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

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