diff --git a/src/compiler/GF/Compile/Compute/Concrete.hs b/src/compiler/GF/Compile/Compute/Concrete.hs index 841a277a5..d2ccf8931 100644 --- a/src/compiler/GF/Compile/Compute/Concrete.hs +++ b/src/compiler/GF/Compile/Compute/Concrete.hs @@ -8,7 +8,7 @@ module GF.Compile.Compute.Concrete , EvalM, runEvalM, evalError , eval, apply, force, value2term , newMeta,getMeta,setMeta - , newEvaluatedThunk,getAllParamValues + , newThunk,newEvaluatedThunk,getAllParamValues , lookupParams ) where @@ -34,6 +34,7 @@ import Control.Applicative import qualified Control.Monad.Fail as Fail import qualified Data.Map as Map import GF.Text.Pretty +import PGF2.Transactions(LIndex) -- * Main entry points @@ -78,8 +79,9 @@ 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. + -- This last constructor is only generated internally + -- in the PMCFG generator. + | VSymCat Int LIndex [(LIndex, Thunk s)] eval env (Vr x) vs = case lookup x env of @@ -181,6 +183,11 @@ eval env (Alts d as) [] = do vd <- eval env d [] return (VAlts vd vas) eval env (Strs ts) [] = do vs <- mapM (\t -> eval env t []) ts return (VStrs vs) +eval env (TSymCat d r rs) []= do rs <- forM rs $ \(i,pv) -> + case lookup pv env of + Just tnk -> return (i,tnk) + Nothing -> evalError ("Variable" <+> pp pv <+> "is not in scope") + return (VSymCat d r rs) eval env t vs = evalError ("Cannot reduce term" <+> pp t) apply (VMeta m env vs0) vs = do st <- getMeta m diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 2c5e36334..dec233a5a 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -15,13 +15,17 @@ module GF.Compile.GeneratePMCFG import GF.Grammar hiding (VApp) import GF.Grammar.Predef +import GF.Grammar.Lookup import GF.Infra.CheckM import GF.Infra.Option import GF.Text.Pretty import GF.Compile.Compute.Concrete +import GF.Data.Operations(Err(..)) import PGF2.Transactions import qualified Data.Map.Strict as Map import Control.Monad +import Data.List(mapAccumL) +import Debug.Trace generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule generatePMCFG opts cwd gr cmo@(cm,cmi) = do @@ -38,35 +42,40 @@ addPMCFG opts cwd gr cmi 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 + ((_,ms),args) <- mapAccumM (\(d,ms) (_,_,ty) -> do + let (ms',_,t) = type2metaTerm gr d ms 0 [] ty + tnk <- trace (show (ppTerm Unqualified 0 t)) $ newThunk [] t + return ((d+1,ms'),tnk)) + (0,Map.empty) ctxt + sequence_ [newMeta (Just ty) i | (i,ty) <- Map.toList ms] 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 ty@(QC q) = do - tnk <- newMeta (Just ty) 0 - return (r, tnk) +type2metaTerm :: SourceGrammar -> Int -> Map.Map MetaId Type -> LIndex -> [(LIndex,Ident)] -> Type -> (Map.Map MetaId Type,Int,Term) +type2metaTerm gr d ms r rs (Sort s) | s == cStr = + (ms,r+1,TSymCat d r rs) +type2metaTerm gr d ms r rs (RecType lbls) = + let ((ms',r'),ass) = mapAccumL (\(ms,r) (lbl,ty) -> let (ms',r',t) = type2metaTerm gr d ms r rs ty + in ((ms',r'),(lbl,(Just ty,t)))) + (ms,r) lbls + in (ms',r',R ass) +type2metaTerm gr d ms r rs (Table p q) = + let pv = identS ('p':show (length rs)) + (ms',r',t) = type2metaTerm gr d ms r ((r'-r,pv):rs) q + count = case allParamValues gr p of + Ok ts -> length ts + Bad msg -> error msg + in (ms',(r'-r)*count,T (TTyped p) [(PV pv,t)]) +type2metaTerm gr d ms r rs ty@(QC q) = + let i = Map.size ms + 1 + in (Map.insert i ty ms,r,Meta i) value2pmcfg (VSusp tnk env vs k) lins = do st <- getMeta tnk case st of + Unevaluated _ t -> do v <- eval env t vs + value2pmcfg v lins Evaluated v -> do v <- apply v vs value2pmcfg v lins Unbound (Just (QC q)) _ -> do (m,ps) <- lookupParams q @@ -92,16 +101,22 @@ value2pmcfg (VR as) lins = do tnk <- newEvaluatedThunk v return (lins,(lbl,tnk):as) value2pmcfg v lins = do - case value2lin v of - Just lin -> return (lin:lins,VR []) - Nothing -> do t <- value2term 0 v - evalError ("the term" <+> ppTerm Unqualified 0 t $$ - "cannot be evaluated at compile time.") + lin <- value2lin v + return (lin:lins,VR []) -value2lin (VStr s) = Just [SymKS s] -value2lin (VSymCat d r) = Just [SymCat d r] -value2lin (VC vs) = fmap concat (mapM value2lin vs) -value2lin _ = Nothing +value2lin (VStr s) = return [SymKS s] +value2lin (VSymCat d r rs) = do rs <- forM rs $ \(i,tnk) -> do + v <- force tnk [] + j <- case v of + VMeta tnk _ _ -> do st <- getMeta tnk + case st of + Unbound _ j -> return j + return (i,j) + return [SymCat d r rs] +value2lin (VC vs) = fmap concat (mapM value2lin vs) +value2lin v = do t <- value2term 0 v + evalError ("the term" <+> ppTerm Unqualified 0 t $$ + "cannot be evaluated at compile time.") mapAccumM f a [] = return (a,[]) mapAccumM f a (x:xs) = do (a, y) <- f a x diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs index cd27ee96c..b893a5215 100644 --- a/src/compiler/GF/Grammar/Binary.hs +++ b/src/compiler/GF/Grammar/Binary.hs @@ -308,7 +308,7 @@ instance Binary Literal where _ -> decodingError instance Binary Symbol where - put (SymCat n l) = putWord8 0 >> put (n,l) + put (SymCat d r rs) = putWord8 0 >> put (d,r,rs) put (SymLit n l) = putWord8 1 >> put (n,l) put (SymVar n l) = putWord8 2 >> put (n,l) put (SymKS ts) = putWord8 3 >> put ts @@ -321,7 +321,7 @@ instance Binary Symbol where put SymALL_CAPIT = putWord8 10 get = do tag <- getWord8 case tag of - 0 -> liftM2 SymCat get get + 0 -> liftM3 SymCat get get get 1 -> liftM2 SymLit get get 2 -> liftM2 SymVar get get 3 -> liftM SymKS get diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index 5164e3443..a6c7d2cb5 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -74,7 +74,7 @@ import GF.Infra.Location import GF.Data.Operations import PGF2(BindType(..)) -import PGF2.Transactions(Symbol) +import PGF2.Transactions(Symbol,LIndex) import Data.Array.IArray(Array) import Data.Array.Unboxed(UArray) @@ -391,6 +391,7 @@ data Term = | Alts Term [(Term, Term)] -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@ | Strs [Term] -- ^ conditioning prefix strings: @strs {s ; ...}@ + | TSymCat Int LIndex [(LIndex,Ident)] deriving (Show, Eq, Ord) -- | Patterns diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index aee20cd2c..cfd2ce416 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -234,6 +234,7 @@ ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>' ppTerm q d (ImplArg e) = braces (ppTerm q 0 e) ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t) ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t) +ppTerm q d (TSymCat i r rs) = pp '<' <> pp i <> pp ',' <> ppLinFun pp r rs <> pp '>' ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e @@ -356,16 +357,31 @@ ppLit (PGF2.LStr s) = pp (show s) ppLit (PGF2.LInt n) = pp n ppLit (PGF2.LFlt d) = pp d -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 '>' -ppSymbol (PGF2.SymKS t) = doubleQuotes (pp t) -ppSymbol PGF2.SymNE = pp "nonExist" -ppSymbol PGF2.SymBIND = pp "BIND" -ppSymbol PGF2.SymSOFT_BIND = pp "SOFT_BIND" -ppSymbol PGF2.SymSOFT_SPACE= pp "SOFT_SPACE" -ppSymbol PGF2.SymCAPIT = pp "CAPIT" -ppSymbol PGF2.SymALL_CAPIT = pp "ALL_CAPIT" +ppSymbol (PGF2.SymCat d r rs)= pp '<' <> pp d <> pp ',' <> ppLinFun ppIntVar r rs <> 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 '>' +ppSymbol (PGF2.SymKS t) = doubleQuotes (pp t) +ppSymbol PGF2.SymNE = pp "nonExist" +ppSymbol PGF2.SymBIND = pp "BIND" +ppSymbol PGF2.SymSOFT_BIND = pp "SOFT_BIND" +ppSymbol PGF2.SymSOFT_SPACE = pp "SOFT_SPACE" +ppSymbol PGF2.SymCAPIT = pp "CAPIT" +ppSymbol PGF2.SymALL_CAPIT = pp "ALL_CAPIT" ppSymbol (PGF2.SymKP syms alts) = pp "pre" <+> braces (hsep (punctuate (pp ';') (hsep (map ppSymbol syms) : map ppAlt alts))) +ppLinFun ppParam r rs + | r == 0 && not (null rs) = hcat (intersperse (pp '+') ( map ppTerm rs)) + | otherwise = hcat (intersperse (pp '+') (pp r : map ppTerm rs)) + where + ppTerm (i,p) + | i == 1 = ppParam p + | otherwise = pp i <> pp '*' <> ppParam p + +ppIntVar p + | i == 0 = pp (chars !! j) + | otherwise = pp (chars !! j : show i) + where + chars = "ijklmnopqr" + (i,j) = p `divMod` (length chars) + ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> pp '/' <+> hsep (map (doubleQuotes . pp) ps) diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index b57a7af22..cda9883ad 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/src/runtime/haskell/PGF2/Transactions.hsc @@ -153,8 +153,9 @@ setAbstractFlag name value = Transaction $ \c_db c_revision c_exn -> type Token = String type LIndex = Int +type Param = Int data Symbol - = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex + = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex [(LIndex,Param)] | SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex | SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int | SymKS Token