diff --git a/src/GF/Command/Importing.hs b/src/GF/Command/Importing.hs index dc8255ad2..8a8cd55bf 100644 --- a/src/GF/Command/Importing.hs +++ b/src/GF/Command/Importing.hs @@ -22,9 +22,7 @@ importGrammar mgr0 opts files = do gr <- batchCompile opts files let name = justModuleName (last files) let (abs,gfcc0) = mkCanon2gfcc opts name gr - (gfcc1,b) <- checkGFCC gfcc0 - if b then return () else do - putStrLn "Corrupted GFCC" + gfcc1 <- checkGFCCio gfcc0 return $ if oElem (iOpt "noopt") opts then gfcc1 else optGFCC gfcc1 "gfcc" -> mapM file2gfcc files >>= return . foldl1 unionGFCC diff --git a/src/GF/Devel/GFC.hs b/src/GF/Devel/GFC.hs index d074cf4fe..6780d32cb 100644 --- a/src/GF/Devel/GFC.hs +++ b/src/GF/Devel/GFC.hs @@ -10,6 +10,7 @@ import GF.GFCC.DataGFCC import GF.GFCC.ParGFCC import GF.Devel.UseIO import GF.Infra.Option +import GF.GFCC.ErrM mainGFC :: [String] -> IO () mainGFC xx = do @@ -20,32 +21,38 @@ mainGFC xx = do gr <- batchCompile opts fs let name = justModuleName (last fs) let (abs,gc0) = mkCanon2gfcc opts name gr - gc1 <- check gc0 + gc1 <- checkGFCCio gc0 let gc = if oElem (iOpt "noopt") opts then gc1 else optGFCC gc1 - let target = abs ++ ".gfcc" - writeFile target (printGFCC gc) - putStrLn $ "wrote file " ++ target - mapM_ (alsoPrint opts abs gc) printOptions + let target = targetName opts abs + let gfccFile = target ++ ".gfcc" + writeFile gfccFile (printGFCC gc) + putStrLn $ "wrote file " ++ gfccFile + mapM_ (alsoPrint opts target gc) printOptions -- gfc -o target.gfcc source_1.gfcc ... source_n.gfcc - _ | all ((=="gfcc") . fileSuffix) fs && oElem (iOpt "o") opts -> do - let target:sources = fs - gfccs <- mapM file2gfcc sources + _ | all ((=="gfcc") . fileSuffix) fs -> do + gfccs <- mapM file2gfcc fs let gfcc = foldl1 unionGFCC gfccs - writeFile target (printGFCC gfcc) + let abs = printCId $ absname gfcc + let target = targetName opts abs + let gfccFile = target ++ ".gfcc" + writeFile gfccFile (printGFCC gfcc) + putStrLn $ "wrote file " ++ gfccFile + mapM_ (alsoPrint opts target gfcc) printOptions _ -> do mapM_ (batchCompile opts) (map return fs) putStrLn "Done." -check gfcc = do - (gc,b) <- checkGFCC gfcc - putStrLn $ if b then "OK" else "Corrupted GFCC" - return gc - -file2gfcc f = - readFileIf f >>= err (error) (return . mkGFCC) . pGrammar . myLexer +file2gfcc f = do + f <- readFileIf f + case pGrammar (myLexer f) of + Ok g -> return (mkGFCC g) + Bad s -> error s +targetName opts abs = case getOptVal opts (aOpt "target") of + Just n -> n + _ -> abs ---- TODO: nicer and richer print options @@ -66,4 +73,4 @@ printOptions = [ ] usageMsg = - "usage: gfc (-h | --make (-noopt) (-js | -jsref | -haskell | -haskell_gadt)) (-src) FILES" + "usage: gfc (-h | --make (-noopt) (-target=PREFIX) (-js | -jsref | -haskell | -haskell_gadt)) (-src) FILES" diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs index e83e7ebe9..7f346619d 100644 --- a/src/GF/Devel/GrammarToGFCC.hs +++ b/src/GF/Devel/GrammarToGFCC.hs @@ -380,7 +380,6 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of P t l -> r2r tr PI t l i -> EInt $ toInteger i - T _ [_] -> error $ "single" +++ prt tr T (TWild _) _ -> error $ "wild" +++ prt tr T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc diff --git a/src/GF/Devel/PrintGFCC.hs b/src/GF/Devel/PrintGFCC.hs index 18c174cd7..864fc07c0 100644 --- a/src/GF/Devel/PrintGFCC.hs +++ b/src/GF/Devel/PrintGFCC.hs @@ -13,3 +13,4 @@ prGFCC printer gr = case printer of "js" -> gfcc2js gr "jsref" -> gfcc2grammarRef gr _ -> printGFCC gr + diff --git a/src/GF/GFCC/CheckGFCC.hs b/src/GF/GFCC/CheckGFCC.hs index bf9a846e3..88a9e12f3 100644 --- a/src/GF/GFCC/CheckGFCC.hs +++ b/src/GF/GFCC/CheckGFCC.hs @@ -1,4 +1,4 @@ -module GF.GFCC.CheckGFCC where +module GF.GFCC.CheckGFCC (checkGFCC, checkGFCCio) where import GF.GFCC.Macros import GF.GFCC.DataGFCC @@ -7,32 +7,47 @@ import GF.GFCC.ErrM import qualified Data.Map as Map import Control.Monad +import Debug.Trace -andMapM :: Monad m => (a -> m Bool) -> [a] -> m Bool -andMapM f xs = mapM f xs >>= return . and +checkGFCCio :: GFCC -> IO GFCC +checkGFCCio gfcc = case checkGFCC gfcc of + Ok (gc,b) -> do + putStrLn $ if b then "OK" else "Corrupted GFCC" + return gc + Bad s -> do + putStrLn s + error "building GFCC failed" -labelBoolIO :: String -> IO (x,Bool) -> IO (x,Bool) -labelBoolIO msg iob = do - (x,b) <- iob - if b then return (x,b) else (putStrLn msg >> return (x,b)) - -checkGFCC :: GFCC -> IO (GFCC,Bool) +checkGFCC :: GFCC -> Err (GFCC,Bool) checkGFCC gfcc = do (cs,bs) <- mapM (checkConcrete gfcc) (Map.assocs (concretes gfcc)) >>= return . unzip return (gfcc {concretes = Map.fromAscList cs}, and bs) -checkConcrete :: GFCC -> (CId,Concr) -> IO ((CId,Concr),Bool) + +-- errors are non-fatal; replace with 'fail' to change this +msg s = trace s (return ()) + +andMapM :: Monad m => (a -> m Bool) -> [a] -> m Bool +andMapM f xs = mapM f xs >>= return . and + +labelBoolErr :: String -> Err (x,Bool) -> Err (x,Bool) +labelBoolErr ms iob = do + (x,b) <- iob + if b then return (x,b) else (msg ms >> return (x,b)) + + +checkConcrete :: GFCC -> (CId,Concr) -> Err ((CId,Concr),Bool) checkConcrete gfcc (lang,cnc) = - labelBoolIO ("happened in language " ++ prt lang) $ do + labelBoolErr ("happened in language " ++ prt lang) $ do (rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip return ((lang,cnc{lins = Map.fromAscList rs}),and bs) where checkl = checkLin gfcc lang -checkLin :: GFCC -> CId -> (CId,Term) -> IO ((CId,Term),Bool) +checkLin :: GFCC -> CId -> (CId,Term) -> Err ((CId,Term),Bool) checkLin gfcc lang (f,t) = - labelBoolIO ("happened in function " ++ prt f) $ do + labelBoolErr ("happened in function " ++ prt f) $ do (t',b) <- checkTerm (lintype gfcc lang f) t --- $ inline gfcc lang t return ((f,t'),b) @@ -82,17 +97,17 @@ inferTerm args trm = case trm of returnt ty = return (trm,ty) infer = inferTerm args -checkTerm :: LinType -> Term -> IO (Term,Bool) +checkTerm :: LinType -> Term -> Err (Term,Bool) checkTerm (args,val) trm = case inferTerm args trm of Ok (t,ty) -> if eqType ty val then return (t,True) else do - putStrLn $ "term: " ++ prt trm ++ + msg ("term: " ++ prt trm ++ "\nexpected type: " ++ prt val ++ - "\ninferred type: " ++ prt ty + "\ninferred type: " ++ prt ty) return (t,False) Bad s -> do - putStrLn s + msg s return (trm,False) eqType :: CType -> CType -> Bool diff --git a/src/GF/GFCC/DataGFCC.hs b/src/GF/GFCC/DataGFCC.hs index 781f76968..69c9a8eb2 100644 --- a/src/GF/GFCC/DataGFCC.hs +++ b/src/GF/GFCC/DataGFCC.hs @@ -99,6 +99,8 @@ printGFCC gfcc0 = compactPrintGFCC $ printTree $ Grm [Lin f v | (f,v) <- assocs (paramlincats cnc)] gfcc = utf8GFCC gfcc0 +printCId :: CId -> String +printCId = printTree -- merge two GFCCs; fails is differens absnames; priority to second arg