diff --git a/lib/resource/Makefile b/lib/resource/Makefile index d16ebef9d..03b923ceb 100644 --- a/lib/resource/Makefile +++ b/lib/resource/Makefile @@ -40,7 +40,8 @@ pretest: echo "gr -cat=Cl -number=11 -prob | tb" | $(GF) -probs=lang.gfprob -path=present:prelude -nocf ../present/Lang???.gfc prelude: - $(GFC) ../prelude/*.gf + $(GFC) ../src/*.gf + cp -p ../src/*.gf? ../prelude alltenses: # $(GFC) arabic/GrammarAra.gf @@ -153,7 +154,11 @@ gfdoc: mv ../prelude/*.html doc/gfdoc gf3: - export GF_LIB_PATH=..; $(MAKE) -e gf3present gf3alltenses + export GF_LIB_PATH=..; $(MAKE) -e gf3prelude gf3present gf3alltenses + +gf3prelude: + $(GFNew) ../src/*.gf + cp -p ../src/*.gfo ../prelude gf3alltenses: # $(GFNew) arabic/GrammarAra.gf diff --git a/lib/resource/english/StructuralEng.gf b/lib/resource/english/StructuralEng.gf index e35b172c0..c6253f6b4 100644 --- a/lib/resource/english/StructuralEng.gf +++ b/lib/resource/english/StructuralEng.gf @@ -20,8 +20,15 @@ concrete StructuralEng of Structural = CatEng ** by8agent_Prep = ss "by" ; by8means_Prep = ss "by" ; can8know_VV, can_VV = { - s = table VVForm [["be able to"] ; "can" ; ["been able to"] ; - ["being able to"] ; "could" ; "can't" ; "couldn't"] ; + s = table { + VVF VInf => ["be able to"] ; + VVF VPres => "can" ; + VVF VPPart => ["been able to"] ; + VVF VPresPart => ["being able to"] ; + VVF VPast => "could" ; --# notpresent + VVPastNeg => "couldn't" ; --# notpresent + VVPresNeg => "can't" + } ; isAux = True } ; during_Prep = ss "during" ; @@ -51,8 +58,15 @@ concrete StructuralEng of Structural = CatEng ** most_Predet = ss "most" ; much_Det = mkDeterminer Sg "much" ; must_VV = { - s = table VVForm [["have to"] ; "must" ; ["had to"] ; - ["having to"] ; ["had to"] ; "mustn't" ; ["hadn't to"]] ; ---- + s = table { + VVF VInf => ["have to"] ; + VVF VPres => "must" ; + VVF VPPart => ["had to"] ; + VVF VPresPart => ["having to"] ; + VVF VPast => ["had to"] ; --# notpresent + VVPastNeg => ["hadn't to"] ; --# notpresent + VVPresNeg => "mustn't" + } ; isAux = True } ; no_Phr = ss "no" ; diff --git a/lib/prelude/Coordination.gf b/lib/src/Coordination.gf similarity index 100% rename from lib/prelude/Coordination.gf rename to lib/src/Coordination.gf diff --git a/lib/prelude/Formal.gf b/lib/src/Formal.gf similarity index 100% rename from lib/prelude/Formal.gf rename to lib/src/Formal.gf diff --git a/lib/prelude/HTML.gf b/lib/src/HTML.gf similarity index 100% rename from lib/prelude/HTML.gf rename to lib/src/HTML.gf diff --git a/lib/prelude/Latex.gf b/lib/src/Latex.gf similarity index 100% rename from lib/prelude/Latex.gf rename to lib/src/Latex.gf diff --git a/lib/prelude/Precedence.gf b/lib/src/Precedence.gf similarity index 100% rename from lib/prelude/Precedence.gf rename to lib/src/Precedence.gf diff --git a/lib/prelude/Predef.gf b/lib/src/Predef.gf similarity index 100% rename from lib/prelude/Predef.gf rename to lib/src/Predef.gf diff --git a/lib/prelude/PredefAbs.gf b/lib/src/PredefAbs.gf similarity index 100% rename from lib/prelude/PredefAbs.gf rename to lib/src/PredefAbs.gf diff --git a/lib/prelude/PredefCnc.gf b/lib/src/PredefCnc.gf similarity index 100% rename from lib/prelude/PredefCnc.gf rename to lib/src/PredefCnc.gf diff --git a/lib/prelude/Prelude.gf b/lib/src/Prelude.gf similarity index 100% rename from lib/prelude/Prelude.gf rename to lib/src/Prelude.gf 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