started CheckGFCC

src/GF/Canon/GFCC/CheckGFCC.hs

@@ -0,0 +1,81 @@
+module GF.Canon.GFCC.CheckGFCC where
+
+import GF.Canon.GFCC.DataGFCC
+import GF.Canon.GFCC.AbsGFCC
+import GF.Canon.GFCC.PrintGFCC
+
+import qualified Data.Map as Map
+import Control.Monad
+
+andMapM :: Monad m => (a -> m Bool) -> [a] -> m Bool
+andMapM f xs = mapM f xs >>= return . and
+
+labelBoolIO :: String -> IO Bool -> IO Bool
+labelBoolIO msg iob = do
+  b <- iob
+  if b then return b else (putStrLn msg >> return b)
+
+checkGFCC :: GFCC -> IO Bool
+checkGFCC gfcc = andMapM (checkConcrete gfcc) $ Map.assocs $ concretes gfcc
+
+checkConcrete :: GFCC -> (CId,Map.Map CId Term) -> IO Bool
+checkConcrete gfcc (lang,cnc) = 
+  labelBoolIO (printTree lang) $ andMapM (checkLin gfcc lang) $ linRules cnc
+
+checkLin :: GFCC -> CId -> (CId,Term) -> IO Bool
+checkLin gfcc lang (f,t) = 
+  labelBoolIO (printTree f) $ checkTerm (lintype gfcc lang f) $ inline gfcc lang t
+
+checkTerm :: LinType -> Term -> IO Bool
+checkTerm (args,val) trm = case (val,trm) of
+  (R tys, R trs) -> do
+    let (ntys,ntrs) = (length tys,length trs)
+    b <- checkCond 
+      ("number of fields in " ++ prtrm ++ " does not match " ++ prval) (ntys == ntrs)
+    bs <- andMapM (uncurry check) (zip tys trs)
+    return $ b && bs
+  (R _, W _ r) -> check val r
+  _ -> return True
+ where
+   checkCond msg cond = if cond then return True else (putStrLn msg >> return False)
+   check ty tr = checkTerm (args,ty) tr
+   prtrm = printTree trm
+   prval = printTree val
+
+-- should be in a generic module, but not in the run-time DataGFCC
+
+type LinType = ([Term],Term)
+
+lintype :: GFCC -> CId -> CId -> LinType
+lintype gfcc lang fun = case lookType gfcc fun of
+  Typ cs c -> (map linc cs, linc c)
+ where 
+   linc = lookLincat gfcc lang
+
+lookLincat :: GFCC -> CId -> CId -> Term
+lookLincat gfcc lang (CId cat) = lookLin gfcc lang (CId ("__" ++ cat))
+
+linRules :: Map.Map CId Term -> [(CId,Term)]
+linRules cnc = [(f,t) | (f@(CId (c:_)),t) <- Map.assocs cnc, c /= '_']  ----
+
+inline :: GFCC -> CId -> Term -> Term
+inline gfcc lang t = case t of
+  F c -> inl $ look c
+  _ -> composSafeOp inl t
+ where
+  inl  = inline gfcc lang
+  look = lookLin gfcc lang
+
+composOp :: Monad m => (Term -> m Term) -> Term -> m Term
+composOp f trm = case trm of
+  R  ts -> liftM R $ mapM comp ts
+  S  ts -> liftM S $ mapM comp ts
+  FV ts -> liftM FV $ mapM comp ts
+  P t u -> liftM2 P (comp t) (comp u)
+  W s t -> liftM (W s) $ comp t
+  _ -> return trm
+ where
+   comp = composOp f
+
+composSafeOp :: (Term -> Term) -> Term -> Term
+composSafeOp f = maybe undefined id . composOp (return . f)

src/GF/Canon/GFCC/DataGFCC.hs

