prelude sources to lib/src; present in StructuralEng; refactored checkGFCC

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

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" ;

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

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"

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

src/GF/Devel/PrintGFCC.hs

@@ -13,3 +13,4 @@ prGFCC printer gr = case printer of
   "js" -> gfcc2js gr
   "jsref" -> gfcc2grammarRef gr
   _ -> printGFCC gr
+

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

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