summaryrefslogtreecommitdiff
path: root/src/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler')
-rw-r--r--src/compiler/GF/Compile.hs36
-rw-r--r--src/compiler/GF/Compile/CheckGrammar.hs97
-rw-r--r--src/compiler/GF/Compile/Coding.hs8
-rw-r--r--src/compiler/GF/Compile/Compute/AppPredefined.hs2
-rw-r--r--src/compiler/GF/Compile/GeneratePMCFG.hs480
-rw-r--r--src/compiler/GF/Compile/GrammarToPGF.hs227
-rw-r--r--src/compiler/GF/Compile/Optimize.hs8
-rw-r--r--src/compiler/GF/Compile/Refresh.hs8
-rw-r--r--src/compiler/GF/Compile/Rename.hs4
-rw-r--r--src/compiler/GF/Compile/SubExOpt.hs8
-rw-r--r--src/compiler/GF/Compile/Update.hs18
-rw-r--r--src/compiler/GF/Grammar/Analyse.hs8
-rw-r--r--src/compiler/GF/Grammar/Binary.hs42
-rw-r--r--src/compiler/GF/Grammar/CF.hs7
-rw-r--r--src/compiler/GF/Grammar/Grammar.hs35
-rw-r--r--src/compiler/GF/Grammar/Lookup.hs22
-rw-r--r--src/compiler/GF/Grammar/Macros.hs9
-rw-r--r--src/compiler/GF/Grammar/Parser.y32
-rw-r--r--src/compiler/GF/Grammar/Printer.hs58
-rw-r--r--src/compiler/GF/Infra/Option.hs12
-rw-r--r--src/compiler/GFTags.hs10
21 files changed, 608 insertions, 523 deletions
diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs
index c737480e1..597044845 100644
--- a/src/compiler/GF/Compile.hs
+++ b/src/compiler/GF/Compile.hs
@@ -6,6 +6,7 @@ import GF.Compile.Rename
import GF.Compile.CheckGrammar
import GF.Compile.Optimize
import GF.Compile.SubExOpt
+import GF.Compile.GeneratePMCFG
import GF.Compile.GrammarToPGF
import GF.Compile.ReadFiles
import GF.Compile.Update
@@ -55,7 +56,8 @@ link :: Options -> Ident -> SourceGrammar -> IOE PGF
link opts cnc gr = do
let isv = (verbAtLeast opts Normal)
putPointE Normal opts "linking ... " $ do
- pgf <- ioeIO (mkCanon2pgf opts cnc gr)
+ let abs = err (const cnc) id $ abstractOfConcrete gr cnc
+ pgf <- ioeIO (mkCanon2pgf opts gr abs)
probs <- ioeIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
ioeIO $ when (verbAtLeast opts Normal) $ putStrFlush "OK"
return $ setProbabilities probs
@@ -183,9 +185,9 @@ compileSourceModule opts env@(k,gr,_) mb_gfo mo@(i,mi) = do
(_,n) | not (isCompleteModule n) -> do
case mb_gfo of
Just gfo -> if flag optMode opts /= ModeTags
- then putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo mo1b
- else putStrLnE "" >> return mo1b
- Nothing -> return mo1b
+ then writeGFO opts gfo mo1b
+ else putStrLnE ""
+ Nothing -> return ()
extendCompileEnvInt env k mb_gfo mo1b
_ -> do
@@ -206,22 +208,26 @@ compileSourceModule opts env@(k,gr,_) mb_gfo mo@(i,mi) = do
mo4 <- putpp " optimizing " $ ioeErr $ optimizeModule opts mos mo3r
intermOut opts DumpOptimize (ppModule Qualified mo4)
+ mo5 <- if isModCnc (snd mo4) && flag optPMCFG opts
+ then putpp " generating PMCFG " $ ioeIO $ generatePMCFG opts mos mo4
+ else return mo4
+ intermOut opts DumpCanon (ppModule Qualified mo5)
+
case mb_gfo of
- Just gfo -> putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo mo4
- Nothing -> return mo4
-
- extendCompileEnvInt env k' mb_gfo mo4
+ Just gfo -> writeGFO opts gfo mo5
+ Nothing -> return ()
+
+ extendCompileEnvInt env k' mb_gfo mo5
else do putStrLnE ""
extendCompileEnvInt env k mb_gfo mo3
-generateModuleCode :: Options -> FilePath -> SourceModule -> IOE SourceModule
-generateModuleCode opts file minfo = do
- let minfo1 = subexpModule minfo
- minfo2 = case minfo1 of
- (m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi)})
- putPointE Normal opts (" wrote file" +++ file) $ ioeIO $ encodeFile file minfo2
- return minfo1
+writeGFO :: Options -> FilePath -> SourceModule -> IOE ()
+writeGFO opts file mo = do
+ let mo1 = subexpModule mo
+ mo2 = case mo1 of
+ (m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi)})
+ putPointE Normal opts (" write file" +++ file) $ ioeIO $ encodeFile file mo2
-- auxiliaries
diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index 2b82bc781..1770e60e8 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -102,52 +102,52 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
return info
_ -> return info
case info of
- CncCat (Just (L loc (RecType []))) _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
- _ -> Bad "no def lin"
+ CncCat (Just (L loc (RecType []))) _ _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
+ _ -> Bad "no def lin"
case lookupIdent c js of
Ok (AnyInd _ _) -> return js
- Ok (CncFun ty (Just def) pn) ->
- return $ updateTree (c,CncFun ty (Just def) pn) js
- Ok (CncFun ty Nothing pn) ->
+ Ok (CncFun ty (Just def) mn mf) ->
+ return $ updateTree (c,CncFun ty (Just def) mn mf) js
+ Ok (CncFun ty Nothing mn mf) ->
case mb_def of
- Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) pn) js
+ Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) mn mf) js
Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
return js
_ -> do
case mb_def of
Ok def -> do (cont,val) <- linTypeOfType gr cm ty
let linty = (snd (valCat ty),cont,val)
- return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing) js
+ return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js
Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
return js
AbsCat (Just _) -> case lookupIdent c js of
Ok (AnyInd _ _) -> return js
- Ok (CncCat (Just _) _ _) -> return js
- Ok (CncCat _ mt mp) -> do
+ Ok (CncCat (Just _) _ _ _) -> return js
+ Ok (CncCat _ mt mp mpmcfg) -> do
checkWarn $
text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
- return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) mt mp) js
+ return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) mt mp mpmcfg) js
_ -> do
checkWarn $
text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
- return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing) js
+ return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing) js
_ -> return js
checkCnc js i@(c,info) =
case info of
- CncFun _ d pn -> case lookupOrigInfo gr (am,c) of
- Ok (_,AbsFun (Just (L _ ty)) _ _ _) ->
- do (cont,val) <- linTypeOfType gr cm ty
- let linty = (snd (valCat ty),cont,val)
- return $ updateTree (c,CncFun (Just linty) d pn) js
- _ -> do checkWarn $ text "function" <+> ppIdent c <+> text "is not in abstract"
+ CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
+ Ok (_,AbsFun (Just (L _ ty)) _ _ _) ->
+ do (cont,val) <- linTypeOfType gr cm ty
+ let linty = (snd (valCat ty),cont,val)
+ return $ updateTree (c,CncFun (Just linty) d mn mf) js
+ _ -> do checkWarn $ text "function" <+> ppIdent c <+> text "is not in abstract"
+ return js
+ CncCat _ _ _ _ -> case lookupOrigInfo gr (am,c) of
+ Ok _ -> return $ updateTree i js
+ _ -> do checkWarn $ text "category" <+> ppIdent c <+> text "is not in abstract"
return js
- CncCat _ _ _ -> case lookupOrigInfo gr (am,c) of
- Ok _ -> return $ updateTree i js
- _ -> do checkWarn $ text "category" <+> ppIdent c <+> text "is not in abstract"
- return js
- _ -> return $ updateTree i js
+ _ -> return $ updateTree i js
-- | General Principle: only Just-values are checked.
@@ -170,21 +170,41 @@ checkInfo ms (m,mo) c info = do
Nothing -> return ()
return (AbsFun (Just (L loc typ)) ma md moper)
- CncFun linty@(Just (cat,cont,val)) (Just (L loc trm)) mpr -> chIn loc "linearization of" $ do
- (trm',_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars
- mpr <- checkPrintname gr mpr
- return (CncFun linty (Just (L loc trm')) mpr)
+ CncCat mty mdef mpr mpmcfg -> do
+ mty <- case mty of
+ Just (L loc typ) -> chIn loc "linearization type of" $ do
+ (typ,_) <- checkLType gr [] typ typeType
+ typ <- computeLType gr [] typ
+ return (Just (L loc typ))
+ Nothing -> return Nothing
+ mdef <- case (mty,mdef) of
+ (Just (L _ typ),Just (L loc def)) ->
+ chIn loc "default linearization of" $ do
+ (def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
+ return (Just (L loc def))
+ _ -> return Nothing
+ mpr <- case mpr of
+ (Just (L loc t)) ->
+ chIn loc "print name of" $ do
+ (t,_) <- checkLType gr [] t typeStr
+ return (Just (L loc t))
+ _ -> return Nothing
+ return (CncCat mty mdef mpr mpmcfg)
- CncCat (Just (L loc typ)) mdef mpr -> chIn loc "linearization type of" $ do
- (typ,_) <- checkLType gr [] typ typeType
- typ <- computeLType gr [] typ
- mdef <- case mdef of
- Just (L loc def) -> do
- (def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
- return $ Just (L loc def)
- _ -> return mdef
- mpr <- checkPrintname gr mpr
- return (CncCat (Just (L loc typ)) mdef mpr)
+ CncFun mty mt mpr mpmcfg -> do
+ mt <- case (mty,mt) of
+ (Just (cat,cont,val),Just (L loc trm)) ->
+ chIn loc "linearization of" $ do
+ (trm,_) <- checkLType gr [] trm (mkProd cont val [])
+ return (Just (L loc trm))
+ _ -> return mt
+ mpr <- case mpr of
+ (Just (L loc t)) ->
+ chIn loc "print name of" $ do
+ (t,_) <- checkLType gr [] t typeStr
+ return (Just (L loc t))
+ _ -> return Nothing
+ return (CncFun mty mt mpr mpmcfg)
ResOper pty pde -> do
(pty', pde') <- case (pty,pde) of
@@ -252,11 +272,6 @@ checkInfo ms (m,mo) c info = do
_ -> composOp (compAbsTyp g) t
-checkPrintname :: SourceGrammar -> Maybe (L Term) -> Check (Maybe (L Term))
-checkPrintname gr (Just (L loc t)) = do (t,_) <- checkLType gr [] t typeStr
- return (Just (L loc t))
-checkPrintname gr Nothing = return Nothing
-
-- | for grammars obtained otherwise than by parsing ---- update!!
checkReservedId :: Ident -> Check ()
checkReservedId x
diff --git a/src/compiler/GF/Compile/Coding.hs b/src/compiler/GF/Compile/Coding.hs
index 1b8753afe..5dc463d0e 100644
--- a/src/compiler/GF/Compile/Coding.hs
+++ b/src/compiler/GF/Compile/Coding.hs
@@ -20,10 +20,10 @@ codeSourceModule :: (String -> String) -> SourceModule -> SourceModule
codeSourceModule co (id,mo) = (id,mo{jments = mapTree codj (jments mo)})
where
codj (c,info) = case info of
- ResOper pty pt -> ResOper (codeLTerms co pty) (codeLTerms co pt)
- ResOverload es tyts -> ResOverload es [(codeLTerm co ty,codeLTerm co t) | (ty,t) <- tyts]
- CncCat pty pt mpr -> CncCat pty (codeLTerms co pt) (codeLTerms co mpr)
- CncFun mty pt mpr -> CncFun mty (codeLTerms co pt) (codeLTerms co mpr)
+ ResOper pty pt -> ResOper (codeLTerms co pty) (codeLTerms co pt)
+ ResOverload es tyts -> ResOverload es [(codeLTerm co ty,codeLTerm co t) | (ty,t) <- tyts]
+ CncCat mty mt mpr mpmcfg -> CncCat mty (codeLTerms co mt) (codeLTerms co mpr) mpmcfg
+ CncFun mty mt mpr mpmcfg -> CncFun mty (codeLTerms co mt) (codeLTerms co mpr) mpmcfg
_ -> info
codeLTerms co = fmap (codeLTerm co)
diff --git a/src/compiler/GF/Compile/Compute/AppPredefined.hs b/src/compiler/GF/Compile/Compute/AppPredefined.hs
index af440ba0d..514b471c4 100644
--- a/src/compiler/GF/Compile/Compute/AppPredefined.hs
+++ b/src/compiler/GF/Compile/Compute/AppPredefined.hs
@@ -45,7 +45,7 @@ arrityPredefined f = do ty <- typPredefined f
return (length ctxt)
predefModInfo :: SourceModInfo
-predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" primitives
+predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" Nothing primitives
primitives = Map.fromList
[ (cErrorType, ResOper (Just (noLoc typeType)) Nothing)
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs
index aaa4a2961..f4f1a3fca 100644
--- a/src/compiler/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/GF/Compile/GeneratePMCFG.hs
@@ -10,10 +10,11 @@
-----------------------------------------------------------------------------
module GF.Compile.GeneratePMCFG
- (convertConcrete) where
+ (generatePMCFG, pgfCncCat
+ ) where
import PGF.CId
-import PGF.Data hiding (Type)
+import PGF.Data hiding (Type, Production)
import GF.Infra.Option
import GF.Grammar hiding (Env, mkRecord, mkTable)
@@ -28,9 +29,11 @@ import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.List as List
import qualified Data.IntMap as IntMap
+import qualified Data.IntSet as IntSet
import qualified Data.ByteString.Char8 as BS
import Text.PrettyPrint hiding (Str)
import Data.Array.IArray
+import Data.Array.Unboxed
import Data.Maybe
import Data.Char (isDigit)
import Control.Monad
@@ -40,155 +43,83 @@ import Control.Exception
----------------------------------------------------------------------
-- main conversion function
-
-convertConcrete :: Options -> SourceGrammar -> SourceModule -> SourceModule -> IO Concr
-convertConcrete opts0 gr am cm = do
- let env = emptyGrammarEnv gr cm
- when (flag optProf opts) $ do
- profileGrammar cm env pfrules
- env <- foldM (convertLinDef gr opts) env pflindefs
- env <- foldM (convertRule gr opts) env pfrules
- return $ getConcr flags printnames env
- where
- (m,mo) = cm
-
- opts = addOptions (mflags (snd am)) opts0
-
- pflindefs = [
- ((m,id),term,lincat) |
- (id,GF.Grammar.CncCat (Just (L _ lincat)) (Just (L _ term)) _) <- Map.toList (jments mo)]
-
- pfrules = [
- (PFRule id args ([],res) (map (\(_,_,ty) -> ty) cont) val term) |
- (id,GF.Grammar.CncFun (Just (cat,cont,val)) (Just (L _ term)) _) <- Map.toList (jments mo),
- let (ctxt,res,_) = err error typeForm (lookupFunType gr (fst am) id)
- args = [catSkeleton ty | (_,_,ty) <- ctxt]]
-
- flags = Map.fromList [(mkCId f,LStr x) | (f,x) <- optionsPGF (mflags mo)]
-
- printnames = Map.fromAscList [(i2i id, name) | (id,info) <- Map.toList (jments mo), name <- prn info]
- where
- prn (GF.Grammar.CncFun _ _ (Just (L _ tr))) = [flatten tr]
- prn (GF.Grammar.CncCat _ _ (Just (L _ tr))) = [flatten tr]
- prn _ = []
-
- flatten (K s) = s
- flatten (Alts x _) = flatten x
- flatten (C x y) = flatten x +++ flatten y
-
-i2i :: Ident -> CId
-i2i = CId . ident2bs
-
-profileGrammar (m,mo) env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) pfrules = do
- hPutStrLn stderr ""
- hPutStrLn stderr ("Language: " ++ showIdent m)
- hPutStrLn stderr ""
- hPutStrLn stderr "Categories Count"
- hPutStrLn stderr "--------------------------------"
- mapM_ profileCat (Map.toList catSet)
- hPutStrLn stderr "--------------------------------"
- hPutStrLn stderr ""
- hPutStrLn stderr "Rules Count"
- hPutStrLn stderr "--------------------------------"
- mapM_ profileRule pfrules
- hPutStrLn stderr "--------------------------------"
+generatePMCFG :: Options -> [SourceModule] -> SourceModule -> IO SourceModule
+generatePMCFG opts mos cmo@(cm,cmi) = do
+ (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr am cm) Map.empty (jments cmi)
+ when (verbAtLeast opts Verbose) $ hPutStrLn stderr ""
+ return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js})
where
- profileCat (cid,(fcat1,fcat2,_)) = do
- hPutStrLn stderr (lformat 23 (showIdent cid) ++ rformat 9 (show (fcat2-fcat1+1)))
-
- profileRule (PFRule fun args res ctypes ctype term) = do
- let pargs = map (protoFCat env) args
- hPutStrLn stderr (lformat 23 (showIdent fun) ++ rformat 9 (show (product (map (catFactor env) args))))
- where
- catFactor (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (n,(_,cat)) =
- case Map.lookup cat catSet of
- Just (s,e,_) -> e-s+1
- Nothing -> 0
-
- lformat :: Int -> String -> String
- lformat n s = s ++ replicate (n-length s) ' '
-
- rformat :: Int -> String -> String
- rformat n s = replicate (n-length s) ' ' ++ s
-
-data ProtoFRule = PFRule Ident {- function -}
- [([Cat],Cat)] {- argument types: context size and category -}
- ([Cat],Cat) {- result type : context size (always 0) and category -}
- [Type] {- argument lin-types representation -}
- Type {- result lin-type representation -}
- Term {- body -}
-
-optimize :: [ProtoFCat] -> GrammarEnv -> GrammarEnv
-optimize pargs (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) =
- IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet IntMap.empty prodSet) appSet
+ gr = mGrammar (cmo:mos)
+ MTConcrete am = mtype cmi
+
+mapAccumWithKeyM :: (Monad m, Ord k) => (a -> k -> b -> m (a,c)) -> a
+ -> Map.Map k b -> m (a,Map.Map k c)
+mapAccumWithKeyM f a m = do let xs = Map.toAscList m
+ (a,ys) <- mapAccumM f a xs
+ return (a,Map.fromAscList ys)
where
- optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | (funid,args) <- Set.toList ps])
- where
- ff :: FunId -> [[FId]] -> GrammarEnv -> GrammarEnv
- ff funid xs env
- | product (map Set.size ys) == count
- = case List.mapAccumL (\env c -> addCoercion env (Set.toList c)) env ys of
- (env,args) -> let xs = sequence (zipWith addContext pargs args)
- in List.foldl (\env x -> addProduction env cat (PApply funid x)) env xs
- | otherwise = List.foldl (\env args -> let xs = sequence (zipWith addContext pargs args)
- in List.foldl (\env x -> addProduction env cat (PApply funid x)) env xs) env xs
- where
- count = length xs
- ys = foldr (zipWith Set.insert) (repeat Set.empty) xs
-
- addContext (PFCat ctxt _ _) fid = do hyps <- mapM toCncHypo ctxt
- return (PArg hyps fid)
-
- toCncHypo cat =
- case Map.lookup cat catSet of
- Just (s,e,_) -> do fid <- range (s,e)
- guard (fid `IntMap.member` lindefSet)
- return (fidVar,fid)
- Nothing -> mzero
-
-convertRule :: SourceGrammar -> Options -> GrammarEnv -> ProtoFRule -> IO GrammarEnv
-convertRule gr opts grammarEnv (PFRule fun args res ctypes ctype term) = do
- let pres = protoFCat grammarEnv res
- pargs = map (protoFCat grammarEnv) args
-
- b = runCnvMonad gr (unfactor term >>= convertTerm opts CNil ctype) (pargs,[])
- (grammarEnv1,b1) = addSequencesB grammarEnv b
- grammarEnv2 = foldBM addRule
- grammarEnv1
- (goB b1 CNil [])
- (pres,pargs)
- grammarEnv3 = optimize pargs grammarEnv2
- when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showIdent fun)
- return $! grammarEnv3
+ mapAccumM f a [] = return (a,[])
+ mapAccumM f a ((k,x):kxs) = do (a,y ) <- f a k x
+ (a,kys) <- mapAccumM f a kxs
+ return (a,(k,y):kys)
+
+
+addPMCFG :: Options -> SourceGrammar -> Ident -> Ident -> SeqSet -> Ident -> Info -> IO (SeqSet, Info)
+addPMCFG opts gr am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L _ term)) mprn _) = do
+ let pres = protoFCat gr res val
+ pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
+
+ pmcfgEnv0 = emptyPMCFGEnv
+
+ b = runCnvMonad gr (unfactor term >>= convertTerm opts CNil val) (pargs,[])
+ (seqs1,b1) = addSequencesB seqs b
+ pmcfgEnv1 = foldBM addRule
+ pmcfgEnv0
+ (goB b1 CNil [])
+ (pres,pargs)
+ pmcfg = getPMCFG pmcfgEnv1
+
+ stats = let PMCFG prods funs = pmcfg
+ (s,e) = bounds funs
+ !prods_cnt = length prods
+ !funs_cnt = e-s+1
+ in (prods_cnt,funs_cnt)
+
+ when (verbAtLeast opts Verbose) $ hPutStr stderr ("\n+ "++showIdent id ++ " " ++ show (product (map catFactor pargs)))
+ seqs1 `seq` stats `seq` return ()
+ when (verbAtLeast opts Verbose) $ hPutStr stderr (" "++show stats)
+ return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg))
where
+ (ctxt,res,_) = err error typeForm (lookupFunType gr am id)
+
addRule lins (newCat', newArgs') env0 =
- let [newCat] = getFIds env0 newCat'
- (env1, newArgs) = List.mapAccumL (\env -> addCoercion env . getFIds env) env0 newArgs'
-
- (env2,funid) = addCncFun env1 (PGF.Data.CncFun (i2i fun) (mkArray lins))
-
- in addApplication env2 newCat (funid,newArgs)
-
-convertLinDef :: SourceGrammar -> Options -> GrammarEnv -> (Cat,Term,Type) -> IO GrammarEnv
-convertLinDef gr opts grammarEnv (cat,lindef,lincat) = do
- let pres = protoFCat grammarEnv ([],cat)
- parg = protoFCat grammarEnv ([],(identW,cVar))
-
- b = runCnvMonad gr (unfactor lindef >>= convertTerm opts CNil lincat) ([parg],[])
- (grammarEnv1,b1) = addSequencesB grammarEnv b
- grammarEnv2 = foldBM addRule
- grammarEnv1
- (goB b1 CNil [])
- (pres,[parg])
- when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showCId lindefCId)
- return $! grammarEnv2
+ let [newCat] = getFIds newCat'
+ !fun = mkArray lins
+ newArgs = map getFIds newArgs'
+ in addFunction env0 newCat fun newArgs
+
+addPMCFG opts gr am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L _ term)) mprn _) = do
+ let pres = protoFCat gr (am,id) lincat
+ parg = protoFCat gr (identW,cVar) typeStr
+
+ pmcfgEnv0 = emptyPMCFGEnv
+
+ b = runCnvMonad gr (unfactor term >>= convertTerm opts CNil lincat) ([parg],[])
+ (seqs1,b1) = addSequencesB seqs b
+ pmcfgEnv1 = foldBM addRule
+ pmcfgEnv0
+ (goB b1 CNil [])
+ (pres,[parg])
+ pmcfg = getPMCFG pmcfgEnv1
+ when (verbAtLeast opts Verbose) $ hPutStr stderr ("\n+ "++showIdent id++" "++show (catFactor pres))
+ seqs1 `seq` pmcfg `seq` return (seqs1,GF.Grammar.CncCat mty mdef mprn (Just pmcfg))
where
- lindefCId = mkCId ("lindef "++showIdent (snd cat))
-
addRule lins (newCat', newArgs') env0 =
- let [newCat] = getFIds env0 newCat'
- (env1,funid) = addCncFun env0 (PGF.Data.CncFun lindefCId (mkArray lins))
- in addLinDef env1 newCat funid
+ let [newCat] = getFIds newCat'
+ !fun = mkArray lins
+ in addFunction env0 newCat fun [[fidVar]]
+
+addPMCFG opts gr am cm seqs id info = return (seqs, info)
unfactor :: Term -> CnvMonad Term
unfactor t = CM (\gr c -> c (unfac gr t))
@@ -202,6 +133,22 @@ unfactor t = CM (\gr c -> c (unfac gr t))
Vr y | y == x -> u
_ -> composSafeOp (restore x u) t
+pgfCncCat :: SourceGrammar -> Type -> Int -> PGF.Data.CncCat
+pgfCncCat gr lincat index =
+ let ((_,size),schema) = computeCatRange gr lincat
+ in PGF.Data.CncCat index
+ (index+size-1)
+ (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath)
+ (getStrPaths schema)))
+ where
+ getStrPaths :: Schema Identity s c -> [Path]
+ getStrPaths = collect CNil []
+ where
+ collect path paths (CRec rs) = foldr (\(lbl,Identity t) paths -> collect (CProj lbl path) paths t) paths rs
+ collect path paths (CTbl _ cs) = foldr (\(trm,Identity t) paths -> collect (CSel trm path) paths t) paths cs
+ collect path paths (CStr _) = reversePath path : paths
+ collect path paths (CPar _) = paths
+
----------------------------------------------------------------------
-- CnvMonad monad
--
@@ -248,7 +195,7 @@ variants xs = CM (\gr c s -> Variant [c x s | x <- xs])
choices :: Int -> Path -> CnvMonad Term
choices nr path = do (args,_) <- get
let PFCat _ _ schema = args !! nr
- descend schema path CNil
+ descend schema path CNil
where
descend (CRec rs) (CProj lbl path) rpath = case lookup lbl rs of
Just (Identity t) -> descend t path (CProj lbl rpath)
@@ -305,15 +252,43 @@ data Path
-- The annotations are as follows: the strings are annotated with
-- their index in the PMCFG tuple, the parameters are annotated
-- with their value both as term and as index.
-data ProtoFCat = PFCat [Ident] Ident Proto
+data ProtoFCat = PFCat Ident Int (Schema Identity Int (Int,[(Term,Int)]))
type Env = (ProtoFCat, [ProtoFCat])
-protoFCat :: GrammarEnv -> ([Cat],Cat) -> ProtoFCat
-protoFCat (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (ctxt,(_,cat)) =
- case Map.lookup cat catSet of
- Just (_,_,proto) -> PFCat (map snd ctxt) cat proto
- Nothing -> error "unknown category"
-
+protoFCat :: SourceGrammar -> Cat -> Type -> ProtoFCat
+protoFCat gr cat lincat =
+ case computeCatRange gr lincat of
+ ((_,f),schema) -> PFCat (snd cat) f schema
+
+getFIds :: ProtoFCat -> [FId]
+getFIds (PFCat _ _ schema) =
+ reverse (solutions (variants schema) ())
+ where
+ variants (CRec rs) = fmap sum $ mapM (\(lbl,Identity t) -> variants t) rs
+ variants (CTbl _ cs) = fmap sum $ mapM (\(trm,Identity t) -> variants t) cs
+ variants (CStr _) = return 0
+ variants (CPar (m,values)) = do (value,index) <- member values
+ return (m*index)
+
+catFactor :: ProtoFCat -> Int
+catFactor (PFCat _ f _) = f
+
+computeCatRange gr lincat = compute (0,1) lincat
+ where
+ compute st (RecType rs) = let (st',rs') = List.mapAccumL (\st (lbl,t) -> let (st',t') = compute st t
+ in (st',(lbl,Identity t'))) st rs
+ in (st',CRec rs')
+ compute st (Table pt vt) = let vs = err error id (allParamValues gr pt)
+ (st',cs') = List.mapAccumL (\st v -> let (st',vt') = compute st vt
+ in (st',(v,Identity vt'))) st vs
+ in (st',CTbl pt cs')
+ compute st (Sort s)
+ | s == cStr = let (index,m) = st
+ in ((index+1,m),CStr index)
+ compute st t = let vs = err error id (allParamValues gr t)
+ (index,m) = st
+ in ((index,m*length vs),CPar (m,zip vs [0..]))
+
ppPath (CProj lbl path) = ppLabel lbl <+> ppPath path
ppPath (CSel trm path) = ppTerm Unqualified 5 trm <+> ppPath path
ppPath CNil = empty
@@ -363,7 +338,7 @@ convertArg opts (Table pt vt) nr path = do
mkTable pt (map (\v -> (v,convertArg opts vt nr (CSel v path))) vs)
convertArg opts (Sort _) nr path = do
(args,_) <- get
- let PFCat _ cat schema = args !! nr
+ let PFCat cat _ schema = args !! nr
l = index (reversePath path) schema
sym | CProj (LVar i) CNil <- path = SymVar nr i
| isLiteralCat opts cat = SymLit nr l
@@ -411,26 +386,31 @@ goV (CTbl _ xs) rpath ss = foldM (\ss (trm,b) -> goB b (CSel trm rpath) ss) ss
goV (CStr seqid) rpath ss = return (seqid : ss)
goV (CPar t) rpath ss = restrictHead (reversePath rpath) t >> return ss
-addSequencesB :: GrammarEnv -> Branch (Value [Symbol]) -> (GrammarEnv, Branch (Value SeqId))
-addSequencesB env (Case nr path bs) = let (env1,bs1) = List.mapAccumL (\env (trm,b) -> let (env',b') = addSequencesB env b
- in (env',(trm,b'))) env bs
- in (env1,Case nr path bs1)
-addSequencesB env (Variant bs) = let (env1,bs1) = List.mapAccumL addSequencesB env bs
- in (env1,Variant bs1)
-addSequencesB env (Return v) = let (env1,v1) = addSequencesV env v
- in (env1,Return v1)
-
-addSequencesV :: GrammarEnv -> Value [Symbol] -> (GrammarEnv, Value SeqId)
-addSequencesV env (CRec vs) = let (env1,vs1) = List.mapAccumL (\env (lbl,b) -> let (env',b') = addSequencesB env b
- in (env',(lbl,b'))) env vs
- in (env1,CRec vs1)
-addSequencesV env (CTbl pt vs)=let (env1,vs1) = List.mapAccumL (\env (trm,b) -> let (env',b') = addSequencesB env b
- in (env',(trm,b'))) env vs
- in (env1,CTbl pt vs1)
-addSequencesV env (CStr lin) = let (env1,seqid) = addSequence env (optimizeLin lin)
- in (env1,CStr seqid)
-addSequencesV env (CPar i) = (env,CPar i)
+----------------------------------------------------------------------
+-- SeqSet
+
+type SeqSet = Map.Map Sequence SeqId
+
+addSequencesB :: SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
+addSequencesB seqs (Case nr path bs) = let (seqs1,bs1) = List.mapAccumL (\seqs (trm,b) -> let (seqs',b') = addSequencesB seqs b
+ in (seqs',(trm,b'))) seqs bs
+ in (seqs1,Case nr path bs1)
+addSequencesB seqs (Variant bs) = let (seqs1,bs1) = List.mapAccumL addSequencesB seqs bs
+ in (seqs1,Variant bs1)
+addSequencesB seqs (Return v) = let (seqs1,v1) = addSequencesV seqs v
+ in (seqs1,Return v1)
+
+addSequencesV :: SeqSet -> Value [Symbol] -> (SeqSet, Value SeqId)
+addSequencesV seqs (CRec vs) = let (seqs1,vs1) = List.mapAccumL (\seqs (lbl,b) -> let (seqs',b') = addSequencesB seqs b
+ in (seqs',(lbl,b'))) seqs vs
+ in (seqs1,CRec vs1)
+addSequencesV seqs (CTbl pt vs)=let (seqs1,vs1) = List.mapAccumL (\seqs (trm,b) -> let (seqs',b') = addSequencesB seqs b
+ in (seqs',(trm,b'))) seqs vs
+ in (seqs1,CTbl pt vs1)
+addSequencesV seqs (CStr lin) = let (seqs1,seqid) = addSequence seqs (optimizeLin lin)
+ in (seqs1,CStr seqid)
+addSequencesV seqs (CPar i) = (seqs,CPar i)
optimizeLin [] = []
optimizeLin lin@(SymKS _ : _) =
@@ -442,6 +422,15 @@ optimizeLin lin@(SymKS _ : _) =
getRest lin = ([],lin)
optimizeLin (sym : lin) = sym : optimizeLin lin
+addSequence :: SeqSet -> [Symbol] -> (SeqSet,SeqId)
+addSequence seqs lst =
+ case Map.lookup seq seqs of
+ Just id -> (seqs,id)
+ Nothing -> let !last_seq = Map.size seqs
+ in (Map.insert seq last_seq seqs, last_seq)
+ where
+ seq = mkArray lst
+
------------------------------------------------------------
-- eval a term to ground terms
@@ -478,124 +467,36 @@ getVarIndex (IC s) | isDigit (BS.last s) = (read . BS.unpack . snd . BS.spanEnd
----------------------------------------------------------------------
-- GrammarEnv
-data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet LinDefSet CoerceSet AppSet ProdSet
-type Proto = Schema Identity Int (Int,[(Term,Int)])
-type CatSet = Map.Map Ident (FId,FId,Proto)
-type SeqSet = Map.Map Sequence SeqId
-type FunSet = Map.Map CncFun FunId
-type LinDefSet= IntMap.IntMap [FunId]
-type CoerceSet= Map.Map [FId] FId
-type AppSet = IntMap.IntMap (Set.Set (FunId,[FId]))
-type ProdSet = IntMap.IntMap (Set.Set Production)
-
-emptyGrammarEnv gr (m,mo) =
- let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats
- in GrammarEnv last_id catSet Map.empty Map.empty IntMap.empty Map.empty IntMap.empty IntMap.empty
- where
- computeCatRange index cat ctype
- | cat == cString = (index,(fidString,fidString,CRec [(theLinLabel,Identity (CStr 0))]))
- | cat == cInt = (index,(fidInt, fidInt, CRec [(theLinLabel,Identity (CStr 0))]))
- | cat == cFloat = (index,(fidFloat, fidFloat, CRec [(theLinLabel,Identity (CStr 0))]))
- | cat == cVar = (index,(fidVar, fidVar, CStr 0))
- | otherwise = (index+size,(index,index+size-1,schema))
- where
- ((_,size),schema) = compute (0,1) ctype
-
- compute st (RecType rs) = let (st',rs') = List.mapAccumL (\st (lbl,t) -> let (st',t') = compute st t
- in (st',(lbl,Identity t'))) st rs
- in (st',CRec rs')
- compute st (Table pt vt) = let vs = err error id (allParamValues gr pt)
- (st',cs') = List.mapAccumL (\st v -> let (st',vt') = compute st vt
- in (st',(v,Identity vt'))) st vs
- in (st',CTbl pt cs')
- compute st (Sort s)
- | s == cStr = let (index,m) = st
- in ((index+1,m),CStr index)
- compute st t = let vs = err error id (allParamValues gr t)
- (index,m) = st
- in ((index,m*length vs),CPar (m,zip vs [0..]))
+data PMCFGEnv = PMCFGEnv !ProdSet !FunSet
+type ProdSet = Set.Set Production
+type FunSet = Map.Map (UArray LIndex SeqId) FunId
- lincats =
- Map.insert cVar (Sort cStr) $
- Map.fromAscList
- [(c, ty) | (c,GF.Grammar.CncCat (Just (L _ ty)) _ _) <- Map.toList (jments mo)]
-
-addApplication :: GrammarEnv -> FId -> (FunId,[FId]) -> GrammarEnv
-addApplication (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fid p =
- GrammarEnv last_id catSet seqSet funSet lindefSet crcSet (IntMap.insertWith Set.union fid (Set.singleton p) appSet) prodSet
-
-addProduction :: GrammarEnv -> FId -> Production -> GrammarEnv
-addProduction (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) cat p =
- GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet)
-
-addSequence :: GrammarEnv -> [Symbol] -> (GrammarEnv,SeqId)
-addSequence env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) lst =
- case Map.lookup seq seqSet of
- Just id -> (env,id)
- Nothing -> let !last_seq = Map.size seqSet
- in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet lindefSet crcSet appSet prodSet,last_seq)
- where
- seq = mkArray lst
+emptyPMCFGEnv =
+ PMCFGEnv Set.empty Map.empty
-addCncFun :: GrammarEnv -> CncFun -> (GrammarEnv,FunId)
-addCncFun env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fun =
+addFunction :: PMCFGEnv -> FId -> UArray LIndex SeqId -> [[FId]] -> PMCFGEnv
+addFunction (PMCFGEnv prodSet funSet) !fid fun args =
case Map.lookup fun funSet of
- Just id -> (env,id)
- Nothing -> let !last_funid = Map.size funSet
- in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) lindefSet crcSet appSet prodSet,last_funid)
-
-addCoercion :: GrammarEnv -> [FId] -> (GrammarEnv,FId)
-addCoercion env@(GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) sub_fcats =
- case sub_fcats of
- [fcat] -> (env,fcat)
- _ -> case Map.lookup sub_fcats crcSet of
- Just fcat -> (env,fcat)
- Nothing -> let !fcat = last_id+1
- in (GrammarEnv fcat catSet seqSet funSet lindefSet (Map.insert sub_fcats fcat crcSet) appSet prodSet,fcat)
-
-addLinDef :: GrammarEnv -> FId -> FunId -> GrammarEnv
-addLinDef (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fid funid =
- GrammarEnv last_id catSet seqSet funSet (IntMap.insertWith (++) fid [funid] lindefSet) crcSet appSet prodSet
-
-getConcr :: Map.Map CId Literal -> Map.Map CId String -> GrammarEnv -> Concr
-getConcr flags printnames (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) =
- Concr { cflags = flags
- , printnames = printnames
- , cncfuns = mkSetArray funSet
- , lindefs = lindefSet
- , sequences = mkSetArray seqSet
- , productions = IntMap.union prodSet coercions
- , pproductions = IntMap.empty
- , lproductions = Map.empty
- , lexicon = IntMap.empty
- , cnccats = Map.fromList [(i2i cat,PGF.Data.CncCat start end (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) (getStrPaths schema))))
- | (cat,(start,end,schema)) <- Map.toList catSet]
- , totalCats = last_id+1
- }
+ Just !funid -> PMCFGEnv (Set.insert (Production fid funid args) prodSet)
+ funSet
+ Nothing -> let !funid = Map.size funSet
+ in PMCFGEnv (Set.insert (Production fid funid args) prodSet)
+ (Map.insert fun funid funSet)
+
+getPMCFG :: PMCFGEnv -> PMCFG
+getPMCFG (PMCFGEnv prodSet funSet) =
+ PMCFG (optimize prodSet) (mkSetArray funSet)
where
- mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
-
- coercions = IntMap.fromList [(fcat,Set.fromList (map PCoerce sub_fcats)) | (sub_fcats,fcat) <- Map.toList crcSet]
-
- getStrPaths :: Schema Identity s c -> [Path]
- getStrPaths = collect CNil []
+ optimize ps = Map.foldWithKey ff [] (Map.fromListWith (++) [((fid,funid),[args]) | (Production fid funid args) <- Set.toList ps])
where
- collect path paths (CRec rs) = foldr (\(lbl,Identity t) paths -> collect (CProj lbl path) paths t) paths rs
- collect path paths (CTbl _ cs) = foldr (\(trm,Identity t) paths -> collect (CSel trm path) paths t) paths cs
- collect path paths (CStr _) = reversePath path : paths
- collect path paths (CPar _) = paths
-
-
-getFIds :: GrammarEnv -> ProtoFCat -> [FId]
-getFIds (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) (PFCat ctxt cat schema) =
- case Map.lookup cat catSet of
- Just (start,end,_) -> reverse (solutions (fmap (start +) $ variants schema) ())
- where
- variants (CRec rs) = fmap sum $ mapM (\(lbl,Identity t) -> variants t) rs
- variants (CTbl _ cs) = fmap sum $ mapM (\(trm,Identity t) -> variants t) cs
- variants (CStr _) = return 0
- variants (CPar (m,values)) = do (value,index) <- member values
- return (m*index)
+ ff :: (FId,FunId) -> [[[FId]]] -> [Production] -> [Production]
+ ff (fid,funid) xs prods
+ | product (map IntSet.size ys) == count
+ = (Production fid funid (map IntSet.toList ys)) : prods
+ | otherwise = map (Production fid funid) xs ++ prods
+ where
+ count = sum (map (product . map length) xs)
+ ys = foldl (zipWith (foldr IntSet.insert)) (repeat IntSet.empty) xs
------------------------------------------------------------
-- updating the MCF rule
@@ -613,9 +514,9 @@ restrictHead path term = do
put (head, args)
restrictProtoFCat :: (Functor m, MonadPlus m) => Path -> Term -> ProtoFCat -> m ProtoFCat
-restrictProtoFCat path v (PFCat ctxt cat schema) = do
+restrictProtoFCat path v (PFCat cat f schema) = do
schema <- addConstraint path v schema
- return (PFCat ctxt cat schema)
+ return (PFCat cat f schema)
where
addConstraint (CProj lbl path) v (CRec rs) = fmap CRec $ update lbl (addConstraint path v) rs
addConstraint (CSel trm path) v (CTbl pt cs) = fmap (CTbl pt) $ update trm (addConstraint path v) cs
@@ -631,4 +532,5 @@ restrictProtoFCat path v (PFCat ctxt cat schema) = do
| otherwise = do xs <- update k0 f xs
return (x:xs)
-mkArray lst = listArray (0,length lst-1) lst
+mkArray lst = listArray (0,length lst-1) lst
+mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index 06ececb3c..7e73b36de 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -1,10 +1,11 @@
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE BangPatterns #-}
module GF.Compile.GrammarToPGF (mkCanon2pgf) where
import GF.Compile.Export
import GF.Compile.GeneratePMCFG
import PGF.CId
+import PGF.Data(fidInt,fidFloat,fidString)
import PGF.Optimize(updateProductionIndices)
import qualified PGF.Macros as CM
import qualified PGF.Data as C
@@ -15,8 +16,8 @@ import GF.Grammar.Grammar
import qualified GF.Grammar.Lookup as Look
import qualified GF.Grammar as A
import qualified GF.Grammar.Macros as GM
---import qualified GF.Compile.Compute.Concrete as Compute ----
import qualified GF.Infra.Option as O
+import GF.Compile.GeneratePMCFG
import GF.Infra.Ident
import GF.Infra.Option
@@ -25,61 +26,72 @@ import GF.Data.Operations
import Data.List
import Data.Function
import Data.Char (isDigit,isSpace)
+import qualified Data.Set as Set
import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
import qualified Data.ByteString.Char8 as BS
+import Data.Array.IArray
import Text.PrettyPrint
---import Debug.Trace ----
-
--- when developing, swap commenting
---traceD s t = trace s t
-traceD s t = t
+import Control.Monad.Identity
--- the main function: generate PGF from GF.
-mkCanon2pgf :: Options -> Ident -> SourceGrammar -> IO D.PGF
-mkCanon2pgf opts cnc gr = (canon2pgf opts gr . reorder abs) gr
- where
- abs = err (const cnc) id $ abstractOfConcrete gr cnc
-
--- Generate PGF from grammar.
-
-type AbsConcsGrammar = (IdModInfo,[IdModInfo]) -- (abstract,concretes)
-type IdModInfo = (Ident,SourceModInfo)
-
-canon2pgf :: Options -> SourceGrammar -> AbsConcsGrammar -> IO D.PGF
-canon2pgf opts gr (am,cms) = do
- if dump opts DumpCanon
- then putStrLn (render (vcat (map (ppModule Qualified) (am:cms))))
- else return ()
- (an,abs) <- mkAbstr am
- cncs <- mapM (mkConcr am) cms
+mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IO D.PGF
+mkCanon2pgf opts gr am = do
+ (an,abs) <- mkAbstr gr am
+ cncs <- mapM (mkConcr gr) (allConcretes gr am)
return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
where
- mkAbstr (a,abm) = return (i2i a, D.Abstr flags funs cats)
+ mkAbstr gr am = return (i2i am, D.Abstr flags funs cats)
where
- flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (mflags abm)]
+ aflags =
+ concatOptions (reverse [mflags mo | (_,mo) <- modules gr, isModAbs mo])
+
+ adefs =
+ [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
+ Look.allOrigInfos gr am
+
+ flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF aflags]
funs = Map.fromAscList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0)) |
- (f,AbsFun (Just (L _ ty)) ma pty _) <- Map.toAscList (jments abm)]
+ ((m,f),AbsFun (Just (L _ ty)) ma pty _) <- adefs]
cats = Map.fromAscList [(i2i c, (snd (mkContext [] cont),catfuns c)) |
- (c,AbsCat (Just (L _ cont))) <- Map.toAscList (jments abm)]
+ ((m,c),AbsCat (Just (L _ cont))) <- adefs]
catfuns cat =
(map (\x -> (0,snd x)) . sortBy (compare `on` fst))
- [(loc,i2i f) | (f,AbsFun (Just (L loc ty)) _ _ (Just True)) <- tree2list (jments abm), snd (GM.valCat ty) == cat]
+ [(loc,i2i f) | ((m,f),AbsFun (Just (L loc ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat]
+
+ mkConcr gr cm = do
+ return (i2i cm, D.Concr flags
+ printnames
+ cncfuns
+ lindefs
+ sequences
+ productions
+ IntMap.empty
+ Map.empty
+ cnccats
+ IntMap.empty
+ fid_cnt2)
+ where
+ cflags = concatOptions [mflags mo | (i,mo) <- modules gr, isModCnc mo,
+ Just r <- [lookup i (allExtendSpecs gr cm)]]
+
+ cdefs = [((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
+ Look.allOrigInfos gr cm
- mkConcr am cm@(lang,mo) = do
- cnc <- convertConcrete opts gr am cm
- return (i2i lang, cnc)
+ flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF cflags]
+
+ !(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
+ !(!fid_cnt2,!productions,!lindefs,!sequences,!cncfuns)
+ = genCncFuns gr am cm cdefs fid_cnt1 cnccats
+
+ printnames = genPrintNames cdefs
i2i :: Ident -> CId
i2i = CId . ident2bs
-b2b :: A.BindType -> C.BindType
-b2b A.Explicit = C.Explicit
-b2b A.Implicit = C.Implicit
-
mkType :: [Ident] -> A.Type -> C.Type
mkType scope t =
case GM.typeForm t of
@@ -94,7 +106,7 @@ mkExp scope t =
Vr x -> case lookup x (zip scope [0..]) of
Just i -> C.EVar i
Nothing -> C.EMeta 0
- Abs b x t-> C.EAbs (b2b b) (i2i x) (mkExp (x:scope) t)
+ Abs b x t-> C.EAbs b (i2i x) (mkExp (x:scope) t)
App t1 t2-> C.EApp (mkExp scope t1) (mkExp scope t2)
EInt i -> C.ELit (C.LInt (fromIntegral i))
EFloat f -> C.ELit (C.LFlt f)
@@ -120,8 +132,8 @@ mkPatt scope p =
mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
in if x == identW
- then ( scope,(b2b bt,i2i x,ty'))
- else (x:scope,(b2b bt,i2i x,ty'))) scope hyps
+ then ( scope,(bt,i2i x,ty'))
+ else (x:scope,(bt,i2i x,ty'))) scope hyps
mkDef (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
mkDef Nothing = Nothing
@@ -148,28 +160,121 @@ compilePatt eqs = whilePP eqs Map.empty
mkCase cns vrs = Case (fmap compilePatt cns) (compilePatt vrs)
--- return just one module per language
+genCncCats gr am cm cdefs =
+ let (index,cats) = mkCncCats 0 cdefs
+ in (index, Map.fromList cats)
+ where
+ mkCncCats index [] = (index,[])
+ mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _):cdefs)
+ | id == cInt =
+ let cc = pgfCncCat gr lincat fidInt
+ (index',cats) = mkCncCats index cdefs
+ in (index', (i2i id,cc) : cats)
+ | id == cFloat =
+ let cc = pgfCncCat gr lincat fidFloat
+ (index',cats) = mkCncCats index cdefs
+ in (index', (i2i id,cc) : cats)
+ | id == cString =
+ let cc = pgfCncCat gr lincat fidString
+ (index',cats) = mkCncCats index cdefs
+ in (index', (i2i id,cc) : cats)
+ | otherwise =
+ let cc@(C.CncCat s e _) = pgfCncCat gr lincat index
+ (index',cats) = mkCncCats (e+1) cdefs
+ in (index', (i2i id,cc) : cats)
+ mkCncCats index (_ :cdefs) = mkCncCats index cdefs
+
-reorder :: Ident -> SourceGrammar -> AbsConcsGrammar
-reorder abs cg =
--- M.MGrammar $
- ((abs, ModInfo MTAbstract MSComplete aflags [] Nothing [] [] "" adefs),
- [(cnc, ModInfo (MTConcrete abs) MSComplete cflags [] Nothing [] [] "" cdefs)
- | cnc <- allConcretes cg abs, let (cflags,cdefs) = concr cnc])
+genCncFuns gr am cm cdefs fid_cnt cnccats =
+ let (fid_cnt1,funs_cnt1,seqs1,funs1,lindefs) = mkCncCats cdefs fid_cnt 0 Map.empty [] IntMap.empty
+ (fid_cnt2,funs_cnt2,seqs2,funs2,prods) = mkCncFuns cdefs fid_cnt1 funs_cnt1 seqs1 funs1 lindefs Map.empty IntMap.empty
+ in (fid_cnt2,prods,lindefs,mkSetArray seqs2,array (0,funs_cnt2-1) funs2)
where
- aflags =
- concatOptions (reverse [mflags mo | (_,mo) <- modules cg, isModAbs mo])
+ mkCncCats [] fid_cnt funs_cnt seqs funs lindefs =
+ (fid_cnt,funs_cnt,seqs,funs,lindefs)
+ mkCncCats (((m,id),CncCat _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt seqs funs lindefs =
+ let !funs_cnt' = let (s_funid, e_funid) = bounds funs0
+ in funs_cnt+(e_funid-s_funid+1)
+ lindefs' = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0
+ !(seqs',funs') = foldl' (toCncFun funs_cnt (m,id)) (seqs,funs) (assocs funs0)
+ in mkCncCats cdefs fid_cnt funs_cnt' seqs' funs' lindefs'
+ mkCncCats (_ :cdefs) fid_cnt funs_cnt seqs funs lindefs =
+ mkCncCats cdefs fid_cnt funs_cnt seqs funs lindefs
- adefs =
- Map.fromList (predefADefs ++ Look.allOrigInfos cg abs)
+ mkCncFuns [] fid_cnt funs_cnt seqs funs lindefs crc prods =
+ (fid_cnt,funs_cnt,seqs,funs,prods)
+ mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt seqs funs lindefs crc prods =
+ let Ok ty_C = fmap GM.typeForm (Look.lookupFunType gr am id)
+ !funs_cnt' = let (s_funid, e_funid) = bounds funs0
+ in funs_cnt+(e_funid-s_funid+1)
+ !(fid_cnt',crc',prods')
+ = foldl' (toProd lindefs ty_C funs_cnt)
+ (fid_cnt,crc,prods) prods0
+ !(seqs',funs') = foldl' (toCncFun funs_cnt (m,id)) (seqs,funs) (assocs funs0)
+ in mkCncFuns cdefs fid_cnt' funs_cnt' seqs' funs' lindefs crc' prods'
+ mkCncFuns (_ :cdefs) fid_cnt funs_cnt seqs funs lindefs crc prods =
+ mkCncFuns cdefs fid_cnt funs_cnt seqs funs lindefs crc prods
+
+ toProd lindefs (ctxt_C,res_C,_) offs st (Production fid0 funid0 args0) =
+ let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0)
+ set0 = Set.fromList (map (C.PApply (offs+funid0)) (sequence args))
+ fid = mkFId res_C fid0
+ !prods' = case IntMap.lookup fid prods of
+ Just set -> IntMap.insert fid (Set.union set0 set) prods
+ Nothing -> IntMap.insert fid set0 prods
+ in (fid_cnt,crc,prods')
where
- predefADefs =
- [(c, AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]]
-
- concr la = (flags, Map.fromList (predefCDefs ++ jments))
- where
- flags = concatOptions [mflags mo | (i,mo) <- modules cg, isModCnc mo,
- Just r <- [lookup i (allExtendSpecs cg la)]]
- jments = Look.allOrigInfos cg la
- predefCDefs =
- [(c, CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]]
+ mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s ) =
+ case fid0s of
+ [fid0] -> (st,map (flip C.PArg (mkFId arg_C fid0)) ctxt)
+ fid0s -> case Map.lookup fids crc of
+ Just fid -> (st,map (flip C.PArg fid) ctxt)
+ Nothing -> let !crc' = Map.insert fids fid_cnt crc
+ !prods' = IntMap.insert fid_cnt (Set.fromList (map C.PCoerce fids)) prods
+ in ((fid_cnt+1,crc',prods'),map (flip C.PArg fid_cnt) ctxt)
+ where
+ (hargs_C,arg_C) = GM.catSkeleton ty
+ ctxt = mapM (mkCtxt lindefs) hargs_C
+ fids = map (mkFId arg_C) fid0s
+
+ toLinDef res offs lindefs (Production fid0 funid0 _) =
+ IntMap.insertWith (++) fid [offs+funid0] lindefs
+ where
+ fid = mkFId res fid0
+
+ mkFId (_,cat) fid0 =
+ case Map.lookup (i2i cat) cnccats of
+ Just (C.CncCat s e _) -> s+fid0
+ Nothing -> error "GrammarToPGF.mkFId failed"
+
+ mkCtxt lindefs (_,cat) =
+ case Map.lookup (i2i cat) cnccats of
+ Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
+ Nothing -> error "GrammarToPGF.mkCtxt failed"
+
+ toCncFun offs (m,id) (seqs,funs) (funid0,lins0) =
+ let Ok (ModInfo{mseqs=Just mseqs}) = lookupModule gr m
+ !(!seqs',lins) = mapAccumL (mkLin mseqs) seqs (elems lins0)
+ in (seqs',(offs+funid0,C.CncFun (i2i id) (mkArray lins)):funs)
+ where
+ mkLin mseqs seqs seqid =
+ let seq = mseqs ! seqid
+ in case Map.lookup seq seqs of
+ Just seqid -> (seqs,seqid)
+ Nothing -> let !seqid = Map.size seqs
+ !seqs' = Map.insert seq seqid seqs
+ in (seqs',seqid)
+
+genPrintNames cdefs =
+ Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
+ where
+ prn (CncFun _ _ (Just (L _ tr)) _) = [flatten tr]
+ prn (CncCat _ _ (Just (L _ tr)) _) = [flatten tr]
+ prn _ = []
+
+ flatten (K s) = s
+ flatten (Alts x _) = flatten x
+ flatten (C x y) = flatten x +++ flatten y
+
+mkArray lst = listArray (0,length lst-1) lst
+mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
diff --git a/src/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs
index 303bdb8d0..33632f5bf 100644
--- a/src/compiler/GF/Compile/Optimize.hs
+++ b/src/compiler/GF/Compile/Optimize.hs
@@ -61,7 +61,7 @@ evalInfo opts ms m c info = do
errIn ("optimizing " ++ showIdent c) $ case info of
- CncCat ptyp pde ppr -> do
+ CncCat ptyp pde ppr mpmcfg -> do
pde' <- case (ptyp,pde) of
(Just (L _ typ), Just (L loc de)) -> do
de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
@@ -74,16 +74,16 @@ evalInfo opts ms m c info = do
ppr' <- evalPrintname gr ppr
- return (CncCat ptyp pde' ppr')
+ return (CncCat ptyp pde' ppr' mpmcfg)
- CncFun (mt@(Just (_,cont,val))) pde ppr -> --trace (prt c) $
+ CncFun (mt@(Just (_,cont,val))) pde ppr mpmcfg -> --trace (prt c) $
eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do
pde' <- case pde of
Just (L loc de) -> do de <- partEval opts gr (cont,val) de
return (Just (L loc (factor param c 0 de)))
Nothing -> return pde
ppr' <- evalPrintname gr ppr
- return $ CncFun mt pde' ppr' -- only cat in type actually needed
+ return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed
ResOper pty pde
| OptExpand `Set.member` optim -> do
diff --git a/src/compiler/GF/Compile/Refresh.hs b/src/compiler/GF/Compile/Refresh.hs
index 86e423317..b66e88aa3 100644
--- a/src/compiler/GF/Compile/Refresh.hs
+++ b/src/compiler/GF/Compile/Refresh.hs
@@ -124,12 +124,12 @@ refreshModule (k,ms) mi@(i,mo)
(k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $
appSTM (mapPairsM (\(L loc t) -> liftM (L loc) (refresh t)) tyts) (initIdStateN k)
return $ (k', (c, ResOverload os tyts'):cs)
- CncCat mt (Just (L loc trm)) pn -> do ---- refresh mt, pn
+ CncCat mt (Just (L loc trm)) mn mpmcfg-> do ---- refresh mt, pn
(k',trm') <- refreshTermKN k trm
- return $ (k', (c, CncCat mt (Just (L loc trm')) pn):cs)
- CncFun mt (Just (L loc trm)) pn -> do ---- refresh pn
+ return $ (k', (c, CncCat mt (Just (L loc trm')) mn mpmcfg):cs)
+ CncFun mt (Just (L loc trm)) mn mpmcfg -> do ---- refresh pn
(k',trm') <- refreshTermKN k trm
- return $ (k', (c, CncFun mt (Just (L loc trm')) pn):cs)
+ return $ (k', (c, CncFun mt (Just (L loc trm')) mn mpmcfg):cs)
_ -> return (k, ci:cs)
diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index 805e85464..336e8f946 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -158,8 +158,8 @@ renameInfo status (m,mi) i info =
ResValue t -> do
t <- renLoc (renameTerm status []) t
return (ResValue t)
- CncCat pty ptr ppr -> liftM3 CncCat (renTerm pty) (renTerm ptr) (renTerm ppr)
- CncFun mt ptr ppr -> liftM2 (CncFun mt) (renTerm ptr) (renTerm ppr)
+ CncCat mty mtr mpr mpmcfg -> liftM4 CncCat (renTerm mty) (renTerm mtr) (renTerm mpr) (return mpmcfg)
+ CncFun mty mtr mpr mpmcfg -> liftM3 (CncFun mty) (renTerm mtr) (renTerm mpr) (return mpmcfg)
_ -> return info
where
renTerm = renPerh (renameTerm status [])
diff --git a/src/compiler/GF/Compile/SubExOpt.hs b/src/compiler/GF/Compile/SubExOpt.hs
index 453c8e3ca..bfa2a1334 100644
--- a/src/compiler/GF/Compile/SubExOpt.hs
+++ b/src/compiler/GF/Compile/SubExOpt.hs
@@ -52,7 +52,7 @@ unsubexpModule sm@(i,mo)
-- perform this iff the module has opers
hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs]
unparInfo (c,info) = case info of
- CncFun xs (Just (L loc t)) m -> [(c, CncFun xs (Just (L loc (unparTerm t))) m)]
+ CncFun xs (Just (L loc t)) m pf -> [(c, CncFun xs (Just (L loc (unparTerm t))) m pf)]
ResOper (Just (L loc (EInt 8))) _ -> [] -- subexp-generated opers
ResOper pty (Just (L loc t)) -> [(c, ResOper pty (Just (L loc (unparTerm t))))]
_ -> [(c,info)]
@@ -75,9 +75,9 @@ addSubexpConsts mo tree lins = do
mapM mkOne $ opers ++ lins
where
mkOne (f,def) = case def of
- CncFun xs (Just (L loc trm)) pn -> do
+ CncFun xs (Just (L loc trm)) pn pf -> do
trm' <- recomp f trm
- return (f,CncFun xs (Just (L loc trm')) pn)
+ return (f,CncFun xs (Just (L loc trm')) pn pf)
ResOper ty (Just (L loc trm)) -> do
trm' <- recomp f trm
return (f,ResOper ty (Just (L loc trm')))
@@ -98,7 +98,7 @@ getSubtermsMod mo js = do
return $ Map.filter (\ (nu,_) -> nu > 1) tree0
where
getInfo get fi@(f,i) = case i of
- CncFun xs (Just (L _ trm)) pn -> do
+ CncFun xs (Just (L _ trm)) pn _ -> do
get trm
return $ fi
ResOper ty (Just (L _ trm)) -> do
diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs
index 2a95df4d5..6eb88b272 100644
--- a/src/compiler/GF/Compile/Update.hs
+++ b/src/compiler/GF/Compile/Update.hs
@@ -76,7 +76,7 @@ extendModule gr (name,m)
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- AR 24/10/2003
rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule
-rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ js_)) = do
+rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ env_ js_)) = do
---- deps <- moduleDeps ms
---- is <- openInterfaces deps i
let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005
@@ -109,7 +109,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ js_)) = do
[i | i <- is, notElem i infs]
testErr (stat' == MSComplete || stat == MSIncomplete)
("module" +++ showIdent i +++ "remains incomplete")
- ModInfo mt0 _ fs me' _ ops0 _ _ js <- lookupModule gr ext
+ ModInfo mt0 _ fs me' _ ops0 _ _ _ js <- lookupModule gr ext
let ops1 = nub $
ops_ ++ -- N.B. js has been name-resolved already
[OQualif i j | (i,j) <- ops] ++
@@ -122,7 +122,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ js_)) = do
let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
let js1 = buildTree (tree2list js_ ++ js0)
let med1= nub (ext : infs ++ insts ++ med_)
- return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 src_ js1
+ return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 src_ env_ js1
return (i,mi')
@@ -173,8 +173,8 @@ globalizeLoc fpath i =
ResValue t -> ResValue (gl t)
ResOper mt m -> ResOper (fmap gl mt) (fmap gl m)
ResOverload ms os -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os)
- CncCat mc mf mp -> CncCat (fmap gl mc) (fmap gl mf) (fmap gl mp)
- CncFun m mt md -> CncFun m (fmap gl mt) (fmap gl md)
+ CncCat mc mf mp mpmcfg-> CncCat (fmap gl mc) (fmap gl mf) (fmap gl mp) mpmcfg
+ CncFun m mt md mpmcfg-> CncFun m (fmap gl mt) (fmap gl md) mpmcfg
AnyInd b m -> AnyInd b m
where
gl (L loc0 x) = loc `seq` L (External fpath loc) x
@@ -200,10 +200,10 @@ unifyAnyInfo m i j = case (i,j) of
(ResOper mt1 m1, ResOper mt2 m2) ->
liftM2 ResOper (unifMaybeL mt1 mt2) (unifMaybeL m1 m2)
- (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) ->
- liftM3 CncCat (unifMaybeL mc1 mc2) (unifMaybeL mf1 mf2) (unifMaybeL mp1 mp2)
- (CncFun m mt1 md1, CncFun _ mt2 md2) ->
- liftM2 (CncFun m) (unifMaybeL mt1 mt2) (unifMaybeL md1 md2) ---- adding defs
+ (CncCat mc1 mf1 mp1 mpmcfg1, CncCat mc2 mf2 mp2 mpmcfg2) ->
+ liftM4 CncCat (unifMaybeL mc1 mc2) (unifMaybeL mf1 mf2) (unifMaybeL mp1 mp2) (unifMaybe mpmcfg1 mpmcfg2)
+ (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
+ liftM3 (CncFun m) (unifMaybeL mt1 mt2) (unifMaybeL md1 md2) (unifMaybe mpmcfg1 mpmcfg2)
(AnyInd b1 m1, AnyInd b2 m2) -> do
testErr (b1 == b2) $ "indirection status"
diff --git a/src/compiler/GF/Grammar/Analyse.hs b/src/compiler/GF/Grammar/Analyse.hs
index 1c9358816..38d3d9bcc 100644
--- a/src/compiler/GF/Grammar/Analyse.hs
+++ b/src/compiler/GF/Grammar/Analyse.hs
@@ -31,8 +31,8 @@ stripInfo i = case i of
ResValue lt -> i ----
ResOper mt md -> ResOper mt Nothing
ResOverload is fs -> ResOverload is [(lty, L loc (EInt 0)) | (lty,L loc _) <- fs]
- CncCat mty mte mtf -> CncCat mty Nothing Nothing
- CncFun mict mte mtf -> CncFun mict Nothing Nothing
+ CncCat mty mte mtf mpmcfg -> CncCat mty Nothing Nothing Nothing
+ CncFun mict mte mtf mpmcfg -> CncFun mict Nothing Nothing Nothing
AnyInd b f -> i
constantsInTerm :: Term -> [QIdent]
@@ -110,8 +110,8 @@ sizeInfo i = case i of
ResValue lt -> 0
ResOper mt md -> 1 + msize mt + msize md
ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]
- CncCat mty mte mtf -> 1 + msize mty -- ignoring lindef and printname
- CncFun mict mte mtf -> 1 + msize mte -- ignoring type and printname
+ CncCat mty mte mtf _ -> 1 + msize mty -- ignoring lindef and printname
+ CncFun mict mte mtf _ -> 1 + msize mte -- ignoring type and printname
AnyInd b f -> -1 -- just to ignore these in the size
_ -> 0
where
diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs
index 2298ed018..d1a3ac413 100644
--- a/src/compiler/GF/Grammar/Binary.hs
+++ b/src/compiler/GF/Grammar/Binary.hs
@@ -18,6 +18,8 @@ import GF.Infra.Ident
import GF.Infra.Option
import GF.Grammar.Grammar
+import PGF.Binary hiding (decodingError)
+
instance Binary Ident where
put id = put (ident2bs id)
get = do bs <- get
@@ -30,9 +32,9 @@ instance Binary SourceGrammar where
get = fmap mGrammar get
instance Binary SourceModInfo where
- put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,jments mi)
- get = do (mtype,mstatus,flags,extend,mwith,opens,med,src,jments) <- get
- return (ModInfo mtype mstatus flags extend mwith opens med src jments)
+ put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,mseqs mi,jments mi)
+ get = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,mseqs,jments) <- get
+ return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments)
instance Binary ModuleType where
put MTAbstract = putWord8 0
@@ -85,6 +87,19 @@ instance Binary Options where
Ok x -> return x
Bad msg -> fail msg
+instance Binary Production where
+ put (Production res funid args) = put (res,funid,args)
+ get = do res <- get
+ funid <- get
+ args <- get
+ return (Production res funid args)
+
+instance Binary PMCFG where
+ put (PMCFG prods funs) = put (prods,funs)
+ get = do prods <- get
+ funs <- get
+ return (PMCFG prods funs)
+
instance Binary Info where
put (AbsCat x) = putWord8 0 >> put x
put (AbsFun w x y z) = putWord8 1 >> put (w,x,y,z)
@@ -92,8 +107,8 @@ instance Binary Info where
put (ResValue x) = putWord8 3 >> put x
put (ResOper x y) = putWord8 4 >> put (x,y)
put (ResOverload x y)= putWord8 5 >> put (x,y)
- put (CncCat x y z) = putWord8 6 >> put (x,y,z)
- put (CncFun x y z) = putWord8 7 >> put (x,y,z)
+ put (CncCat w x y z) = putWord8 6 >> put (w,x,y,z)
+ put (CncFun w x y z) = putWord8 7 >> put (w,x,y,z)
put (AnyInd x y) = putWord8 8 >> put (x,y)
get = do tag <- getWord8
case tag of
@@ -103,8 +118,8 @@ instance Binary Info where
3 -> get >>= \x -> return (ResValue x)
4 -> get >>= \(x,y) -> return (ResOper x y)
5 -> get >>= \(x,y) -> return (ResOverload x y)
- 6 -> get >>= \(x,y,z) -> return (CncCat x y z)
- 7 -> get >>= \(x,y,z) -> return (CncFun x y z)
+ 6 -> get >>= \(w,x,y,z) -> return (CncCat w x y z)
+ 7 -> get >>= \(w,x,y,z) -> return (CncFun w x y z)
8 -> get >>= \(x,y) -> return (AnyInd x y)
_ -> decodingError
@@ -122,15 +137,6 @@ instance Binary a => Binary (L a) where
put (L x y) = put (x,y)
get = get >>= \(x,y) -> return (L x y)
-instance Binary BindType where
- put Explicit = putWord8 0
- put Implicit = putWord8 1
- get = do tag <- getWord8
- case tag of
- 0 -> return Explicit
- 1 -> return Implicit
- _ -> decodingError
-
instance Binary Term where
put (Vr x) = putWord8 0 >> put x
put (Cn x) = putWord8 1 >> put x
@@ -270,7 +276,7 @@ instance Binary Label where
decodeModHeader :: FilePath -> IO SourceModule
decodeModHeader fpath = do
- (m,mtype,mstatus,flags,extend,mwith,opens,med,src) <- decodeFile fpath
- return (m,ModInfo mtype mstatus flags extend mwith opens med src Map.empty)
+ (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) <- decodeFile fpath
+ return (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty)
decodingError = fail "This GFO file was compiled with different version of GF"
diff --git a/src/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs
index 5a10612ec..2ef625131 100644
--- a/src/compiler/GF/Grammar/CF.hs
+++ b/src/compiler/GF/Grammar/CF.hs
@@ -83,8 +83,8 @@ type CFFun = String
cf2gf :: FilePath -> CF -> SourceGrammar
cf2gf fpath cf = mGrammar [
- (aname, ModInfo MTAbstract MSComplete (modifyFlags (\fs -> fs{optStartCat = Just cat})) [] Nothing [] [] fpath abs),
- (cname, ModInfo (MTConcrete aname) MSComplete noOptions [] Nothing [] [] fpath cnc)
+ (aname, ModInfo MTAbstract MSComplete (modifyFlags (\fs -> fs{optStartCat = Just cat})) [] Nothing [] [] fpath Nothing abs),
+ (cname, ModInfo (MTConcrete aname) MSComplete noOptions [] Nothing [] [] fpath Nothing cnc)
]
where
name = justModuleName fpath
@@ -102,7 +102,7 @@ cf2grammar rules = (buildTree abs, buildTree conc, cat) where
_ -> error "empty CF"
cats = [(cat, AbsCat (Just (L NoLoc []))) |
cat <- nub (concat (map cf2cat rules))] ----notPredef cat
- lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
+ lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
(funs,lins) = unzip (map cf2rule rules)
cf2cat :: CFRule -> [Ident]
@@ -119,6 +119,7 @@ cf2rule (L loc (fun, (cat, items))) = (def,ldef) where
Nothing
(Just (L loc (mkAbs (map fst args)
(mkRecord (const theLinLabel) [foldconcat (map mkIt args0)]))))
+ Nothing
Nothing)
mkIt (v, Left _) = P (Vr v) theLinLabel
mkIt (_, Right a) = K a
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index acf2153bc..5174b1695 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -32,7 +32,9 @@ module GF.Grammar.Grammar (
abstractOfConcrete,
ModuleStatus(..),
-
+
+ PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence,
+
Info(..),
Location(..), L(..), unLoc,
Type,
@@ -64,18 +66,25 @@ import GF.Infra.Option ---
import GF.Data.Operations
+import PGF.Data (FId, FunId, SeqId, LIndex, Sequence, BindType(..))
+
import Data.List
+import Data.Array.IArray
+import Data.Array.Unboxed
import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.IntMap as IntMap
import qualified Data.ByteString.Char8 as BS
import Text.PrettyPrint
import System.FilePath
+import Control.Monad.Identity
+
data SourceGrammar = MGrammar {
moduleMap :: Map.Map Ident SourceModInfo,
modules :: [(Ident,SourceModInfo)]
}
- deriving Show
data SourceModInfo = ModInfo {
mtype :: ModuleType,
@@ -86,9 +95,9 @@ data SourceModInfo = ModInfo {
mopens :: [OpenSpec],
mexdeps :: [Ident],
msrc :: FilePath,
+ mseqs :: Maybe (Array SeqId Sequence),
jments :: Map.Map Ident Info
}
- deriving Show
type SourceModule = (Ident, SourceModInfo)
@@ -116,9 +125,6 @@ isInherited c i = case c of
inheritAll :: Ident -> (Ident,MInclude)
inheritAll i = (i,MIAll)
-addOpenQualif :: Ident -> Ident -> SourceModInfo -> SourceModInfo
-addOpenQualif i j (ModInfo mt ms fs me mw ops med src js) = ModInfo mt ms fs me mw (OQualif i j : ops) med src js
-
data OpenSpec =
OSimple Ident
| OQualif Ident Ident
@@ -313,6 +319,14 @@ allConcreteModules gr =
[i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
+data Production = Production {-# UNPACK #-} !FId
+ {-# UNPACK #-} !FunId
+ [[FId]]
+ deriving (Eq,Ord,Show)
+
+data PMCFG = PMCFG [Production]
+ (Array FunId (UArray LIndex SeqId))
+ deriving (Eq,Show)
-- | the constructors are judgements in
--
@@ -336,8 +350,8 @@ data Info =
| ResOverload [Ident] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited
-- judgements in concrete syntax
- | CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) -- ^ (/CNC/) lindef ini'zed,
- | CncFun (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) -- ^ (/CNC/) type info added at 'TC'
+ | CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) lindef ini'zed,
+ | CncFun (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) type info added at 'TC'
-- indirection to module Ident
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
@@ -364,11 +378,6 @@ type Fun = QIdent
type QIdent = (Ident,Ident)
-data BindType =
- Explicit
- | Implicit
- deriving (Eq,Ord,Show)
-
data Term =
Vr Ident -- ^ variable
| Cn Ident -- ^ constant
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index 7e743dd16..0a06347d6 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -71,11 +71,11 @@ lookupResDef gr (m,c)
case info of
ResOper _ (Just (L _ t)) -> return t
ResOper _ Nothing -> return (Q (m,c))
- CncCat (Just (L _ ty)) _ _ -> lock c ty
- CncCat _ _ _ -> lock c defLinType
+ CncCat (Just (L _ ty)) _ _ _ -> lock c ty
+ CncCat _ _ _ _ -> lock c defLinType
- CncFun (Just (cat,_,_)) (Just (L _ tr)) _ -> unlock cat tr
- CncFun _ (Just (L _ tr)) _ -> return tr
+ CncFun (Just (cat,_,_)) (Just (L _ tr)) _ _ -> unlock cat tr
+ CncFun _ (Just (L _ tr)) _ _ -> return tr
AnyInd _ n -> look n c
ResParam _ _ -> return (QC (m,c))
@@ -89,8 +89,8 @@ lookupResType gr (m,c) = do
ResOper (Just (L _ t)) _ -> return t
-- used in reused concrete
- CncCat _ _ _ -> return typeType
- CncFun (Just (cat,cont,val)) _ _ -> do
+ CncCat _ _ _ _ -> return typeType
+ CncFun (Just (cat,cont,val)) _ _ _ -> do
val' <- lock cat val
return $ mkProd cont val' []
AnyInd _ n -> lookupResType gr (n,c)
@@ -119,10 +119,10 @@ lookupOrigInfo gr (m,c) = do
AnyInd _ n -> lookupOrigInfo gr (n,c)
i -> return (m,i)
-allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)]
+allOrigInfos :: SourceGrammar -> Ident -> [(QIdent,Info)]
allOrigInfos gr m = errVal [] $ do
mo <- lookupModule gr m
- return [(c,i) | (c,_) <- tree2list (jments mo), Ok (_,i) <- [lookupOrigInfo gr (m,c)]]
+ return [((m,c),i) | (c,_) <- tree2list (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]]
lookupParamValues :: SourceGrammar -> QIdent -> Err [Term]
lookupParamValues gr c = do
@@ -163,9 +163,9 @@ lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
lookupLincat gr m c = do
info <- lookupQIdentInfo gr (m,c)
case info of
- CncCat (Just (L _ t)) _ _ -> return t
- AnyInd _ n -> lookupLincat gr n c
- _ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
+ CncCat (Just (L _ t)) _ _ _ -> return t
+ AnyInd _ n -> lookupLincat gr n c
+ _ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
-- | this is needed at compile time
lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index 8af343fc6..e8842375d 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -69,9 +69,8 @@ valTypeCnc typ = snd (typeFormCnc typ)
typeSkeleton :: Type -> ([(Int,Cat)],Cat)
typeSkeleton typ =
- let (cont,cat,_) = typeForm typ
- args = map (\(b,x,t) -> typeSkeleton t) cont
- in ([(length c, v) | (c,v) <- args], cat)
+ let (ctxt,cat,_) = typeForm typ
+ in ([(length c, v) | (b,x,t) <- ctxt, let (c,v) = typeSkeleton t], cat)
catSkeleton :: Type -> ([Cat],Cat)
catSkeleton typ =
@@ -560,8 +559,8 @@ allDependencies ism b =
ResOper pty pt -> [pty,pt]
ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont]
- CncCat pty _ _ -> [pty]
- CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type))
+ CncCat pty _ _ _ -> [pty]
+ CncFun _ pt _ _ -> [pt] ---- (Maybe (Ident,(Context,Type))
AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual
AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co]
_ -> []
diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y
index 6c83d72a0..530795974 100644
--- a/src/compiler/GF/Grammar/Parser.y
+++ b/src/compiler/GF/Grammar/Parser.y
@@ -117,14 +117,14 @@ ModDef
defs <- case buildAnyTree id jments of
Ok x -> return x
Bad msg -> fail msg
- return (id, ModInfo mtype mstat opts extends with opens [] "" defs) }
+ return (id, ModInfo mtype mstat opts extends with opens [] "" Nothing defs) }
ModHeader :: { SourceModule }
ModHeader
: ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
(mtype,id) = $2 ;
(extends,with,opens) = $4 }
- in (id, ModInfo mtype mstat noOptions extends with opens [] "" emptyBinTree) }
+ in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing emptyBinTree) }
ComplMod :: { ModuleStatus }
ComplMod
@@ -219,11 +219,11 @@ TopDef
| 'data' ListDataDef { Left $2 }
| 'param' ListParamDef { Left $2 }
| 'oper' ListOperDef { Left $2 }
- | 'lincat' ListTermDef { Left [(f, CncCat (Just e) Nothing Nothing ) | (f,e) <- $2] }
- | 'lindef' ListTermDef { Left [(f, CncCat Nothing (Just e) Nothing ) | (f,e) <- $2] }
+ | 'lincat' ListTermDef { Left [(f, CncCat (Just e) Nothing Nothing Nothing) | (f,e) <- $2] }
+ | 'lindef' ListTermDef { Left [(f, CncCat Nothing (Just e) Nothing Nothing) | (f,e) <- $2] }
| 'lin' ListLinDef { Left $2 }
- | 'printname' 'cat' ListTermDef { Left [(f, CncCat Nothing Nothing (Just e)) | (f,e) <- $3] }
- | 'printname' 'fun' ListTermDef { Left [(f, CncFun Nothing Nothing (Just e)) | (f,e) <- $3] }
+ | 'printname' 'cat' ListTermDef { Left [(f, CncCat Nothing Nothing (Just e) Nothing) | (f,e) <- $3] }
+ | 'printname' 'fun' ListTermDef { Left [(f, CncFun Nothing Nothing (Just e) Nothing) | (f,e) <- $3] }
| 'flags' ListFlagDef { Right $2 }
CatDef :: { [(Ident,Info)] }
@@ -263,8 +263,8 @@ OperDef
LinDef :: { [(Ident,Info)] }
LinDef
- : Posn ListName '=' Exp Posn { [(f, CncFun Nothing (Just (mkL $1 $5 $4)) Nothing) | f <- $2] }
- | Posn Name ListArg '=' Exp Posn { [($2, CncFun Nothing (Just (mkL $1 $6 (mkAbs $3 $5))) Nothing)] }
+ : Posn ListName '=' Exp Posn { [(f, CncFun Nothing (Just (mkL $1 $5 $4)) Nothing Nothing) | f <- $2] }
+ | Posn Name ListArg '=' Exp Posn { [($2, CncFun Nothing (Just (mkL $1 $6 (mkAbs $3 $5))) Nothing Nothing)] }
TermDef :: { [(Ident,L Term)] }
TermDef
@@ -674,14 +674,14 @@ isOverloading t =
checkInfoType mt jment@(id,info) =
case info of
- AbsCat pcont -> ifAbstract mt (locPerh pcont)
- AbsFun pty _ pde _ -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde)
- CncCat pty pd ppn -> ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh ppn)
- CncFun _ pd ppn -> ifConcrete mt (locPerh pd ++ locPerh ppn)
- ResParam pparam _ -> ifResource mt (locPerh pparam)
- ResValue ty -> ifResource mt (locL ty)
- ResOper pty pt -> ifOper mt pty pt
- ResOverload _ xs -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
+ AbsCat pcont -> ifAbstract mt (locPerh pcont)
+ AbsFun pty _ pde _ -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde)
+ CncCat pty pd ppn _ -> ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh ppn)
+ CncFun _ pd ppn _ -> ifConcrete mt (locPerh pd ++ locPerh ppn)
+ ResParam pparam _ -> ifResource mt (locPerh pparam)
+ ResValue ty -> ifResource mt (locL ty)
+ ResOper pty pt -> ifOper mt pty pt
+ ResOverload _ xs -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
where
locPerh = maybe [] locL
locAll xs = [loc | L loc x <- xs]
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index f65d26f89..cf0bbf6e9 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -26,10 +26,15 @@ import GF.Infra.Option
import GF.Grammar.Values
import GF.Grammar.Grammar
+import PGF.Printer (ppFId, ppFunId, ppSeqId, ppSeq)
+
import Text.PrettyPrint
import Data.Maybe (maybe, isNothing)
import Data.List (intersperse)
import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
+import qualified Data.Set as Set
+import qualified Data.Array.IArray as Array
data TermPrintQual = Qualified | Unqualified
@@ -37,11 +42,13 @@ ppGrammar :: SourceGrammar -> Doc
ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr
ppModule :: TermPrintQual -> SourceModule -> Doc
-ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ jments) =
- hdr $$ nest 2 (ppOptions opts $$ vcat (map (ppJudgement q) defs)) $$ ftr
+ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
+ hdr $$
+ nest 2 (ppOptions opts $$
+ vcat (map (ppJudgement q) (Map.toList jments)) $$
+ maybe empty ppSequences mseqs) $$
+ ftr
where
- defs = Map.toList jments
-
hdr = complModDoc <+> modTypeDoc <+> equals <+>
hsep (intersperse (text "**") $
filter (not . isEmpty) $ [ commaPunct ppExtends exts
@@ -108,7 +115,7 @@ ppJudgement q (id, ResOverload ids defs) =
(text "overload" <+> lbrace $$
nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e <+> semi) | (L _ ty,L _ e) <- defs]) $$
rbrace) <+> semi
-ppJudgement q (id, CncCat ptype pexp pprn) =
+ppJudgement q (id, CncCat ptype pexp pprn mpmcfg) =
(case ptype of
Just (L _ typ) -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi
Nothing -> empty) $$
@@ -116,17 +123,37 @@ ppJudgement q (id, CncCat ptype pexp pprn) =
Just (L _ exp) -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
Nothing -> empty) $$
(case pprn of
- Just (L _ prn) -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
+ Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
+ Nothing -> empty) $$
+ (case mpmcfg of
+ Just (PMCFG prods funs)
+ -> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$
+ nest 2 (vcat (map ppProduction prods) $$
+ space $$
+ vcat (map (\(funid,arr) -> ppFunId funid <+> text ":=" <+>
+ parens (hcat (punctuate comma (map ppSeqId (Array.elems arr)))))
+ (Array.assocs funs))) $$
+ char '}'
Nothing -> empty)
-ppJudgement q (id, CncFun ptype pdef pprn) =
+ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) =
(case pdef of
Just (L _ e) -> let (xs,e') = getAbs e
in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi
Nothing -> empty) $$
(case pprn of
- Just (L _ prn) -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
+ Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
+ Nothing -> empty) $$
+ (case mpmcfg of
+ Just (PMCFG prods funs)
+ -> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$
+ nest 2 (vcat (map ppProduction prods) $$
+ space $$
+ vcat (map (\(funid,arr) -> ppFunId funid <+> text ":=" <+>
+ parens (hcat (punctuate comma (map ppSeqId (Array.elems arr)))))
+ (Array.assocs funs))) $$
+ char '}'
Nothing -> empty)
-ppJudgement q (id, AnyInd cann mid) = text "-- ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi
+ppJudgement q (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi
ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e)
in prec d 0 (char '\\' <> commaPunct ppBind xs <+> text "->" <+> ppTerm q 0 e')
@@ -277,6 +304,18 @@ ppLocation fpath (Local b e)
| b == e = text fpath <> colon <> int b
| otherwise = text fpath <> colon <> int b <> text "-" <> int e
+ppProduction (Production fid funid args) =
+ ppFId fid <+> text "->" <+> ppFunId funid <>
+ brackets (hcat (punctuate comma (map (hsep . intersperse (char '|') . map ppFId) args)))
+
+ppSequences seqsArr
+ | null seqs = empty
+ | otherwise = text "sequences" <+> char '{' $$
+ nest 2 (vcat (map ppSeq seqs)) $$
+ char '}'
+ where
+ seqs = Array.assocs seqsArr
+
commaPunct f ds = (hcat (punctuate comma (map f ds)))
prec d1 d2 doc
@@ -299,3 +338,4 @@ getLet :: Term -> ([LocalDef], Term)
getLet (Let l e) = let (ls,e') = getLet e
in (l:ls,e')
getLet e = ([],e)
+
diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index 6fbc91d91..6a468d157 100644
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -140,7 +140,6 @@ data Flags = Flags {
optMode :: Mode,
optStopAfterPhase :: Phase,
optVerbosity :: Verbosity,
- optProf :: Bool,
optShowCPUTime :: Bool,
optOutputFormats :: [OutputFormat],
optSISR :: Maybe SISRFormat,
@@ -157,9 +156,10 @@ data Flags = Flags {
optName :: Maybe String,
optPreprocessors :: [String],
optEncoding :: String,
+ optPMCFG :: Bool,
optOptimizations :: Set Optimization,
optOptimizePGF :: Bool,
- optMkIndexPGF :: Bool,
+ optMkIndexPGF :: Bool,
optCFGTransforms :: Set CFGTransform,
optLibraryPath :: [FilePath],
optStartCat :: Maybe String,
@@ -236,7 +236,6 @@ defaultFlags = Flags {
optMode = ModeInteractive,
optStopAfterPhase = Compile,
optVerbosity = Normal,
- optProf = False,
optShowCPUTime = False,
optOutputFormats = [],
optSISR = Nothing,
@@ -254,6 +253,7 @@ defaultFlags = Flags {
optName = Nothing,
optPreprocessors = [],
optEncoding = "latin1",
+ optPMCFG = True,
-- #ifdef CC_LAZY
-- optOptimizations = Set.fromList [OptStem,OptCSE],
-- #else
@@ -290,7 +290,6 @@ optDescr =
Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.",
Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .",
Option [] ["make"] (NoArg (liftM2 addOptions (mode ModeCompiler) (phase Link))) "Build .pgf file and other output files and exit.",
- Option [] ["prof"] (NoArg (prof True)) "Dump profiling information when compiling to PMCFG",
Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.",
Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).",
Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
@@ -338,6 +337,8 @@ optDescr =
Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.",
Option [] ["lexer"] (ReqArg lexer "LEXER") "Use lexer LEXER.",
Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.",
+ Option [] ["pmcfg"] (NoArg (pmcfg True)) "Generate PMCFG (default).",
+ Option [] ["no-pmcfg"] (NoArg (pmcfg False)) "Don't generate PMCFG (useful for libraries).",
Option [] ["optimize"] (ReqArg optimize "OPT")
"Select an optimization package. OPT = all | values | parametrize | none",
Option [] ["optimize-pgf"] (NoArg (optimize_pgf True))
@@ -364,7 +365,6 @@ optDescr =
Just v -> case readMaybe v >>= toEnumBounded of
Just i -> set $ \o -> o { optVerbosity = i }
Nothing -> fail $ "Bad verbosity: " ++ show v
- prof x = set $ \o -> o { optProf = x }
cpu x = set $ \o -> o { optShowCPUTime = x }
gfoDir x = set $ \o -> o { optGFODir = Just x }
outFmt x = readOutputFormat x >>= \f ->
@@ -395,6 +395,8 @@ optDescr =
lexer x = set $ \o -> o { optLexer = Just x }
unlexer x = set $ \o -> o { optUnlexer = Just x }
+ pmcfg x = set $ \o -> o { optPMCFG = x }
+
optimize x = case lookup x optimizationPackages of
Just p -> set $ \o -> o { optOptimizations = p }
Nothing -> fail $ "Unknown optimization package: " ++ x
diff --git a/src/compiler/GFTags.hs b/src/compiler/GFTags.hs
index 1fad82b99..15f85e351 100644
--- a/src/compiler/GFTags.hs
+++ b/src/compiler/GFTags.hs
@@ -31,11 +31,11 @@ getTags x (m,mi) =
maybe (loc "oper-def") mb_def
getLocations (ResOverload _ defs) = list (\(x,y) -> ltype "overload-type" x ++
loc "overload-def" y) defs
- getLocations (CncCat mb_type mb_def mb_prn) = maybe (loc "lincat") mb_type ++
- maybe (loc "lindef") mb_def ++
- maybe (loc "printname") mb_prn
- getLocations (CncFun _ mb_lin mb_prn) = maybe (loc "lin") mb_lin ++
- maybe (loc "printname") mb_prn
+ getLocations (CncCat mty mdef mprn _) = maybe (loc "lincat") mty ++
+ maybe (loc "lindef") mdef ++
+ maybe (loc "printname") mprn
+ getLocations (CncFun _ mlin mprn _) = maybe (loc "lin") mlin ++
+ maybe (loc "printname") mprn
getLocations _ = []
loc kind (L loc _) = [(kind,render (ppLocation (msrc mi) loc),"")]
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:52:29 +0000