@@ -131,4 +131,3 @@ mkGFCC (Grm (Hdr a cs) ab@(Abs funs) ccs) = GFCC {
  where
    mkCnc lins = fromList [(fun,lin) | Lin fun lin <- lins] ---- Asc
 
-

src/GF/Canon/GFCC/Shell.hs

@@ -41,7 +41,7 @@ commands = unlines [
 treat :: MultiGrammar -> String -> IO ()
 treat mgr s = case words s of
   "gt" :cat:n:_ -> mapM_ prlinonly $ take (read1 n) $ generateAll mgr cat
-  "gtt":cat:n:_ -> mapM_ prlin $ generateAll mgr cat
+  "gtt":cat:n:_ -> mapM_ prlin $ take (read1 n) $ generateAll mgr cat
   "gr" :cat:n:_ -> generateRandom mgr cat >>= mapM_ prlinonly . take (read1 n) 
   "grt":cat:n:_ -> generateRandom mgr cat >>= mapM_ prlin . take (read1 n) 
   "p":lang:cat:ws -> do

src/GF/Devel/Compile.hs

@@ -35,6 +35,16 @@ batchCompile opts files = do
   Ok (_,gr) <- appIOE $ foldM (compileModule defOpts) emptyCompileEnv files
   return gr
 
+-- to output an intermediate stage
+intermOut :: Options -> Option -> String -> IOE ()
+intermOut opts opt s = if oElem opt opts then 
+  ioeIO (putStrLn ("\n\n--#" +++ prOpt opt) >> putStrLn s) 
+  else return ()
+
+prMod :: SourceModule -> String
+prMod = compactPrint . prModule
+
+
 -- | environment variable for grammar search path
 gfGrammarPathVar = "GF_GRAMMAR_PATH"
 
@@ -45,6 +55,7 @@ type CompileEnv = (Int,SourceGrammar)
 -- command-line options override options (marked by --#) in the file
 -- As for path: if it is read from file, the file path is prepended to each name.
 -- If from command line, it is used as it is.
+
 compileModule :: Options -> CompileEnv -> FilePath -> IOE CompileEnv
 compileModule opts1 env file = do
   opts0 <- ioeIO $ getOptionsFromFile file
@@ -60,21 +71,20 @@ compileModule opts1 env file = do
   ps <- ioeIO $ extendPathEnv gfLibraryPath gfGrammarPathVar ps1
   let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ()))
   ioeIOIf $ putStrLn $ "module search path:" +++ show ps ----
-  let st = env
+  let sgr = snd env
   let rfs = [] ---- files already in memory and their read times
   let file' = if useFileOpt then justFileName file else file -- to find file itself
   files <- getAllFiles opts ps rfs file'
   ioeIOIf $ putStrLn $ "files to read:" +++ show files ----
   let names = map justModuleName files
   ioeIOIf $ putStrLn $ "modules to include:" +++ show names ----
-  let env0 = compileEnvShSt st names
+  let sgr2 = MGrammar [m | m@(i,_) <- modules sgr, 
+                           notElem (prt i) $ map fileBody names]
+  let env0 = (0,sgr2)
   (e,mm) <- foldIOE (compileOne opts) env0 files
   maybe (return ()) putStrLnE mm
   return e
 
-compileEnvShSt :: CompileEnv -> [ModName] -> CompileEnv
-compileEnvShSt env@(_,sgr) fs = (0,sgr2) where
-  sgr2 = MGrammar [m | m@(i,_) <- modules sgr, notElem (prt i) $ map fileBody fs]
 
 compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
 compileOne opts env@(_,srcgr) file = do
@@ -125,19 +135,25 @@ compileSourceModule opts env@(k,gr) mo@(i,mi) = do
       mos   = modules gr
 
   mo1   <- ioeErr $ rebuildModule mos mo
+  intermOut opts (iOpt "show_rebuild") (prMod mo1)
 
   mo1b  <- ioeErr $ extendModule mos mo1
+  intermOut opts (iOpt "show_extend") (prMod mo1b)
 
   case mo1b of
     (_,ModMod n) | not (isCompleteModule n) -> do
       return (k,mo1b)   -- refresh would fail, since not renamed
     _ -> do
       mo2:_ <- putpp "  renaming " $ ioeErr $ renameModule mos mo1b
+      intermOut opts (iOpt "show_rename") (prMod mo2)
 
       (mo3:_,warnings) <- putpp "  type checking" $ ioeErr $ showCheckModule mos mo2
       if null warnings then return () else putp warnings $ return ()
+      intermOut opts (iOpt "show_typecheck") (prMod mo3)
+
 
       (k',mo3r:_) <- putpp "  refreshing " $ ioeErr $ refreshModule (k,mos) mo3
+      intermOut opts (iOpt "show_refresh") (prMod mo3r)
 
       let eenv = emptyEEnv
       (mo4,eenv') <- 

src/GF/Devel/GFC.hs

@@ -2,6 +2,9 @@ module Main where
 
 import GF.Devel.Compile
 import GF.Devel.GrammarToGFCC
+import GF.Canon.GFCC.CheckGFCC
+import GF.Canon.GFCC.PrintGFCC
+import GF.Canon.GFCC.DataGFCC
 import GF.Devel.UseIO
 import GF.Infra.Option
 ---import GF.Devel.PrGrammar ---
@@ -17,10 +20,19 @@ main = do
     _ | oElem (iOpt "-make") opts -> do
       gr <- batchCompile opts fs
       let name = justModuleName (last fs)
-      let (abs,gc) = prGrammar2gfcc opts name gr
+      let (abs,gc) = mkCanon2gfcc opts name gr
+
+      if oElem (iOpt "check") opts then (check gc) else return ()
+
       let target = abs ++ ".gfcc"
-      writeFile target gc
+      writeFile target (printTree gc)
       putStrLn $ "wrote file " ++ target
     _ -> do
       mapM_ (batchCompile opts) (map return fs)
       putStrLn "Done."
+
+check gc = do
+  let gfcc = mkGFCC gc
+  b <- checkGFCC gfcc
+  putStrLn $ if b then "OK" else "Corrupted GFCC"
+

src/GF/Devel/GrammarToGFCC.hs

@@ -1,4 +1,4 @@
-module GF.Devel.GrammarToGFCC (prGrammar2gfcc) where
+module GF.Devel.GrammarToGFCC (prGrammar2gfcc,mkCanon2gfcc) where
 
 import GF.Grammar.Grammar
 import qualified GF.Grammar.Lookup as Look