diff --git a/gf.cabal b/gf.cabal index d768786ce..dd3657336 100644 --- a/gf.cabal +++ b/gf.cabal @@ -116,7 +116,6 @@ executable gf GF.Compile.GeneratePMCFG GF.Compile.GrammarToPGF GF.Compile.Multi - GF.Compile.Optimize GF.Compile.OptimizePGF GF.Compile.PGFtoHaskell GF.Compile.PGFtoJava diff --git a/src/compiler/GF/Compile/Compute/Concrete.hs b/src/compiler/GF/Compile/Compute/Concrete.hs index 9767f1f55..f1563ff84 100644 --- a/src/compiler/GF/Compile/Compute/Concrete.hs +++ b/src/compiler/GF/Compile/Compute/Concrete.hs @@ -3,9 +3,12 @@ -- | Functions for computing the values of terms in the concrete syntax, in -- | preparation for PMCFG generation. module GF.Compile.Compute.Concrete - (normalForm, - Value(..), Env, value2term, eval + ( normalForm + , Value(..), Thunk, ThunkState(..), Env, EvalM, runEvalM + , eval, apply, force, value2term + , newMeta,newEvaluatedThunk,getAllParamValues ) where + import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import GF.Grammar hiding (Env, VGen, VApp, VRecType) @@ -72,6 +75,8 @@ data Value s | VPattType (Value s) | VAlts (Value s) [(Value s, Value s)] | VStrs [Value s] + | VSymCat Int Int -- This is only generated internally in + -- the PMCFG generator. eval env (Vr x) vs = case lookup x env of @@ -322,6 +327,10 @@ value2term i (VMeta m env tnks) = do case res of Right i -> foldM (\e1 tnk -> fmap (App e1) (force tnk [] >>= value2term i)) (Meta i) tnks Left v -> value2term i v +value2term i (VSusp j env vs k) = do + tnk <- newEvaluatedThunk (VGen maxBound vs) + v <- k tnk + value2term i v value2term i (VGen j tnks) = foldM (\e1 tnk -> fmap (App e1) (force tnk [] >>= value2term i)) (Vr (identS ('v':show j))) tnks value2term i (VClosure env (Abs b x t)) = do diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 70d135387..1e74b80a0 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -13,628 +13,82 @@ module GF.Compile.GeneratePMCFG (generatePMCFG, pgfCncCat, addPMCFG ) where -import qualified PGF2 as PGF2 -import qualified PGF2.Internal as PGF2 -import PGF2.Internal(Symbol(..),fidVar) - -import GF.Infra.Option -import GF.Grammar hiding (Env, mkRecord, mkTable) -import GF.Grammar.Lookup +import GF.Grammar import GF.Grammar.Predef -import GF.Grammar.Lockfield (isLockLabel) -import GF.Data.BacktrackM -import GF.Data.Operations -import GF.Infra.UseIO (ePutStr,ePutStrLn) -- IOE, -import GF.Data.Utilities (updateNthM) --updateNth -import GF.Compile.Compute.Concrete(normalForm) -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 GF.Text.Pretty -import Data.Array.IArray -import Data.Array.Unboxed ---import Data.Maybe ---import Data.Char (isDigit) -import Control.Applicative(Applicative(..)) -import Control.Monad -import Control.Monad.Identity ---import Control.Exception ---import Debug.Trace(trace) -import qualified Control.Monad.Fail as Fail +import GF.Infra.CheckM +import GF.Infra.Option +import GF.Compile.Compute.Concrete +import PGF2.Transactions +import qualified Data.Map.Strict as Map ----------------------------------------------------------------------- --- main conversion function +generatePMCFG :: Options -> SourceGrammar -> SourceModule -> Check SourceModule +generatePMCFG opts gr cmo@(cm,cmi) = do + js <- mapM (addPMCFG opts gr) (Map.toList (jments cmi)) + return (cm,cmi{jments = (Map.fromAscList js)}) ---generatePMCFG :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule -generatePMCFG opts sgr opath cmo@(cm,cmi) = do - (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr opath am cm) Map.empty (jments cmi) - when (verbAtLeast opts Verbose) $ ePutStrLn "" - return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js}) +addPMCFG opts gr (id,CncFun mty@(Just (cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) = do + lins <- pmcfgForm gr (L loc id) term ctxt + return (id,CncFun mty mlin mprn (Just (PMCFG lins))) +addPMCFG opts gr id_info = return id_info + +pmcfgForm :: Grammar -> L Ident -> Term -> Context -> Check [[[Symbol]]] +pmcfgForm gr _ t ctxt = + runEvalM gr $ do + (_,args) <- mapAccumM (\(d,r) (_,_,ty) -> do (r,v) <- type2metaValue d r ty + return ((d+1,r),v)) + (0,0) ctxt + v <- eval [] t args + (lins,_) <- value2pmcfg v [] + return (reverse lins) + +type2metaValue :: Int -> Int -> Type -> EvalM s (Int,Thunk s) +type2metaValue d r (Sort s) | s == cStr = do + tnk <- newEvaluatedThunk (VSymCat d r) + return (r+1,tnk) +type2metaValue d r (RecType lbls) = do + (r,lbls) <- mapAccumM (\i (lbl,ty) -> do (i,tnk) <- type2metaValue d i ty + return (i,(lbl,tnk))) + r lbls + tnk <- newEvaluatedThunk (VR lbls) + return (r,tnk) +type2metaValue d r (Table p q) = do + ts <- getAllParamValues p + (r,vs) <- mapAccumM (\r _ -> type2metaValue d r q) r ts + tnk <- newEvaluatedThunk (VV p vs) + return (r, tnk) +type2metaValue d r (QC q) = do + tnk <- newMeta 0 + return (r, tnk) + +value2pmcfg (VR as) lins = do + (lins,as) <- collectFields lins as + return (lins,VR as) where - gr = prependModule sgr cmo - 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 - 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 -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info) -addPMCFG opts gr opath am cm seqs id (CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do ---when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...") - let pres = protoFCat gr res val - pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont] - - pmcfgEnv0 = emptyPMCFGEnv - b <- convert opts gr (floc opath loc id) term (cont,val) pargs - let (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) $ - ePutStr ("\n+ "++showIdent id++" "++show (product (map catFactor pargs))) - seqs1 `seq` stats `seq` return () - when (verbAtLeast opts Verbose) $ ePutStr (" "++show stats) - return (seqs1,CncFun mty mlin mprn (Just pmcfg)) - where - (ctxt,res,_) = err bug typeForm (lookupFunType gr am id) - - addRule lins (newCat', newArgs') env0 = - let [newCat] = getFIds newCat' - !fun = mkArray lins - newArgs = map getFIds newArgs' - in addFunction env0 newCat fun newArgs - -addPMCFG opts gr opath am cm seqs id (CncCat mty@(Just (L _ lincat)) - mdef@(Just (L loc1 def)) - mref@(Just (L loc2 ref)) - mprn - Nothing) = do - let pcat = protoFCat gr (am,id) lincat - pvar = protoFCat gr (MN identW,cVar) typeStr - - pmcfgEnv0 = emptyPMCFGEnv - - let lincont = [(Explicit, varStr, typeStr)] - b <- convert opts gr (floc opath loc1 id) def (lincont,lincat) [pvar] - let (seqs1,b1) = addSequencesB seqs b - pmcfgEnv1 = foldBM addLindef - pmcfgEnv0 - (goB b1 CNil []) - (pcat,[pvar]) - - let lincont = [(Explicit, varStr, lincat)] - b <- convert opts gr (floc opath loc2 id) ref (lincont,typeStr) [pcat] - let (seqs2,b2) = addSequencesB seqs1 b - pmcfgEnv2 = foldBM addLinref - pmcfgEnv1 - (goB b2 CNil []) - (pvar,[pcat]) - - let pmcfg = getPMCFG pmcfgEnv2 - - when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" "++show (catFactor pcat)) - seqs2 `seq` pmcfg `seq` return (seqs2,CncCat mty mdef mref mprn (Just pmcfg)) - where - addLindef lins (newCat', newArgs') env0 = - let [newCat] = getFIds newCat' - !fun = mkArray lins - in addFunction env0 newCat fun [[fidVar]] - - addLinref lins (newCat', [newArg']) env0 = - let newArg = getFIds newArg' - !fun = mkArray lins - in addFunction env0 fidVar fun [newArg] - -addPMCFG opts gr opath am cm seqs id info = return (seqs, info) - -floc opath loc id = maybe (L loc id) (\path->L (External path loc) id) opath - -convert opts gr loc term ty@(_,val) pargs = error "TODO: convert" -{- case normalForm gr loc (etaExpand ty term) of - term -> return $ runCnvMonad gr (convertTerm opts CNil val term) (pargs,[])-} - where - etaExpand (context,val) = mkAbs pars . flip mkApp args - where pars = [(Explicit,v) | v <- vars] - args = map Vr vars - vars = map (\(bt,x,t) -> x) context - -pgfCncCat :: SourceGrammar -> PGF2.Cat -> Type -> Int -> (PGF2.Cat,Int,Int,[String]) -pgfCncCat gr id lincat index = - let ((_,size),schema) = computeCatRange gr lincat - in ( id - , index - , index+size-1 - , 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 --- --- The branching monad provides backtracking together with --- recording of the choices made. We have two cases --- when we have alternative choices: --- --- * when we have parameter type, then --- we have to try all possible values --- * when we have variants we have to try all alternatives --- --- The conversion monad keeps track of the choices and they are --- returned as 'Branch' data type. - -data Branch a - = Case Int Path [(Term,Branch a)] - | Variant [Branch a] - | Return a - -newtype CnvMonad a = CM {unCM :: SourceGrammar - -> forall b . (a -> ([ProtoFCat],[Symbol]) -> Branch b) - -> ([ProtoFCat],[Symbol]) - -> Branch b} - -instance Fail.MonadFail CnvMonad where - fail = bug - -instance Applicative CnvMonad where - pure = return - (<*>) = ap - -instance Monad CnvMonad where - return a = CM (\gr c s -> c a s) - CM m >>= k = CM (\gr c s -> m gr (\a s -> unCM (k a) gr c s) s) - -instance MonadState ([ProtoFCat],[Symbol]) CnvMonad where - get = CM (\gr c s -> c s s) - put s = CM (\gr c _ -> c () s) - -instance Functor CnvMonad where - fmap f (CM m) = CM (\gr c s -> m gr (c . f) s) - -runCnvMonad :: SourceGrammar -> CnvMonad a -> ([ProtoFCat],[Symbol]) -> Branch a -runCnvMonad gr (CM m) s = m gr (\v s -> Return v) s - --- | backtracking for all variants -variants :: [a] -> CnvMonad a -variants xs = CM (\gr c s -> Variant [c x s | x <- xs]) - --- | backtracking for all parameter values that a variable could take -choices :: Int -> Path -> CnvMonad Term -choices nr path = do (args,_) <- get - let PFCat _ _ schema = args !! nr - 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) - descend (CRec rs) CNil rpath = do rs <- mapM (\(lbl,Identity t) -> fmap (assign lbl) (descend t CNil (CProj lbl rpath))) rs - return (R rs) - descend (CTbl pt cs) (CSel trm path) rpath = case lookup trm cs of - Just (Identity t) -> descend t path (CSel trm rpath) - descend (CTbl pt cs) CNil rpath = do cs <- mapM (\(trm,Identity t) -> descend t CNil (CSel trm rpath)) cs - return (V pt cs) - descend (CPar (m,vs)) CNil rpath = case vs of - [(value,index)] -> return value - values -> let path = reversePath rpath - in CM (\gr c s -> Case nr path [(value, updateEnv path value gr c s) - | (value,index) <- values]) - descend schema path rpath = bug $ "descend "++show (schema,path,rpath) - - updateEnv path value gr c (args,seq) = - case updateNthM (restrictProtoFCat path value) nr args of - Just args -> c value (args,seq) - Nothing -> bug "conflict in updateEnv" - --- | the argument should be a parameter type and then --- the function returns all possible values. -getAllParamValues :: Type -> CnvMonad [Term] -getAllParamValues ty = CM (\gr c -> c (err bug id (allParamValues gr ty))) - -mkRecord :: [(Label,CnvMonad (Schema Branch s c))] -> CnvMonad (Schema Branch s c) -mkRecord xs = CM (\gr c -> foldl (\c (lbl,CM m) bs s -> c ((lbl,m gr (\v s -> Return v) s) : bs) s) (c . CRec) xs []) - -mkTable :: Type -> [(Term ,CnvMonad (Schema Branch s c))] -> CnvMonad (Schema Branch s c) -mkTable pt xs = CM (\gr c -> foldl (\c (trm,CM m) bs s -> c ((trm,m gr (\v s -> Return v) s) : bs) s) (c . CTbl pt) xs []) - ----------------------------------------------------------------------- --- Term Schema --- --- The term schema is a term-like structure, with records, tables, --- strings and parameters values, but in addition we could add --- annotations of arbitrary types - --- | Term schema -data Schema b s c - = CRec [(Label,b (Schema b s c))] - | CTbl Type [(Term, b (Schema b s c))] - | CStr s - | CPar c ---deriving Show -- doesn't work - -instance Show s => Show (Schema b s c) where - showsPrec _ sch = - case sch of - CRec r -> showString "CRec " . shows (map fst r) - CTbl t _ -> showString "CTbl " . showsPrec 10 t . showString " _" - CStr s -> showString "CStr " . showsPrec 10 s - CPar c -> showString "CPar{}" - --- | Path into a term or term schema -data Path - = CProj Label Path - | CSel Term Path - | CNil - deriving (Eq,Show) - --- | The ProtoFCat represents a linearization type as term schema. --- 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 Int (Schema Identity Int (Int,[(Term,Int)])) -type Env = (ProtoFCat, [ProtoFCat]) - -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) -> case lbl of - LVar _ -> let (st',t') = compute st t - in (st ,(lbl,Identity 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 bug 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 bug id (allParamValues gr t) - (index,m) = st - in ((index,m*length vs),CPar (m,zip vs [0..])) - -ppPath (CProj lbl path) = lbl <+> ppPath path -ppPath (CSel trm path) = ppU 5 trm <+> ppPath path -ppPath CNil = empty - -reversePath path = rev CNil path - where - rev path0 CNil = path0 - rev path0 (CProj lbl path) = rev (CProj lbl path0) path - rev path0 (CSel trm path) = rev (CSel trm path0) path - - ----------------------------------------------------------------------- --- term conversion - -type Value a = Schema Branch a Term - -convertTerm :: Options -> Path -> Type -> Term -> CnvMonad (Value [Symbol]) -convertTerm opts sel ctype (Vr x) = convertArg opts ctype (getVarIndex x) (reversePath sel) -convertTerm opts sel ctype (Abs _ _ t) = convertTerm opts sel ctype t -- there are only top-level abstractions and we ignore them !!! -convertTerm opts sel ctype (R record) = convertRec opts sel ctype record -convertTerm opts sel ctype (P term l) = convertTerm opts (CProj l sel) ctype term -convertTerm opts sel ctype (V pt ts) = convertTbl opts sel ctype pt ts -convertTerm opts sel ctype (S term p) = do v <- evalTerm CNil p - convertTerm opts (CSel v sel) ctype term -convertTerm opts sel ctype (FV vars) = do term <- variants vars - convertTerm opts sel ctype term -convertTerm opts sel ctype (C t1 t2) = do v1 <- convertTerm opts sel ctype t1 - v2 <- convertTerm opts sel ctype t2 - return (CStr (concat [s | CStr s <- [v1,v2]])) -convertTerm opts sel ctype (K t) = return (CStr [SymKS t]) -convertTerm opts sel ctype Empty = return (CStr []) -convertTerm opts sel ctype (Alts s alts)= do CStr s <- convertTerm opts CNil ctype s - alts <- forM alts $ \(u,alt) -> do - CStr u <- convertTerm opts CNil ctype u - Strs ps <- unPatt alt - ps <- mapM (convertTerm opts CNil ctype) ps - return (u,map unSym ps) - return (CStr [SymKP s alts]) - where - unSym (CStr []) = "" - unSym (CStr [SymKS t]) = t - unSym _ = ppbug $ hang ("invalid prefix in pre expression:") 4 (Alts s alts) - - unPatt (EPatt _ _ p) = fmap Strs (getPatts p) - unPatt u = return u - - getPatts p = case p of - PAlt a b -> liftM2 (++) (getPatts a) (getPatts b) - PString s -> return [K s] - PSeq _ _ a _ _ b -> do - as <- getPatts a - bs <- getPatts b - return [K (s ++ t) | K s <- as, K t <- bs] - _ -> fail (render ("not valid pattern in pre expression" <+> ppPatt Unqualified 0 p)) - -convertTerm opts sel ctype (Q (m,f)) - | m == cPredef && - f == cBIND = return (CStr [SymBIND]) - | m == cPredef && - f == cSOFT_BIND = return (CStr [SymSOFT_BIND]) - | m == cPredef && - f == cSOFT_SPACE = return (CStr [SymSOFT_SPACE]) - | m == cPredef && - f == cCAPIT = return (CStr [SymCAPIT]) - | m == cPredef && - f == cALL_CAPIT = return (CStr [SymALL_CAPIT]) - | m == cPredef && - f == cNonExist = return (CStr [SymNE]) -{- -convertTerm opts sel@(CProj l _) ctype (ExtR t1 t2@(R rs2)) - | l `elem` map fst rs2 = convertTerm opts sel ctype t2 - | otherwise = convertTerm opts sel ctype t1 - -convertTerm opts sel@(CProj l _) ctype (ExtR t1@(R rs1) t2) - | l `elem` map fst rs1 = convertTerm opts sel ctype t1 - | otherwise = convertTerm opts sel ctype t2 --} -convertTerm opts CNil ctype t = do v <- evalTerm CNil t - return (CPar v) -convertTerm _ sel _ t = ppbug ("convertTerm" <+> sep [parens (show sel),ppU 10 t]) - -convertArg :: Options -> Term -> Int -> Path -> CnvMonad (Value [Symbol]) -convertArg opts (RecType rs) nr path = - mkRecord (map (\(lbl,ctype) -> (lbl,convertArg opts ctype nr (CProj lbl path))) rs) -convertArg opts (Table pt vt) nr path = do - vs <- getAllParamValues pt - 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 - l = index (reversePath path) schema - sym | CProj (LVar i) CNil <- path = SymVar nr i - | isLiteralCat opts cat = SymLit nr l - | otherwise = SymCat nr l - return (CStr [sym]) - where - index (CProj lbl path) (CRec rs) = case lookup lbl rs of - Just (Identity t) -> index path t - index (CSel trm path) (CTbl _ rs) = case lookup trm rs of - Just (Identity t) -> index path t - index CNil (CStr idx) = idx -convertArg opts ty nr path = do - value <- choices nr (reversePath path) - return (CPar value) - -convertRec opts CNil (RecType rs) record = - mkRecord [(lbl,convertTerm opts CNil ctype (proj lbl))|(lbl,ctype)<-rs] - where proj lbl = if isLockLabel lbl then R [] else projectRec lbl record -convertRec opts (CProj lbl path) ctype record = - convertTerm opts path ctype (projectRec lbl record) -convertRec opts _ ctype _ = bug ("convertRec: "++show ctype) - -convertTbl opts CNil (Table _ vt) pt ts = do - vs <- getAllParamValues pt - mkTable pt (zipWith (\v t -> (v,convertTerm opts CNil vt t)) vs ts) -convertTbl opts (CSel v sub_sel) ctype pt ts = do - vs <- getAllParamValues pt - case lookup v (zip vs ts) of - Just t -> convertTerm opts sub_sel ctype t - Nothing -> ppbug ( "convertTbl:" <+> ("missing value" <+> v $$ - "among" <+> vcat vs)) -convertTbl opts _ ctype _ _ = bug ("convertTbl: "++show ctype) - - -goB :: Branch (Value SeqId) -> Path -> [SeqId] -> BacktrackM Env [SeqId] -goB (Case nr path bs) rpath ss = do (value,b) <- member bs - restrictArg nr path value - goB b rpath ss -goB (Variant bs) rpath ss = do b <- member bs - goB b rpath ss -goB (Return v) rpath ss = goV v rpath ss - -goV :: Value SeqId -> Path -> [SeqId] -> BacktrackM Env [SeqId] -goV (CRec xs) rpath ss = foldM (\ss (lbl,b) -> goB b (CProj lbl rpath) ss) ss (reverse xs) -goV (CTbl _ xs) rpath ss = foldM (\ss (trm,b) -> goB b (CSel trm rpath) ss) ss (reverse xs) -goV (CStr seqid) rpath ss = return (seqid : ss) -goV (CPar t) rpath ss = restrictHead (reversePath rpath) t >> return ss - - ----------------------------------------------------------------------- --- SeqSet - -type SeqSet = Map.Map [Symbol] SeqId - -addSequencesB :: SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId)) -addSequencesB seqs (Case nr path bs) = let !(seqs1,bs1) = 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) = 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) = 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) = 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 lin - in (seqs1,CStr seqid) -addSequencesV seqs (CPar i) = (seqs,CPar i) - --- a strict version of Data.List.mapAccumL -mapAccumL' f s [] = (s,[]) -mapAccumL' f s (x:xs) = (s'',y:ys) - where !(s', y ) = f s x - !(s'',ys) = mapAccumL' f s' xs - -addSequence :: SeqSet -> [Symbol] -> (SeqSet,SeqId) -addSequence seqs seq = - 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) - - ------------------------------------------------------------- --- eval a term to ground terms - -evalTerm :: Path -> Term -> CnvMonad Term -evalTerm CNil (QC f) = return (QC f) -evalTerm CNil (App x y) = do x <- evalTerm CNil x - y <- evalTerm CNil y - return (App x y) -evalTerm path (Vr x) = choices (getVarIndex x) path -evalTerm path (R rs) = - case path of - CProj lbl path -> evalTerm path (projectRec lbl rs) - CNil -> R `fmap` mapM (\(lbl,(_,t)) -> assign lbl `fmap` evalTerm path t) rs -evalTerm path (P term lbl) = evalTerm (CProj lbl path) term -evalTerm path (V pt ts) = - case path of - CNil -> V pt `fmap` mapM (evalTerm path) ts - CSel trm path -> - do vs <- getAllParamValues pt - case lookup trm (zip vs ts) of - Just t -> evalTerm path t - Nothing -> ppbug $ "evalTerm: missing value:"<+>trm - $$ "among:" <+>fsep (map (ppU 10) vs) -evalTerm path (S term sel) = do v <- evalTerm CNil sel - evalTerm (CSel v path) term -evalTerm path (FV terms) = variants terms >>= evalTerm path -evalTerm path (EInt n) = return (EInt n) -evalTerm path t = ppbug ("evalTerm" <+> parens t) ---evalTerm path t = ppbug (text "evalTerm" <+> sep [parens (text (show path)),parens (text (show t))]) - -getVarIndex x = maybe err id $ getArgIndex x - where err = bug ("getVarIndex "++show x) - ----------------------------------------------------------------------- --- GrammarEnv - -data PMCFGEnv = PMCFGEnv !ProdSet !FunSet -type ProdSet = Set.Set Production -type FunSet = Map.Map (UArray LIndex SeqId) FunId - -emptyPMCFGEnv = - PMCFGEnv Set.empty Map.empty - -addFunction :: PMCFGEnv -> FId -> UArray LIndex SeqId -> [[FId]] -> PMCFGEnv -addFunction (PMCFGEnv prodSet funSet) !fid fun args = - case Map.lookup fun funSet of - 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 - optimize ps = Map.foldrWithKey ff [] (Map.fromListWith (++) [((fid,funid),[args]) | (Production fid funid args) <- Set.toList ps]) - where - 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 - -restrictArg :: LIndex -> Path -> Term -> BacktrackM Env () -restrictArg nr path index = do - (head, args) <- get - args <- updateNthM (restrictProtoFCat path index) nr args - put (head, args) - -restrictHead :: Path -> Term -> BacktrackM Env () -restrictHead path term = do - (head, args) <- get - head <- restrictProtoFCat path term head - put (head, args) - -restrictProtoFCat :: (Functor m, MonadPlus m) => Path -> Term -> ProtoFCat -> m ProtoFCat -restrictProtoFCat path v (PFCat cat f schema) = do - schema <- addConstraint path v 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 - addConstraint CNil v (CPar (m,vs)) = case lookup v vs of - Just index -> return (CPar (m,[(v,index)])) - Nothing -> mzero - addConstraint CNil v (CStr _) = bug "restrictProtoFCat: string path" - - update k0 f [] = return [] - update k0 f (x@(k,Identity v):xs) - | k0 == k = do v <- f v - return ((k,Identity v):xs) - | otherwise = do xs <- update k0 f xs - return (x:xs) - -mkArray lst = listArray (0,length lst-1) lst -mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] - -bug msg = ppbug msg -ppbug msg = error completeMsg - where - originalMsg = render $ hang "Internal error in GeneratePMCFG:" 4 msg - completeMsg = - case render msg of -- the error message for pattern matching a runtime string - "descend (CStr 0,CNil,CProj (LIdent (Id {rawId2utf8 = \"s\"})) CNil)" - -> unlines [originalMsg -- add more helpful output - ,"" - ,"1) Check that you are not trying to pattern match a /runtime string/." - ," These are illegal:" - ," lin Test foo = case foo.s of {" - ," \"str\" => … } ; <- explicit matching argument of a lin" - ," lin Test foo = opThatMatches foo <- calling an oper that pattern matches" - ,"" - ,"2) Not about pattern matching? Submit a bug report and we update the error message." - ," https://github.com/GrammaticalFramework/gf-core/issues" - ] - _ -> originalMsg -- any other message: just print it as is - -ppU = ppTerm Unqualified + collectFields lins [] = do + return (lins,[]) + collectFields lins ((lbl,tnk):as) = do + v <- force tnk [] + (lins,v) <- value2pmcfg v lins + case v of + VR [] -> collectFields lins as + _ -> do (lins,as) <- collectFields lins as + tnk <- newEvaluatedThunk v + return (lins,(lbl,tnk):as) +value2pmcfg v lins = do + lin <- value2lin v + return (lin:lins,VR []) + +value2lin (VStr s) = + return [SymKS s] +value2lin (VC vs) = + fmap concat (mapM value2lin vs) +value2lin (VSymCat d r) = + return [SymCat d r] + + +mapAccumM f a [] = return (a,[]) +mapAccumM f a (x:xs) = do (a, y) <- f a x + (a,ys) <- mapAccumM f a xs + return (a,y:ys) + +pgfCncCat = error "TODO: pgfCncCat" diff --git a/src/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs deleted file mode 100644 index c78c16819..000000000 --- a/src/compiler/GF/Compile/Optimize.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# LANGUAGE PatternGuards #-} ----------------------------------------------------------------------- --- | --- Module : Optimize --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/16 13:56:13 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.18 $ --- --- Top-level partial evaluation for GF source modules. ------------------------------------------------------------------------------ - -module GF.Compile.Optimize (optimizeModule) where - -import GF.Infra.Ident -import GF.Infra.CheckM -import GF.Infra.Option -import GF.Grammar.Grammar -import GF.Grammar.Printer -import GF.Grammar.Macros -import GF.Grammar.Lookup -import GF.Grammar.Predef -import GF.Compile.Compute.Concrete(normalForm) -import GF.Data.Operations - -import Control.Monad -import qualified Data.Set as Set -import qualified Data.Map as Map -import GF.Text.Pretty -import Debug.Trace - --- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005. - -optimizeModule :: Options -> SourceGrammar -> SourceModule -> Check SourceModule -optimizeModule opts sgr m@(name,mi) - | mstatus mi == MSComplete = do - ids <- topoSortJments m - mi <- foldM updateEvalInfo mi ids - return (name,mi) - | otherwise = return m - where - oopts = opts `addOptions` mflags mi - - updateEvalInfo mi (i,info) = do - info <- evalInfo oopts sgr (name,mi) i info - return (mi{jments=Map.insert i info (jments mi)}) - -evalInfo :: Options -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info -evalInfo opts sgr m c info = do - - (if verbAtLeast opts Verbose then trace (" " ++ showIdent c) else id) return () - - errIn ("optimizing " ++ showIdent c) $ case info of - - CncCat ptyp pde pre 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 - return (Just (L loc (factor param c 0 de))) - (Just (L loc typ), Nothing) -> do - de <- mkLinDefault gr typ - de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de - return (Just (L loc (factor param c 0 de))) - _ -> return pde -- indirection - - pre' <- case (ptyp,pre) of - (Just (L _ typ), Just (L loc re)) -> do - re <- partEval opts gr ([(Explicit, varStr, typ)], typeStr) re - return (Just (L loc (factor param c 0 re))) - (Just (L loc typ), Nothing) -> do - re <- mkLinReference gr typ - re <- partEval opts gr ([(Explicit, varStr, typ)], typeStr) re - return (Just (L loc (factor param c 0 re))) - _ -> return pre -- indirection - - ppr' <- case ppr of - Just pr -> fmap Just (evalPrintname sgr c pr) - Nothing -> return ppr - - return (CncCat ptyp pde' pre' ppr' mpmcfg) - - CncFun (mt@(Just (_,cont,val))) pde ppr mpmcfg -> --trace (prt c) $ - eIn ("linearization in type" <+> mkProd cont val [] $$ "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' <- case ppr of - Just pr -> fmap Just (evalPrintname sgr c pr) - Nothing -> return ppr - return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed -{- - ResOper pty pde - | not new && OptExpand `Set.member` optim -> do - pde' <- case pde of - Just (L loc de) -> do de <- computeConcrete gr de - return (Just (L loc (factor param c 0 de))) - Nothing -> return Nothing - return $ ResOper pty pde' --} - _ -> return info - where --- new = flag optNewComp opts -- computations moved to GF.Compile.GeneratePMCFG - - gr = prependModule sgr m - optim = flag optOptimizations opts - param = OptParametrize `Set.member` optim - eIn cat = errIn (render ("Error optimizing" <+> cat <+> c <+> ':')) - --- | the main function for compiling linearizations -partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Check Term -partEval opts = error "TODO: partEval" - {-if flag optNewComp opts - then partEvalNew opts-} - {-else partEvalOld opts-} -{- -partEvalNew opts gr (context, val) trm = - errIn (render ("partial evaluation" <+> ppTerm Qualified 0 trm)) $ - checkPredefError trm - -partEvalOld opts gr (context, val) trm = errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $ do - let vars = map (\(bt,x,t) -> x) context - args = map Vr vars - subst = [(v, Vr v) | v <- vars] - trm1 = mkApp trm args - trm2 <- computeTerm gr subst trm1 - trm3 <- if rightType trm2 - then computeTerm gr subst trm2 -- compute twice?? - else recordExpand val trm2 >>= computeTerm gr subst - trm4 <- checkPredefError trm3 - return $ mkAbs [(Explicit,v) | v <- vars] trm4 - where - -- don't eta expand records of right length (correct by type checking) - rightType (R rs) = case val of - RecType ts -> length rs == length ts - _ -> False - rightType _ = False - - --- here we must be careful not to reduce --- variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}} --- {s = variants {"Auto" ; "Wagen"} ; g = variants {N ; M}} ; - -recordExpand :: Type -> Term -> Err Term -recordExpand typ trm = case typ of - RecType tys -> case trm of - FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs] - _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys] - _ -> return trm - --} --- | auxiliaries for compiling the resource - -mkLinDefault :: SourceGrammar -> Type -> Check Term -mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ - where - mkDefField typ = case typ of - Table p t -> do - t' <- mkDefField t - let T _ cs = mkWildCases t' - return $ T (TWild p) cs - Sort s | s == cStr -> return $ Vr varStr - QC p -> do case lookupParamValues gr p of - Ok (v:_) -> return v - _ -> checkError ("no parameter values given to type" <+> ppQIdent Qualified p) - RecType r -> do - let (ls,ts) = unzip r - ts <- mapM mkDefField ts - return $ R (zipWith assign ls ts) - _ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val - _ -> checkError ("linearization type field cannot be" <+> typ) - -mkLinReference :: SourceGrammar -> Type -> Check Term -mkLinReference gr typ = - liftM (Abs Explicit varStr) $ - case mkDefField typ (Vr varStr) of - Bad "no string" -> return Empty - Ok x -> return x - where - mkDefField ty trm = - case ty of - Table pty ty -> do ps <- allParamValues gr pty - case ps of - [] -> Bad "no string" - (p:ps) -> mkDefField ty (S trm p) - Sort s | s == cStr -> return trm - QC p -> Bad "no string" - RecType [] -> Bad "no string" - RecType rs -> do - msum (map (\(l,ty) -> mkDefField ty (P trm l)) (sortRec rs)) - `mplus` Bad "no string" - _ | Just _ <- isTypeInts typ -> Bad "no string" - _ -> Bad (render ("linearization type field cannot be" <+> typ)) - -evalPrintname :: Grammar -> Ident -> L Term -> Check (L Term) -evalPrintname gr c (L loc pr) = do - pr <- normalForm gr (L loc c) pr - return (L loc pr) - --- do even more: factor parametric branches - -factor :: Bool -> Ident -> Int -> Term -> Term -factor param c i t = - case t of - T (TComp ty) cs -> factors ty [(p, factor param c (i+1) v) | (p, v) <- cs] - _ -> composSafeOp (factor param c i) t - where - factors ty pvs0 - | not param = V ty (map snd pvs0) - factors ty [] = V ty [] - factors ty pvs0@[(p,v)] = V ty [v] - factors ty pvs0@(pv:pvs) = - let t = mkFun pv - ts = map mkFun pvs - in if all (==t) ts - then T (TTyped ty) (mkCases t) - else V ty (map snd pvs0) - - --- we hope this will be fresh and don't check... in GFC would be safe - qvar = identS ("q_" ++ showIdent c ++ "__" ++ show i) - - mkFun (patt, val) = replace (patt2term patt) (Vr qvar) val - mkCases t = [(PV qvar, t)] - --- we need to replace subterms -replace :: Term -> Term -> Term -> Term -replace old new trm = - case trm of - -- these are the important cases, since they can correspond to patterns - QC _ | trm == old -> new - App _ _ | trm == old -> new - R _ | trm == old -> new - App x y -> App (replace old new x) (replace old new y) - _ -> composSafeOp (replace old new) trm diff --git a/src/compiler/GF/Compile/OptimizePGF.hs b/src/compiler/GF/Compile/OptimizePGF.hs index 730322649..aefb42a11 100644 --- a/src/compiler/GF/Compile/OptimizePGF.hs +++ b/src/compiler/GF/Compile/OptimizePGF.hs @@ -2,7 +2,7 @@ module GF.Compile.OptimizePGF(optimizePGF) where import PGF2(Cat,Fun) -import PGF2.Internal +import PGF2.Transactions import Data.Array.ST import Data.Array.Unboxed import qualified Data.Map as Map @@ -12,13 +12,14 @@ import qualified Data.IntMap as IntMap import qualified Data.List as List import Control.Monad.ST -type ConcrData = ([(FId,[FunId])], -- ^ Lindefs +type ConcrData = () +{-([(FId,[FunId])], -- ^ Lindefs [(FId,[FunId])], -- ^ Linrefs [(FId,[Production])], -- ^ Productions [(Fun,[SeqId])], -- ^ Concrete functions (must be sorted by Fun) [[Symbol]], -- ^ Sequences (must be sorted) [(Cat,FId,FId,[String])]) -- ^ Concrete categories - +-} optimizePGF :: Cat -> ConcrData -> ConcrData optimizePGF startCat = error "TODO: optimizePGF" {- topDownFilter startCat . bottomUpFilter diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 7bbe1d8dc..a437b0ea8 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -78,7 +78,7 @@ extendModule cwd gr (name,m) -- | rebuilding instance + interface, and "with" modules, prior to renaming. -- AR 24/10/2003 rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule -rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) = +rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ js_)) = checkInModule cwd mi NoLoc empty $ do ---- deps <- moduleDeps ms @@ -115,7 +115,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js else MSIncomplete unless (stat' == MSComplete || stat == MSIncomplete) (checkError ("module" <+> i <+> "remains incomplete")) - ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext + ModInfo mt0 _ fs me' _ ops0 _ fpath js <- lookupModule gr ext let ops1 = nub $ ops_ ++ -- N.B. js has been name-resolved already [OQualif i j | (i,j) <- ops] ++ @@ -131,7 +131,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js js let js1 = Map.union js0 js_ let med1= nub (ext : infs ++ insts ++ med_) - return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ env_ js1 + return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ js1 return (i,mi') diff --git a/src/compiler/GF/CompileOne.hs b/src/compiler/GF/CompileOne.hs index 9d0814328..5f214157b 100644 --- a/src/compiler/GF/CompileOne.hs +++ b/src/compiler/GF/CompileOne.hs @@ -8,7 +8,6 @@ module GF.CompileOne(-- ** Compiling a single module import GF.Compile.GetGrammar(getSourceModule) import GF.Compile.Rename(renameModule) import GF.Compile.CheckGrammar(checkModule) -import GF.Compile.Optimize(optimizeModule) import GF.Compile.SubExOpt(subexpModule,unsubexpModule) import GF.Compile.GeneratePMCFG(generatePMCFG) import GF.Compile.Update(extendModule,rebuildModule) @@ -107,10 +106,9 @@ compileSourceModule opts cwd mb_gfFile gr = -- Apply to complete modules when not generating tags backend mo3 = - do mo4 <- runPass Optimize "optimizing" $ optimizeModule opts gr mo3 - if isModCnc (snd mo4) && flag optPMCFG opts - then runPassI "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4 - else runPassI "" $ return mo4 + do if isModCnc (snd mo3) && flag optPMCFG opts + then runPassI "generating PMCFG" $ fmap fst $ runCheck' opts (generatePMCFG opts gr mo3) + else runPassI "" $ return mo3 ifComplete yes mo@(_,mi) = if isCompleteModule mi then yes mo else return mo diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs index 9b61d9dfe..cd27ee96c 100644 --- a/src/compiler/GF/Grammar/Binary.hs +++ b/src/compiler/GF/Grammar/Binary.hs @@ -23,10 +23,10 @@ import GF.Infra.UseIO(MonadIO(..)) import GF.Grammar.Grammar import PGF2(Literal(..)) -import PGF2.Internal(Symbol(..)) +import PGF2.Transactions(Symbol(..)) -- Please change this every time when the GFO format is changed -gfoVersion = "GF04" +gfoVersion = "GF05" instance Binary Ident where put id = put (ident2utf8 id) @@ -44,9 +44,9 @@ instance Binary Grammar where get = fmap mGrammar get instance Binary ModuleInfo where - 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) + 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,mflags,mextend,mwith,mopens,med,msrc,jments) <- get + return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc jments) instance Binary ModuleType where put MTAbstract = putWord8 0 @@ -103,18 +103,9 @@ instance Binary Options where toString (LInt n) = show n toString (LFlt d) = show d -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) + put (PMCFG lins) = put lins + get = fmap PMCFG get instance Binary Info where put (AbsCat x) = putWord8 0 >> put x @@ -377,7 +368,7 @@ decodeModuleHeader :: MonadIO io => FilePath -> io (VersionTagged Module) decodeModuleHeader = liftIO . fmap (fmap conv) . decodeFile' where conv (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) = - (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty) + (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Map.empty) encodeModule :: MonadIO io => FilePath -> SourceModule -> io () encodeModule fpath mo = liftIO $ encodeFile fpath (Tagged mo) diff --git a/src/compiler/GF/Grammar/CFG.hs b/src/compiler/GF/Grammar/CFG.hs index 9d73c3b48..de20eb8bc 100644 --- a/src/compiler/GF/Grammar/CFG.hs +++ b/src/compiler/GF/Grammar/CFG.hs @@ -8,7 +8,7 @@ module GF.Grammar.CFG(Cat,Token, module GF.Grammar.CFG) where import GF.Data.Utilities import PGF2(Fun,Cat) -import PGF2.Internal(Token) +import PGF2.Transactions(Token) import GF.Data.Relation import Data.Map (Map) diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index a7267ddc4..18dd56613 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -64,7 +64,7 @@ module GF.Grammar.Grammar ( Location(..), L(..), unLoc, noLoc, ppLocation, ppL, -- ** PMCFG - PMCFG(..), Production(..), FId, FunId, SeqId, LIndex + PMCFG(..) ) where import GF.Infra.Ident @@ -74,7 +74,7 @@ import GF.Infra.Location import GF.Data.Operations import PGF2(BindType(..)) -import PGF2.Internal(FId, FunId, SeqId, LIndex, Symbol) +import PGF2.Transactions(Symbol) import Data.Array.IArray(Array) import Data.Array.Unboxed(UArray) @@ -100,7 +100,6 @@ data ModuleInfo = ModInfo { mopens :: [OpenSpec], mexdeps :: [ModuleName], msrc :: FilePath, - mseqs :: Maybe (Array SeqId [Symbol]), jments :: Map.Map Ident Info } @@ -305,13 +304,7 @@ 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)) +data PMCFG = PMCFG [[[Symbol]]] deriving (Eq,Show) -- | the constructors are judgements in diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y index 5959480ef..7216c7594 100644 --- a/src/compiler/GF/Grammar/Parser.y +++ b/src/compiler/GF/Grammar/Parser.y @@ -132,14 +132,14 @@ ModDef (opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) } jments <- mapM (checkInfoType mtype) jments defs <- buildAnyTree id jments - return (id, ModInfo mtype mstat opts extends with opens [] "" Nothing defs) } + return (id, ModInfo mtype mstat opts extends with opens [] "" 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 [] "" Nothing Map.empty) } + in (id, ModInfo mtype mstat noOptions extends with opens [] "" Map.empty) } ComplMod :: { ModuleStatus } ComplMod diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index 48b05a188..aee20cd2c 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -25,7 +25,7 @@ module GF.Grammar.Printer import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import PGF2 as PGF2 -import PGF2.Internal as PGF2 +import PGF2.Transactions as PGF2 import GF.Infra.Ident import GF.Infra.Option import GF.Grammar.Values @@ -46,11 +46,10 @@ instance Pretty Grammar where pp = vcat . map (ppModule Qualified) . modules ppModule :: TermPrintQual -> SourceModule -> Doc -ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) = +ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ jments) = hdr $$ nest 2 (ppOptions opts $$ - vcat (map (ppJudgement q) (Map.toList jments)) $$ - maybe empty (ppSequences q) mseqs) $$ + vcat (map (ppJudgement q) (Map.toList jments))) $$ ftr where hdr = complModDoc <+> modTypeDoc <+> '=' <+> @@ -136,13 +135,9 @@ ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) = Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';' Nothing -> empty) $$ (case (mpmcfg,q) of - (Just (PMCFG prods funs),Internal) + (Just (PMCFG lins),Internal) -> "pmcfg" <+> id <+> '=' <+> '{' $$ - nest 2 (vcat (map ppProduction prods) $$ - ' ' $$ - vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+> - parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr))))) - (Array.assocs funs))) $$ + nest 2 (vcat (map ppPmcfgLin lins)) $$ '}' _ -> empty) ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) = @@ -154,13 +149,9 @@ ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) = Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';' Nothing -> empty) $$ (case (mpmcfg,q) of - (Just (PMCFG prods funs),Internal) + (Just (PMCFG lins),Internal) -> "pmcfg" <+> id <+> '=' <+> '{' $$ - nest 2 (vcat (map ppProduction prods) $$ - ' ' $$ - vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+> - parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr))))) - (Array.assocs funs))) $$ + nest 2 (vcat (map ppPmcfgLin lins)) $$ '}' _ -> empty) ppJudgement q (id, AnyInd cann mid) = @@ -168,6 +159,9 @@ ppJudgement q (id, AnyInd cann mid) = Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';' _ -> empty +ppPmcfgLin lin = + brackets (vcat (map (hsep . map ppSymbol) lin)) + instance Pretty Term where pp = ppTerm Unqualified 0 ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e) @@ -330,18 +324,6 @@ ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps)) ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt) -ppProduction (Production fid funid args) = - ppFId fid <+> "->" <+> ppFunId funid <> - brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args))) - -ppSequences q seqsArr - | null seqs || q /= Internal = empty - | otherwise = "sequences" <+> '{' $$ - nest 2 (vcat (map ppSeq seqs)) $$ - '}' - where - seqs = Array.assocs seqsArr - commaPunct f ds = (hcat (punctuate "," (map f ds))) prec d1 d2 doc @@ -365,17 +347,6 @@ getLet (Let l e) = let (ls,e') = getLet e in (l:ls,e') getLet e = ([],e) -ppFunId funid = pp 'F' <> pp funid -ppSeqId seqid = pp 'S' <> pp seqid - -ppFId fid - | fid == PGF2.fidString = pp "CString" - | fid == PGF2.fidInt = pp "CInt" - | fid == PGF2.fidFloat = pp "CFloat" - | fid == PGF2.fidVar = pp "CVar" - | fid == PGF2.fidStart = pp "CStart" - | otherwise = pp 'C' <> pp fid - ppMeta :: Int -> Doc ppMeta n | n == 0 = pp '?' @@ -385,9 +356,6 @@ ppLit (PGF2.LStr s) = pp (show s) ppLit (PGF2.LInt n) = pp n ppLit (PGF2.LFlt d) = pp d -ppSeq (seqid,seq) = - ppSeqId seqid <+> pp ":=" <+> hsep (map ppSymbol seq) - ppSymbol (PGF2.SymCat d r) = pp '<' <> pp d <> pp ',' <> pp r <> pp '>' ppSymbol (PGF2.SymLit d r) = pp '{' <> pp d <> pp ',' <> pp r <> pp '}' ppSymbol (PGF2.SymVar d r) = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>' diff --git a/src/runtime/haskell/PGF2/Internal.hsc b/src/runtime/haskell/PGF2/Internal.hsc index f700e225e..c60be58dc 100644 --- a/src/runtime/haskell/PGF2/Internal.hsc +++ b/src/runtime/haskell/PGF2/Internal.hsc @@ -7,38 +7,13 @@ module PGF2.Internal(-- * Access the internal structures -- * Byte code CodeLabel, Instr(..), IVal(..), TailInfo(..), - SeqId,LIndex, - FunId,Token,Production(..),PArg(..),Symbol(..), - unionPGF, writeConcr ) where import PGF2.FFI import PGF2.Expr -type Token = String -type LIndex = Int -data Symbol - = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex - | SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex - | SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int - | SymKS Token - | SymKP [Symbol] [([Symbol],[String])] - | SymBIND -- the special BIND token - | SymNE -- non exist - | SymSOFT_BIND -- the special SOFT_BIND token - | SymSOFT_SPACE -- the special SOFT_SPACE token - | SymCAPIT -- the special CAPIT token - | SymALL_CAPIT -- the special ALL_CAPIT token - deriving (Eq,Ord,Show) -data Production - = PApply {-# UNPACK #-} !FunId [PArg] - | PCoerce {-# UNPACK #-} !FId - deriving (Eq,Ord,Show) -type FunId = Int -type SeqId = Int type FId = Int -data PArg = PArg [FId] {-# UNPACK #-} !FId deriving (Eq,Ord,Show) fidString, fidInt, fidFloat, fidVar, fidStart :: FId fidString = (-1) diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index a3f4df371..b57a7af22 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/src/runtime/haskell/PGF2/Transactions.hsc @@ -1,5 +1,7 @@ module PGF2.Transactions ( Transaction + + -- abstract syntax , modifyPGF , branchPGF , checkoutPGF @@ -9,6 +11,9 @@ module PGF2.Transactions , dropCategory , setGlobalFlag , setAbstractFlag + + -- concrete syntax + , Token, LIndex, Symbol(..) ) where import PGF2.FFI @@ -144,3 +149,20 @@ setAbstractFlag name value = Transaction $ \c_db c_revision c_exn -> bracket (newStablePtr value) freeStablePtr $ \c_value -> withForeignPtr marshaller $ \m -> pgf_set_abstract_flag c_db c_revision c_name c_value m c_exn + + +type Token = String +type LIndex = Int +data Symbol + = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex + | SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex + | SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | SymKS Token + | SymKP [Symbol] [([Symbol],[String])] + | SymBIND -- the special BIND token + | SymNE -- non exist + | SymSOFT_BIND -- the special SOFT_BIND token + | SymSOFT_SPACE -- the special SOFT_SPACE token + | SymCAPIT -- the special CAPIT token + | SymALL_CAPIT -- the special ALL_CAPIT token + deriving (Eq,Show)