summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/GF/Canon/GFCC/CheckGFCC.hs81
-rw-r--r--src/GF/Canon/GFCC/DataGFCC.hs1
-rw-r--r--src/GF/Canon/GFCC/Shell.hs2
-rw-r--r--src/GF/Devel/Compile.hs26
-rw-r--r--src/GF/Devel/GFC.hs16
-rw-r--r--src/GF/Devel/GrammarToGFCC.hs2
6 files changed, 118 insertions, 10 deletions
diff --git a/src/GF/Canon/GFCC/CheckGFCC.hs b/src/GF/Canon/GFCC/CheckGFCC.hs
new file mode 100644
index 000000000..cc27f5c1e
--- /dev/null
+++ b/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)
diff --git a/src/GF/Canon/GFCC/DataGFCC.hs b/src/GF/Canon/GFCC/DataGFCC.hs
index eabd8b3a3..f42b48d1b 100644
--- a/src/GF/Canon/GFCC/DataGFCC.hs
+++ b/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
-
diff --git a/src/GF/Canon/GFCC/Shell.hs b/src/GF/Canon/GFCC/Shell.hs
index 5285b89a8..5a2171a03 100644
--- a/src/GF/Canon/GFCC/Shell.hs
+++ b/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
diff --git a/src/GF/Devel/Compile.hs b/src/GF/Devel/Compile.hs
index a89ed4624..2e9de8a16 100644
--- a/src/GF/Devel/Compile.hs
+++ b/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') <-
diff --git a/src/GF/Devel/GFC.hs b/src/GF/Devel/GFC.hs
index f6753e31f..6d9108eea 100644
--- a/src/GF/Devel/GFC.hs
+++ b/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"
+
diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs
index 38811f80d..2742629d5 100644
--- a/src/GF/Devel/GrammarToGFCC.hs
+++ b/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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 23:56:19 +0000