diff options
Diffstat (limited to 'src/compiler/GF/Compile')
| -rw-r--r-- | src/compiler/GF/Compile/Abstract/TC.hs | 2 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Concrete/AppPredefined.hs | 11 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/GeneratePMCFG.hs | 660 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/GrammarToPGF.hs | 565 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/PGFtoProlog.hs | 5 |
5 files changed, 468 insertions, 775 deletions
diff --git a/src/compiler/GF/Compile/Abstract/TC.hs b/src/compiler/GF/Compile/Abstract/TC.hs index 8236bcf44..9c28d88e9 100644 --- a/src/compiler/GF/Compile/Abstract/TC.hs +++ b/src/compiler/GF/Compile/Abstract/TC.hs @@ -34,7 +34,7 @@ data AExp = AVr Ident Val | ACn QIdent Val | AType - | AInt Integer + | AInt Int | AFloat Double | AStr String | AMeta MetaId Val diff --git a/src/compiler/GF/Compile/Concrete/AppPredefined.hs b/src/compiler/GF/Compile/Concrete/AppPredefined.hs index 73355381e..30f555b60 100644 --- a/src/compiler/GF/Compile/Concrete/AppPredefined.hs +++ b/src/compiler/GF/Compile/Concrete/AppPredefined.hs @@ -73,17 +73,17 @@ appPredefined t = case t of -- one-place functions Q (mod,f) | mod == cPredef -> case x of - (K s) | f == cLength -> retb $ EInt $ toInteger $ length s + (K s) | f == cLength -> retb $ EInt $ length s _ -> retb t -- two-place functions App (Q (mod,f)) z0 | mod == cPredef -> do (z,_) <- appPredefined z0 case (norm z, norm x) of - (EInt i, K s) | f == cDrop -> retb $ K (drop (fi i) s) - (EInt i, K s) | f == cTake -> retb $ K (take (fi i) s) - (EInt i, K s) | f == cTk -> retb $ K (take (max 0 (length s - fi i)) s) - (EInt i, K s) | f == cDp -> retb $ K (drop (max 0 (length s - fi i)) s) + (EInt i, K s) | f == cDrop -> retb $ K (drop i s) + (EInt i, K s) | f == cTake -> retb $ K (take i s) + (EInt i, K s) | f == cTk -> retb $ K (take (max 0 (length s - i)) s) + (EInt i, K s) | f == cDp -> retb $ K (drop (max 0 (length s - i)) s) (K s, K t) | f == cEqStr -> retb $ if s == t then predefTrue else predefFalse (K s, K t) | f == cOccur -> retb $ if substring s t then predefTrue else predefFalse (K s, K t) | f == cOccurs -> retb $ if any (flip elem t) s then predefTrue else predefFalse @@ -119,7 +119,6 @@ appPredefined t = case t of (K x,K y) -> K (x +++ y) _ -> t _ -> t - fi = fromInteger -- read makes variables into constants diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index a735b7adc..b0f566cea 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-} ---------------------------------------------------------------------- -- | -- Maintainer : Krasimir Angelov @@ -13,11 +13,15 @@ module GF.Compile.GeneratePMCFG (convertConcrete) where import PGF.CId -import PGF.Data -import PGF.Macros +import PGF.Data hiding (Type) import GF.Infra.Option +import GF.Grammar hiding (Env, mkRecord, mkTable) +import qualified GF.Infra.Modules as M +import GF.Grammar.Lookup +import GF.Grammar.Predef import GF.Data.BacktrackM +import GF.Data.Operations import GF.Data.Utilities (updateNthM, updateNth, sortNub) import System.IO @@ -26,36 +30,52 @@ import qualified Data.Set as Set import qualified Data.List as List import qualified Data.IntMap as IntMap import qualified Data.ByteString.Char8 as BS +import Text.PrettyPrint hiding (Str) import Data.Array.IArray import Data.Maybe +import Data.Char (isDigit) import Control.Monad +import Control.Monad.Identity import Control.Exception ---------------------------------------------------------------------- -- main conversion function ---convertConcrete :: Options -> Abstr -> CId -> Concr -> IO Concr -convertConcrete opts lang flags printnames abs_defs cnc_defs lincats params lin_defs = do - let env0 = emptyGrammarEnv cat_defs params +convertConcrete :: Options -> SourceGrammar -> SourceModule -> SourceModule -> IO Concr +convertConcrete opts gr am cm = do + let env0 = emptyGrammarEnv gr cm when (flag optProf opts) $ do - profileGrammar lang env0 pfrules - env1 <- expandHOAS opts abs_defs cat_defs lin_defs env0 - env2 <- foldM (convertRule opts) env1 pfrules - return $ getParserInfo flags printnames env2 + profileGrammar cm env0 pfrules + env1 <- expandHOAS opts cm env0 + env2 <- foldM (convertRule gr opts) env1 pfrules + return $ getConcr flags printnames env2 where - cat_defs = Map.insert cidVar (S []) lincats + (m,mo) = cm pfrules = [ - (PFRule id args (0,res) (map findLinType args) (findLinType (0,res)) term) | - (id, (ty,_,_)) <- Map.toList abs_defs, let (args,res) = typeSkeleton ty, - term <- maybeToList (Map.lookup id cnc_defs)] - - findLinType (_,id) = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs) + (PFRule id args (0,res) (map (\(_,_,ty) -> ty) cont) val term) | + (id,GF.Grammar.CncFun (Just (cat,cont,val)) (Just (L _ term)) _) <- Map.toList (M.jments mo), + let (args,res) = err error typeSkeleton (lookupFunType gr (fst am) id)] + + flags = Map.fromList [(mkCId f,LStr x) | (f,x) <- optionsPGF (M.flags mo)] + + printnames = Map.fromAscList [(i2i id, name) | (id,info) <- Map.toList (M.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 -profileGrammar lang (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfrules = do +i2i :: Ident -> CId +i2i = CId . ident2bs + +profileGrammar (m,mo) env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfrules = do hPutStrLn stderr "" - hPutStrLn stderr ("Language: " ++ show lang) + hPutStrLn stderr ("Language: " ++ showIdent m) hPutStrLn stderr "" hPutStrLn stderr "Categories Count" hPutStrLn stderr "--------------------------------" @@ -69,22 +89,52 @@ profileGrammar lang (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfr mapM_ profileRule pfrules hPutStrLn stderr "--------------------------------" where - profileCat (cid,(fcat1,fcat2,_,_)) = do - hPutStrLn stderr (lformat 23 cid ++ rformat 9 (fcat2-fcat1+1)) + 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 = zipWith protoFCat args ctypes - hPutStrLn stderr (lformat 23 fun ++ rformat 9 (product [length xs | PFCat _ _ _ tcs <- pargs, (_,xs) <- tcs])) - - lformat :: Show a => Int -> a -> String - lformat n x = s ++ replicate (n-length s) ' ' + let pargs = map (protoFCat env) args + hPutStrLn stderr (lformat 23 (showIdent fun) ++ rformat 9 (show (product (map (catFactor env) args)))) where - s = show x + catFactor (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,(_,cat)) = + case IntMap.lookup n catSet >>= Map.lookup cat 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 -} + [(Int,Cat)] {- argument types: context size and category -} + (Int,Cat) {- result type : context size (always 0) and category -} + [Type] {- argument lin-types representation -} + Type {- result lin-type representation -} + Term {- body -} + +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 CNil ctype) (pargs,[]) + (grammarEnv1,b1) = addSequencesB grammarEnv b + grammarEnv2 = brk (\grammarEnv -> foldBM addRule + grammarEnv + (goB b1 CNil []) + (pres,pargs) ) grammarEnv1 + when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showIdent fun) + return $! grammarEnv2 + where + addRule lins (newCat', newArgs') env0 = + let [newCat] = getFCatsX env0 newCat' + (env1, newArgs) = List.mapAccumL (\env -> addFCoercion env . getFCats env) env0 newArgs' - rformat :: Show a => Int -> a -> String - rformat n x = replicate (n-length s) ' ' ++ s - where - s = show x + (env2,funid) = addCncFun env1 (PGF.Data.CncFun (i2i fun) (mkArray lins)) + + in addProduction env2 newCat (PApply funid newArgs) brk :: (GrammarEnv -> GrammarEnv) -> (GrammarEnv -> GrammarEnv) brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = @@ -103,141 +153,245 @@ brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = count = length xs ys = foldr (zipWith Set.insert) (repeat Set.empty) xs -convertRule :: Options -> GrammarEnv -> ProtoFRule -> IO GrammarEnv -convertRule opts grammarEnv (PFRule fun args res ctypes ctype term) = do - let pres = protoFCat res ctype - pargs = zipWith protoFCat args ctypes - - b = runBranchM (convertTerm [] ctype term) (pargs,[]) - (grammarEnv1,b1) = addSequences' grammarEnv b - grammarEnv2 = brk (\grammarEnv -> foldBM addRule - grammarEnv - (go' b1 [] []) - (pres,pargs) ) grammarEnv1 - when (verbAtLeast opts Verbose) $ hPutStrLn stderr ("+ "++showCId fun) - return $! grammarEnv2 +unfactor :: Term -> CnvMonad Term +unfactor t = CM (\gr c -> c (unfac gr t)) where - addRule lins (newCat', newArgs') env0 = - let [newCat] = getFCats env0 newCat' - (env1, newArgs) = List.mapAccumL (\env -> addFCoercion env . getFCats env) env0 newArgs' - - (env2,funid) = addCncFun env1 (CncFun fun (mkArray lins)) - - in addProduction env2 newCat (PApply funid newArgs) + unfac gr t = + case t of + T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac gr u) | v <- err error id (allParamValues gr ty)] + _ -> composSafeOp (unfac gr) t + where + restore x u t = case t of + Vr y | y == x -> u + _ -> composSafeOp (restore x u) t ---------------------------------------------------------------------- --- Branch monad - -newtype BranchM a = BM (forall b . (a -> ([ProtoFCat],[Symbol]) -> Branch b) -> ([ProtoFCat],[Symbol]) -> Branch b) - -instance Monad BranchM where - return a = BM (\c s -> c a s) - BM m >>= k = BM (\c s -> m (\a s -> unBM (k a) c s) s) - where unBM (BM m) = m - -instance MonadState ([ProtoFCat],[Symbol]) BranchM where - get = BM (\c s -> c s s) - put s = BM (\c _ -> c () s) +-- 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. -instance Functor BranchM where - fmap f (BM m) = BM (\c s -> m (c . f) s) +data Branch a + = Case Int Path [(Term,Branch a)] + | Variant [Branch a] + | Return a -runBranchM :: BranchM (Value a) -> ([ProtoFCat],[Symbol]) -> Branch a -runBranchM (BM m) s = m (\v s -> Return v) s +newtype CnvMonad a = CM {unCM :: SourceGrammar + -> forall b . (a -> ([ProtoFCat],[Symbol]) -> Branch b) + -> ([ProtoFCat],[Symbol]) + -> Branch b} -variants :: [a] -> BranchM a -variants xs = BM (\c s -> Variant [c x s | x <- xs]) +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) -choices :: Int -> FPath -> BranchM LIndex -choices nr path = BM (\c s -> let (args,_) = s - PFCat _ _ _ tcs = args !! nr - in case fromMaybe (error "evalTerm: wrong path") (lookup path tcs) of - [index] -> c index s - indices -> Case nr path [c i (updateEnv i s) | i <- indices]) - where - updateEnv index (args,seq) = (updateNth (restrictArg path index) nr args,seq) +instance MonadState ([ProtoFCat],[Symbol]) CnvMonad where + get = CM (\gr c s -> c s s) + put s = CM (\gr c _ -> c () s) - restrictArg path index (PFCat n cat rcs tcs) = PFCat n cat rcs (addConstraint path index tcs) +instance Functor CnvMonad where + fmap f (CM m) = CM (\gr c s -> m gr (c . f) s) - addConstraint path0 index0 [] = error "restrictProtoFCat: unknown path" - addConstraint path0 index0 (c@(path,indices) : tcs) - | path0 == path = ((path,[index0]) : tcs) - | otherwise = c : addConstraint path0 index0 tcs +runCnvMonad :: SourceGrammar -> CnvMonad a -> ([ProtoFCat],[Symbol]) -> Branch a +runCnvMonad gr (CM m) s = m gr (\v s -> Return v) s -mkRecord :: [BranchM (Value a)] -> BranchM (Value a) -mkRecord xs = BM (\c -> foldl (\c (BM m) bs s -> c (m (\v s -> Return v) s : bs) s) (c . Rec) xs []) +-- | 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]) + + updateEnv path value gr c (args,seq) = + case updateNthM (restrictProtoFCat path value) nr args of + Just args -> c value (args,seq) + Nothing -> error "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 error 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 conversion - -type CnvMonad a = BranchM a - -type FPath = [LIndex] -data ProtoFCat = PFCat Int CId [FPath] [(FPath,[LIndex])] +-- 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 + +-- | 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 Int Ident (Schema Identity Int (Int,[(Term,Int)])) type Env = (ProtoFCat, [ProtoFCat]) -data ProtoFRule = PFRule CId {- function -} - [(Int,CId)] {- argument types: context size and category -} - (Int,CId) {- result type : context size (always 0) and category -} - [Term] {- argument lin-types representation -} - Term {- result lin-type representation -} - Term {- body -} -type TermMap = Map.Map CId Term - - -protoFCat :: (Int,CId) -> Term -> ProtoFCat -protoFCat (n,cat) ctype = - let (rcs,tcs) = loop [] [] [] ctype' - in PFCat n cat rcs tcs - where - ctype' -- extend the high-order linearization type - | n > 0 = case ctype of - R xs -> R (xs ++ replicate n (S [])) - _ -> error $ "Not a record: " ++ show ctype - | otherwise = ctype - - loop path rcs tcs (R record) = List.foldr (\(index,term) (rcs,tcs) -> loop (index:path) rcs tcs term) (rcs,tcs) (zip [0..] record) - loop path rcs tcs (C i) = ( rcs,(path,[0..i]):tcs) - loop path rcs tcs (S _) = (path:rcs, tcs) -data Branch a - = Case Int FPath [Branch a] - | Variant [Branch a] - | Return (Value a) - -data Value a - = Rec [Branch a] - | Str a - | Con LIndex +protoFCat :: GrammarEnv -> (Int,Cat) -> ProtoFCat +protoFCat (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,(_,cat)) = + case IntMap.lookup n catSet >>= Map.lookup cat of + Just (_,_,pfcat) -> pfcat + Nothing -> error "unknown category" + +ppPath (CProj lbl path) = ppLabel lbl <+> ppPath path +ppPath (CSel trm path) = ppTerm Unqualified 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 -go' :: Branch SeqId -> FPath -> [SeqId] -> BacktrackM Env [SeqId] -go' (Case nr path_ bs) path ss = do (index,b) <- member (zip [0..] bs) - restrictArg nr path_ index - go' b path ss -go' (Variant bs) path ss = do b <- member bs - go' b path ss -go' (Return v) path ss = go v path ss -go :: Value SeqId -> FPath -> [SeqId] -> BacktrackM Env [SeqId] -go (Rec xs) path ss = foldM (\ss (lbl,b) -> go' b (lbl:path) ss) ss (reverse (zip [0..] xs)) -go (Str seqid) path ss = return (seqid : ss) -go (Con i) path ss = restrictHead path i >> return ss +---------------------------------------------------------------------- +-- term conversion -addSequences' :: GrammarEnv -> Branch [Symbol] -> (GrammarEnv, Branch SeqId) -addSequences' env (Case nr path bs) = let (env1,bs1) = List.mapAccumL addSequences' env bs +type Value a = Schema Branch a Term + +convertTerm :: Path -> Type -> Term -> CnvMonad (Value [Symbol]) +convertTerm sel ctype (Vr x) = convertArg ctype (getVarIndex x) (reversePath sel) +convertTerm sel ctype (Abs _ _ t) = convertTerm sel ctype t -- there are only top-level abstractions and we ignore them !!! +convertTerm sel ctype (R record) = convertRec sel ctype record +convertTerm sel ctype (P term l) = convertTerm (CProj l sel) ctype term +convertTerm sel ctype (V pt ts) = convertTbl sel ctype pt ts +convertTerm sel ctype (S term p) = do v <- evalTerm CNil p + convertTerm (CSel v sel) ctype term +convertTerm sel ctype (FV vars) = do term <- variants vars + convertTerm sel ctype term +convertTerm sel ctype (C t1 t2) = do v1 <- convertTerm sel ctype t1 + v2 <- convertTerm sel ctype t2 + return (CStr (concat [s | CStr s <- [v1,v2]])) +convertTerm sel ctype (K t) = return (CStr [SymKS [t]]) +convertTerm sel ctype Empty = return (CStr []) +convertTerm sel ctype (Alts s alts) + = return (CStr [SymKP (strings s) [Alt (strings u) (strings v) | (u,v) <- alts]]) + where + strings (K s) = [s] + strings (C u v) = strings u ++ strings v + strings (Strs ss) = concatMap strings ss +convertTerm CNil ctype t = do v <- evalTerm CNil t + return (CPar v) +convertTerm _ _ t = error (render (text "convertTerm" <+> parens (ppTerm Unqualified 0 t))) + +convertArg :: Term -> Int -> Path -> CnvMonad (Value [Symbol]) +convertArg (RecType rs) nr path = + mkRecord (map (\(lbl,ctype) -> (lbl,convertArg ctype nr (CProj lbl path))) rs) +convertArg (Table pt vt) nr path = do + vs <- getAllParamValues pt + mkTable pt (map (\v -> (v,convertArg vt nr (CSel v path))) vs) +convertArg (Sort _) nr path = do + (args,_) <- get + let PFCat _ cat schema = args !! nr + l = index (reversePath path) schema + sym | isLiteralCat 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 ty nr path = do + value <- choices nr (reversePath path) + return (CPar value) + +convertRec CNil (RecType rs) record = + mkRecord (map (\(lbl,ctype) -> (lbl,convertTerm CNil ctype (projectRec lbl record))) rs) +convertRec (CProj lbl path) ctype record = + convertTerm path ctype (projectRec lbl record) +convertRec _ ctype _ = error ("convertRec: "++show ctype) + +convertTbl CNil (Table _ vt) pt ts = do + vs <- getAllParamValues pt + mkTable pt (zipWith (\v t -> (v,convertTerm CNil vt t)) vs ts) +convertTbl (CSel v sub_sel) ctype pt ts = do + vs <- getAllParamValues pt + case lookup v (zip vs ts) of + Just t -> convertTerm sub_sel ctype t + Nothing -> error (render (text "convertTbl:" <+> (text "missing value" <+> ppTerm Unqualified 0 v $$ + text "among" <+> vcat (map (ppTerm Unqualified 0) vs)))) +convertTbl _ ctype _ _ = error ("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 + +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) -addSequences' env (Variant bs) = let (env1,bs1) = List.mapAccumL addSequences' env bs +addSequencesB env (Variant bs) = let (env1,bs1) = List.mapAccumL addSequencesB env bs in (env1,Variant bs1) -addSequences' env (Return v) = let (env1,v1) = addSequences env v +addSequencesB env (Return v) = let (env1,v1) = addSequencesV env v in (env1,Return v1) -addSequences :: GrammarEnv -> Value [Symbol] -> (GrammarEnv, Value SeqId) -addSequences env (Rec vs) = let (env1,vs1) = List.mapAccumL addSequences' env vs - in (env1,Rec vs1) -addSequences env (Str lin) = let (env1,seqid) = addFSeq env (optimizeLin lin) - in (env1,Str seqid) -addSequences env (Con i) = (env,Con i) +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) = addFSeq env (optimizeLin lin) + in (env1,CStr seqid) +addSequencesV env (CPar i) = (env,CPar i) optimizeLin [] = [] @@ -251,98 +405,76 @@ optimizeLin lin@(SymKS _ : _) = optimizeLin (sym : lin) = sym : optimizeLin lin -convertTerm :: FPath -> Term -> Term -> CnvMonad (Value [Symbol]) -convertTerm sel ctype (V nr) = convertArg ctype nr (reverse sel) -convertTerm sel ctype (C nr) = convertCon ctype nr (reverse sel) -convertTerm sel ctype (R record) = convertRec sel ctype record -convertTerm sel ctype (P term p) = do nr <- evalTerm [] p - convertTerm (nr:sel) ctype term -convertTerm sel ctype (FV vars) = do term <- variants vars - convertTerm sel ctype term -convertTerm sel ctype (S ts) = do vs <- mapM (convertTerm sel ctype) ts - return (Str (concat [s | Str s <- vs])) -convertTerm sel ctype (K (KS t)) = return (Str [SymKS [t]]) -convertTerm sel ctype (K (KP s v))=return (Str [SymKP s v]) -convertTerm sel ctype (W s t) = do - ss <- case t of - R ss -> return ss - convertRec sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss] -convertTerm sel ctype x = error ("convertTerm ("++show x++")") - -convertArg :: Term -> Int -> FPath -> CnvMonad (Value [Symbol]) -convertArg (R ctypes) nr path = do - mkRecord (zipWith (\lbl ctype -> convertArg ctype nr (lbl:path)) [0..] ctypes) -convertArg (C max) nr path = do - index <- choices nr path - return (Con index) -convertArg (S _) nr path = do - (args,_) <- get - let PFCat _ cat rcs tcs = args !! nr - l = index path rcs 0 - sym | isLiteralCat cat = SymLit nr l - | otherwise = SymCat nr l - return (Str [sym]) - where - index lbl' (lbl:lbls) idx - | lbl' == lbl = idx - | otherwise = index lbl' lbls $! (idx+1) - -convertCon (C max) index [] = return (Con index) -convertCon x _ _ = fail $ "SimpleToFCFG.convertCon: " ++ show x - -convertRec [] (R ctypes) record = do - mkRecord (zipWith (convertTerm []) ctypes record) -convertRec (index:sub_sel) ctype record = - convertTerm sub_sel ctype (record !! index) - - ------------------------------------------------------------ -- eval a term to ground terms -evalTerm :: FPath -> Term -> CnvMonad LIndex -evalTerm path (V nr) = choices nr (reverse path) -evalTerm path (C nr) = return nr -evalTerm path (R record) = case path of - (index:path) -> evalTerm path (record !! index) -evalTerm path (P term sel) = do index <- evalTerm [] sel - evalTerm (index:path) term +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 -> do rs <- mapM (\(lbl,(_,t)) -> do t <- evalTerm path t + return (assign lbl t)) rs + return (R rs) +evalTerm path (P term lbl) = evalTerm (CProj lbl path) term +evalTerm path (V pt ts) = case path of + (CSel trm path) -> do vs <- getAllParamValues pt + case lookup trm (zip vs ts) of + Just t -> evalTerm path t + Nothing -> error "evalTerm: missing value" + CNil -> do ts <- mapM (evalTerm path) ts + return (V pt ts) +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 x = error ("evalTerm ("++show x++")") +evalTerm path t = error (render (text "evalTerm" <+> parens (ppTerm Unqualified 0 t))) +getVarIndex (IA _ i) = i +getVarIndex (IAV _ _ i) = i +getVarIndex (IC s) | isDigit (BS.last s) = (read . BS.unpack . snd . BS.spanEnd isDigit) s ---------------------------------------------------------------------- -- GrammarEnv data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet CoerceSet (IntMap.IntMap (Set.Set Production)) -type CatSet = IntMap.IntMap (Map.Map CId (FId,FId,[Int],Array LIndex String)) +type CatSet = IntMap.IntMap (Map.Map Ident (FId,FId,ProtoFCat)) type SeqSet = Map.Map Sequence SeqId type FunSet = Map.Map CncFun FunId type CoerceSet= Map.Map [FId] FId -emptyGrammarEnv lincats params = +emptyGrammarEnv gr (m,mo) = let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats in GrammarEnv last_id (IntMap.singleton 0 catSet) Map.empty Map.empty Map.empty IntMap.empty where - computeCatRange index cat ctype - | cat == cidString = (index, (fcatString,fcatString,[],listArray (0,0) ["s"])) - | cat == cidInt = (index, (fcatInt, fcatInt, [],listArray (0,0) ["s"])) - | cat == cidFloat = (index, (fcatFloat, fcatFloat, [],listArray (0,0) ["s"])) - | cat == cidVar = (index, (fcatVar, fcatVar, [],listArray (0,0) ["s"])) - | otherwise = (index+size,(index,index+size-1, poly,maybe (error "missing params") (mkArray . getLabels []) (Map.lookup cat params))) + computeCatRange index cat ctype = + (index+size,(index,index+size-1,PFCat 0 cat schema)) where - (size,poly) = getMultipliers 1 [] ctype + ((_,size),schema) = compute (0,1) ctype - getMultipliers m ms (R record) = foldr (\t (m,ms) -> getMultipliers m ms t) (m,ms) record - getMultipliers m ms (S _) = (m,ms) - getMultipliers m ms (C max_index) = (m*(max_index+1),m : ms) - - getLabels ls (R record) = concat [getLabels (l:ls) t | P (K (KS l)) t <- record] - getLabels ls (S [FV ps,t]) = concat [getLabels (l:ls) t | K (KS l) <- ps] - getLabels ls (S []) = [unwords (reverse ls)] - getLabels ls (FV _) = [] - getLabels _ t = error (show t) - -expandHOAS opts abs_defs lincats lindefs env = + 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..])) + + lincats = + Map.insert cVar (Sort cStr) $ + Map.fromAscList + [(c, ty) | (c,GF.Grammar.CncCat (Just (L _ ty)) _ _) <- Map.toList (M.jments mo)] + + +expandHOAS opts (m,mo) env = return env {- foldM add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) (Map.keys lincats) where hoTypes :: [(Int,CId)] @@ -379,10 +511,10 @@ expandHOAS opts abs_defs lincats lindefs env = add_varFun env cat = case Map.lookup cat lindefs of Nothing -> return env - Just lindef -> convertRule opts env (PFRule _V [(0,cidVar)] (0,cat) [arg] res lindef) + Just lindef -> convertRule opts env (PFRule _V [(0,cVar)] (0,cat) [arg] res lindef) where arg = - case Map.lookup cidVar lincats of + case Map.lookup cVar lincats of Nothing -> error $ "No lincat for " ++ showCId cat Just ctype -> ctype @@ -390,7 +522,7 @@ expandHOAS opts abs_defs lincats lindefs env = case Map.lookup cat lincats of Nothing -> error $ "No lincat for " ++ showCId cat Just ctype -> ctype - +-} addProduction :: GrammarEnv -> FId -> Production -> GrammarEnv addProduction (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) cat p = GrammarEnv last_id catSet seqSet funSet crcSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet) @@ -420,57 +552,87 @@ addFCoercion env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) sub_fc Nothing -> let !fcat = last_id+1 in (GrammarEnv fcat catSet seqSet funSet (Map.insert sub_fcats fcat crcSet) prodSet,fcat) -getParserInfo :: Map.Map CId Literal -> Map.Map CId String -> GrammarEnv -> Concr -getParserInfo flags printnames (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = +getConcr :: Map.Map CId Literal -> Map.Map CId String -> GrammarEnv -> Concr +getConcr flags printnames (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = Concr { cflags = flags , printnames = printnames - , cncfuns = mkArray funSet - , sequences = mkArray seqSet + , cncfuns = mkSetArray funSet + , sequences = mkSetArray seqSet , productions = IntMap.union prodSet coercions , pproductions = IntMap.empty , lproductions = Map.empty - , cnccats = maybe Map.empty (Map.map (\(start,end,_,lbls) -> (CncCat start end lbls))) (IntMap.lookup 0 catSet) + , cnccats = Map.fromList [(i2i cat,PGF.Data.CncCat start end (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) (getStrPaths schema)))) + | (cat,(start,end,PFCat _ _ schema)) <- maybe [] Map.toList (IntMap.lookup 0 catSet)] , totalCats = last_id+1 } where - mkArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] + 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 [] + 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 + + getFCats :: GrammarEnv -> ProtoFCat -> [FId] -getFCats (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat rcs tcs) = +getFCats (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat schema) = case IntMap.lookup n catSet >>= Map.lookup cat of - Just (start,end,ms,_) -> reverse (solutions (variants ms tcs start) ()) + Just (start,end,_) -> reverse (solutions (fmap (start +) $ variants schema) ()) where - variants _ [] fcat = return fcat - variants (m:ms) ((_,indices) : tcs) fcat = do index <- member indices - variants ms tcs ((m*index) + fcat) - + 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) + +getFCatsX :: GrammarEnv -> ProtoFCat -> [FId] +getFCatsX (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat schema) = + case IntMap.lookup n catSet >>= Map.lookup cat 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) ------------------------------------------------------------ -- updating the MCF rule -restrictArg :: LIndex -> FPath -> LIndex -> BacktrackM Env () +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 :: FPath -> LIndex -> BacktrackM Env () -restrictHead path term - = do (head, args) <- get - head' <- restrictProtoFCat path term head - put (head', args) - -restrictProtoFCat :: FPath -> LIndex -> ProtoFCat -> BacktrackM Env ProtoFCat -restrictProtoFCat path0 index0 (PFCat n cat rcs tcs) = do - tcs <- addConstraint tcs - return (PFCat n cat rcs tcs) + 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 n cat schema) = do + schema <- addConstraint path v schema + return (PFCat n cat schema) where - addConstraint [] = error "restrictProtoFCat: unknown path" - addConstraint (c@(path,indices) : tcs) - | path0 == path = guard (index0 `elem` indices) >> - return ((path,[index0]) : tcs) - | otherwise = liftM (c:) (addConstraint tcs) + 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 _) = error "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 diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index d1121e827..193a3defc 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -6,7 +6,6 @@ import GF.Compile.GeneratePMCFG import PGF.CId import PGF.Optimize(updateProductionIndices) -import PGF.Check(checkLin) import qualified PGF.Macros as CM import qualified PGF.Data as C import qualified PGF.Data as D @@ -38,76 +37,39 @@ traceD s t = t -- the main function: generate PGF from GF. -mkCanon2pgf :: Options -> String -> SourceGrammar -> IO D.PGF -mkCanon2pgf opts cnc gr = (canon2pgf opts pars . reorder abs . canon2canon opts abs) gr +mkCanon2pgf :: Options -> Ident -> SourceGrammar -> IO D.PGF +mkCanon2pgf opts cnc gr = (canon2pgf opts gr . reorder abs) gr where - abs = err (const c) id $ M.abstractOfConcrete gr c where c = identC (BS.pack cnc) - pars = mkParamLincat gr + abs = err (const cnc) id $ M.abstractOfConcrete gr cnc --- Generate PGF from GFCM. --- this assumes a grammar translated by canon2canon +-- Generate PGF from grammar. -canon2pgf :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> IO D.PGF -canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do +canon2pgf :: Options -> SourceGrammar -> SourceGrammar -> IO D.PGF +canon2pgf opts gr cgr@(M.MGrammar (am:cms)) = do if dump opts DumpCanon then putStrLn (render (vcat (map (ppModule Qualified) (M.modules cgr)))) else return () - cncs <- sequence [mkConcr lang (i2i lang) mo | (lang,mo) <- cms] - return $ updateProductionIndices (D.PGF gflags an abs (Map.fromList cncs)) - where - -- abstract - an = (i2i a) - abs = D.Abstr aflags funs cats - gflags = Map.empty - aflags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (M.flags abm)] - - mkDef (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] - mkDef Nothing = Nothing - - mkArrity (Just a) = a - mkArrity Nothing = 0 - - -- concretes - lfuns = [(f', (mkType [] ty, mkArrity ma, mkDef pty)) | - (f,AbsFun (Just (L _ ty)) ma pty) <- tree2list (M.jments abm), let f' = i2i f] - funs = Map.fromAscList lfuns - lcats = [(i2i c, (snd (mkContext [] cont),catfuns c)) | - (c,AbsCat (Just (L _ cont))) <- tree2list (M.jments abm)] - cats = Map.fromAscList lcats - catfuns cat = - (map snd . sortBy (compare `on` fst)) - [(loc,i2i f) | (f,AbsFun (Just (L loc ty)) _ _) <- tree2list (M.jments abm), snd (GM.valCat ty) == cat] - - mkConcr lang0 lang mo = do - lins' <- case mapM (checkLin (funs,lins,lincats) lang) (Map.toList lins) of - Ok x -> return x - Bad msg -> fail msg - cnc <- convertConcrete opts lang flags printnames funs (Map.fromList (map fst lins')) lincats params lindefs - return (lang, cnc) - where - js = tree2list (M.jments mo) - flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (M.flags mo)] - utf = id -- trace (show lang0 +++ show flags) $ - -- if moduleFlag optEncoding (moduleOptions (M.flags mo)) == UTF_8 - -- then id else id - ---- then (trace "decode" D.convertStringsInTerm decodeUTF8) else id - umkTerm = utf . mkTerm - lins = Map.fromAscList - [(f', umkTerm tr) | (f,CncFun _ (Just (L _ tr)) _) <- js, - let f' = i2i f, exists f'] -- eliminating lins without fun - -- needed even here because of restricted inheritance - lincats = Map.fromAscList - [(i2i c, mkCType ty) | (c,CncCat (Just (L _ ty)) _ _) <- js] - lindefs = Map.fromAscList - [(i2i c, umkTerm tr) | (c,CncCat _ (Just (L _ tr)) _) <- js] - printnames = Map.union - (Map.fromAscList [(i2i f, realize (umkTerm tr)) | (f,CncFun _ _ (Just (L _ tr))) <- js]) - (Map.fromAscList [(i2i f, realize (umkTerm tr)) | (f,CncCat _ _ (Just (L _ tr))) <- js]) - params = Map.fromAscList - [(i2i c, pars lang0 c) | (c,CncCat (Just ty) _ _) <- js] - fcfg = Nothing - - exists f = Map.member f funs + (an,abs) <- mkAbstr am + cncs <- mapM (mkConcr am) cms + return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs)) + where + mkAbstr (a,abm) = return (i2i a, D.Abstr flags funs cats) + where + flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (M.flags abm)] + + funs = Map.fromAscList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty)) | + (f,AbsFun (Just (L _ ty)) ma pty) <- Map.toAscList (M.jments abm)] + + cats = Map.fromAscList [(i2i c, (snd (mkContext [] cont),catfuns c)) | + (c,AbsCat (Just (L _ cont))) <- Map.toAscList (M.jments abm)] + + catfuns cat = + (map snd . sortBy (compare `on` fst)) + [(loc,i2i f) | (f,AbsFun (Just (L loc ty)) _ _) <- tree2list (M.jments abm), snd (GM.valCat ty) == cat] + + mkConcr am cm@(lang,mo) = do + cnc <- convertConcrete opts gr am cm + return (i2i lang, cnc) i2i :: Ident -> CId i2i = CId . ident2bs @@ -153,465 +115,40 @@ mkPatt scope p = in (scope',C.PImplArg p') A.PTilde t -> ( scope,C.PTilde (mkExp scope t)) - 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 -mkTerm :: Term -> C.Term -mkTerm tr = case tr of - Vr (IA _ i) -> C.V i - Vr (IAV _ _ i) -> C.V i - Vr (IC s) | isDigit (BS.last s) -> - C.V ((read . BS.unpack . snd . BS.spanEnd isDigit) s) - ---- from gf parser of gfc - EInt i -> C.C $ fromInteger i - R rs -> C.R [mkTerm t | (_, (_,t)) <- rs] - P t l -> C.P (mkTerm t) (C.C (mkLab l)) - T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------ - V _ cs -> C.R [mkTerm t | t <- cs] - S t p -> C.P (mkTerm t) (mkTerm p) - C s t -> C.S $ concatMap flats [mkTerm x | x <- [s,t]] - FV ts -> C.FV [mkTerm t | t <- ts] - K s -> C.K (C.KS s) ------ K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants - Empty -> C.S [] - App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging - Abs _ _ t -> mkTerm t ---- only on toplevel - Alts td tvs -> - C.K (C.KP (strings td) [C.Alt (strings u) (strings v) | (u,v) <- tvs]) - _ -> prtTrace tr $ C.S [C.K (C.KS (render (A.ppTerm Unqualified 0 tr <+> int 66662)))] ---- for debugging - where - mkLab (LIdent l) = case BS.unpack l of - '_':ds -> (read ds) :: Int - _ -> prtTrace tr $ 66663 - strings t = case t of - K s -> [s] - C u v -> strings u ++ strings v - Strs ss -> concatMap strings ss - _ -> prtTrace tr $ ["66660"] - flats t = case t of - C.S ts -> concatMap flats ts - _ -> [t] +mkDef (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] +mkDef Nothing = Nothing --- encoding PGF-internal lincats as terms -mkCType :: Type -> C.Term -mkCType t = case t of - EInt i -> C.C $ fromInteger i - RecType rs -> C.R [mkCType t | (_, t) <- rs] - Table pt vt -> case pt of - EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt - RecType rs -> mkCType $ foldr Table vt (map snd rs) - _ | Just i <- GM.isTypeInts pt -> C.R $ replicate (fromInteger i) $ mkCType vt - - Sort s | s == cStr -> C.S [] --- Str only - _ | Just i <- GM.isTypeInts t -> C.C $ fromInteger i - _ -> error $ "mkCType " ++ show t - --- encoding showable lincats (as in source gf) as terms -mkParamLincat :: SourceGrammar -> Ident -> Ident -> C.Term -mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do - typ <- Look.lookupLincat sgr lang cat - mkPType typ - where - mkPType typ = case typ of - RecType lts -> do - ts <- mapM (mkPType . snd) lts - return $ C.R [ C.P (kks $ showIdent (label2ident l)) t | ((l,_),t) <- zip lts ts] - Table (RecType lts) v -> do - ps <- mapM (mkPType . snd) lts - v' <- mkPType v - return $ foldr (\p v -> C.S [p,v]) v' ps - Table p v -> do - p' <- mkPType p - v' <- mkPType v - return $ C.S [p',v'] - Sort s | s == cStr -> return $ C.S [] - _ -> return $ - C.FV $ map (kks . renderStyle style{mode=OneLineMode} . ppTerm Unqualified 6) $ - errVal [] $ Look.allParamValues sgr typ - kks = C.K . C.KS +mkArrity (Just a) = a +mkArrity Nothing = 0 -- return just one module per language reorder :: Ident -> SourceGrammar -> SourceGrammar -reorder abs cg = M.MGrammar $ - (abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs): - [(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] [] (sorted2tree js)) - | (c,(fs,js)) <- cncs] - where - mos = M.modules cg - adefs = sorted2tree $ sortIds $ - predefADefs ++ Look.allOrigInfos cg abs - predefADefs = - [(c, AbsCat (Just (L (0,0) []))) | c <- [cFloat,cInt,cString]] - aflags = - concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo] - - cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs] - concr la = (flags, - sortIds (predefCDefs ++ jments)) where - jments = Look.allOrigInfos cg la - flags = concatOptions - [M.flags mo | - (i,mo) <- mos, M.isModCnc mo, - Just r <- [lookup i (M.allExtendSpecs cg la)]] - - predefCDefs = - [(c, CncCat (Just (L (0,0) GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]] - - sortIds = sortBy (\ (f,_) (g,_) -> compare f g) - - --- one grammar per language - needed for symtab generation -repartition :: Ident -> SourceGrammar -> [SourceGrammar] -repartition abs cg = - [M.partOfGrammar cg (lang,mo) | - let mos = M.modules cg, - lang <- case M.allConcretes cg abs of - [] -> [abs] -- to make pgf nonempty even when there are no concretes - cncs -> cncs, - let mo = errVal - (error (render (text "no module found for" <+> A.ppIdent lang))) $ M.lookupModule cg lang - ] - --- translate tables and records to arrays, parameters and labels to indices - -canon2canon :: Options -> Ident -> SourceGrammar -> SourceGrammar -canon2canon opts abs cg0 = - (recollect . map cl2cl . repartition abs . purgeGrammar abs) cg0 - where - recollect = M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules - cl2cl = M.MGrammar . js2js . map (c2c p2p) . M.modules - - js2js ms = map (c2c (j2j (M.MGrammar ms))) ms - - c2c f2 (c,mo) = (c, M.replaceJudgements mo $ mapTree f2 (M.jments mo)) - - j2j cg (f,j) = - let debug = if verbAtLeast opts Verbose then trace ("+ " ++ showIdent f) else id in - case j of - CncFun x (Just (L loc tr)) z -> CncFun x (Just (L loc (debug (t2t (unfactor cg0 tr))))) z - CncCat (Just (L locty ty)) (Just (L locx x)) y -> CncCat (Just (L locty (ty2ty ty))) (Just (L locx (t2t (unfactor cg0 x)))) y - _ -> j - where - cg1 = cg - t2t = term2term f cg1 pv - ty2ty = type2type cg1 pv - pv@(labels,untyps,typs) = trs $ paramValues cg1 - - unfactor :: SourceGrammar -> Term -> Term - unfactor gr t = case t of - T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac u) | v <- vals ty] - _ -> GM.composSafeOp unfac t - where - unfac = unfactor gr - vals = err error id . Look.allParamValues gr - restore x u t = case t of - Vr y | y == x -> u - _ -> GM.composSafeOp (restore x u) t - - -- flatten record arguments of param constructors - p2p (f,j) = case j of - ResParam (Just ps) (Just vs) -> - ResParam (Just [L loc (c,concatMap unRec cont) | L loc (c,cont) <- ps]) (Just (map unrec vs)) - _ -> j - unRec (bt,x,ty) = case ty of - RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (Explicit,identW,typ)] - _ -> [(bt,x,ty)] - unrec t = case t of - App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs] - _ -> GM.composSafeOp unrec t - - ----- - trs v = traceD (render (tr v)) v - - tr (labels,untyps,typs) = - (text "LABELS:" <+> - vcat [A.ppIdent c <> char '.' <> hsep (map A.ppLabel l) <+> char '=' <+> text (show i) | ((c,l),i) <- Map.toList labels]) $$ - (text "UNTYPS:" <+> - vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show i) | (t,i) <- Map.toList untyps]) $$ - (text "TYPS: " <+> - vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show (Map.assocs i)) | (t,i) <- Map.toList typs]) ----- - -purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar -purgeGrammar abstr gr = - (M.MGrammar . list . filter complete . purge . M.modules) gr - where - list ms = traceD (render (text "MODULES" <+> hsep (punctuate comma (map (ppIdent . fst) ms)))) ms - purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst) - needed = nub $ concatMap (requiredCanModules isSingle gr) acncs - acncs = abstr : M.allConcretes gr abstr - isSingle = True - complete (i,m) = M.isCompleteModule m --- not . isIncompleteCanon - -type ParamEnv = - (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels - Map.Map Term Integer, -- untyped terms to values - Map.Map Type (Map.Map Term Integer)) -- types to their terms to values - ---- gathers those param types that are actually used in lincats and lin terms -paramValues :: SourceGrammar -> ParamEnv -paramValues cgr = (labels,untyps,typs) where - partyps = nub $ - --- [App (Q (IC "Predef") (IC "Ints")) (EInt i) | i <- [1,9]] ---linTypeInt - [ty | - (_,(_,CncCat (Just (L _ ty0)) _ _)) <- jments, - ty <- typsFrom ty0 - ] ++ [ - Q (m,ty) | - (m,(ty,ResParam _ _)) <- jments - ] ++ [ty | - (_,(_,CncFun _ (Just (L _ tr)) _)) <- jments, - ty <- err (const []) snd $ appSTM (typsFromTrm tr) [] - ] - params = [(ty, errVal (traceD ("UNKNOWN PARAM TYPE" +++ show ty) []) $ - Look.allParamValues cgr ty) | ty <- partyps] - typsFrom ty = (if isParam ty then (ty:) else id) $ case ty of - Table p t -> typsFrom p ++ typsFrom t - RecType ls -> concat [typsFrom t | (_, t) <- ls] - _ -> [] - - isParam ty = case ty of - Q _ -> True - QC _ -> True - RecType rs -> all isParam (map snd rs) - _ -> False +reorder abs cg = + M.MGrammar $ + (abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs): + [(cnc, M.ModInfo (M.MTConcrete abs) M.MSComplete cflags [] Nothing [] [] cdefs) + | cnc <- M.allConcretes cg abs, let (cflags,cdefs) = concr cnc] + where + aflags = + concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo] - typsFromTrm :: Term -> STM [Type] Term - typsFromTrm tr = case tr of - R fs -> mapM_ (typsFromField . snd) fs >> return tr + adefs = + Map.fromList (predefADefs ++ Look.allOrigInfos cg abs) where - typsFromField (mty, t) = case mty of - Just x -> updateSTM (x:) >> typsFromTrm t - _ -> typsFromTrm t - V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr - T (TTyped ty) cs -> - updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr - T (TComp ty) cs -> - updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr - _ -> GM.composOp typsFromTrm tr - - mods = traceD (render (hsep (map (ppIdent . fst) ms))) ms where ms = M.modules cgr - - jments = - [(m,j) | (m,mo) <- mods, j <- tree2list $ M.jments mo] - typs = - Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params] - untyps = - Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs] - lincats = - [(cat,[f | let RecType fs = GM.defLinType, f <- fs]) | cat <- [cInt,cFloat, cString]] ++ - reverse ---- TODO: really those lincats that are reached - ---- reverse is enough to expel overshadowed ones... - [(cat,ls) | (_,(cat,CncCat (Just (L _ ty)) _ _)) <- jments, - RecType ls <- [unlockTy ty]] - labels = Map.fromList $ concat - [((cat,[lab]),(typ,i)): - [((cat,[LVar v]),(typ,toInteger (mx + v))) | v <- [0,1]] ++ ---- 1 or 2 vars - [((cat,[lab,lab2]),(ty,j)) | - rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]] - ++ - ---- one more level, but: ... - [((cat,[lab,lab2,lab3]),(ty,j)) | - rss <- getRec typ, ((lab2, ty0),j0) <- zip rss [0..], - (_,ty2) <- rss, - rs <- getRec ty2, ((lab3, ty),j) <- zip rs [0..]] - | - (cat,ls) <- lincats, ((lab, typ),i) <- zip ls [0..], let mx = length ls] - -- go to tables recursively - ---- ... TODO: go to deeper records - where - getRec typ = case typ of - RecType rs -> [rs] ---- [unlockTyp rs] -- (sort (unlockTyp ls)) - Table _ t -> getRec t - _ -> [] - -type2type :: SourceGrammar -> ParamEnv -> Type -> Type -type2type cgr env@(labels,untyps,typs) ty = case ty of - RecType rs -> - RecType [(mkLab i, t2t t) | (i,(l, t)) <- zip [0..] (unlockTyp rs)] - Table pt vt -> Table (t2t pt) (t2t vt) - QC _ -> look ty - _ -> ty - where - t2t = type2type cgr env - look ty = EInt $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of - Just vs -> length $ Map.assocs vs - _ -> trace ("unknown partype " ++ show ty) 66669 - -term2term :: Ident -> SourceGrammar -> ParamEnv -> Term -> Term -term2term fun cgr env@(labels,untyps,typs) tr = case tr of - App _ _ -> mkValCase (unrec tr) - QC _ -> mkValCase tr - R rs -> R [(mkLab i, (Nothing, t2t t)) | - (i,(l,(_,t))) <- zip [0..] (GM.sortRec (unlock rs))] - P t l -> r2r tr - - T (TWild _) _ -> error $ (render (text "wild" <+> ppTerm Qualified 0 tr)) - T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc - T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc - V ty ts -> mkCurry $ V ty [t2t t | t <- ts] - S t p -> mkCurrySel (t2t t) (t2t p) - - _ -> GM.composSafeOp t2t tr - where - t2t = term2term fun cgr env - - unrec t = case t of - App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs] - _ -> GM.composSafeOp unrec t - - mkValCase tr = case appSTM (doVar tr) [] of - Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st - _ -> valNum $ comp tr - - --- this is mainly needed for parameter record projections - ---- was: - comp t = errVal t $ Compute.computeConcreteRec cgr t - - doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term - doVar tr = case getLab tr of - Ok (cat, lab) -> do - k <- readSTM >>= return . length - let tr' = Vr $ identC $ (BS.pack (show k)) ----- - - let tyvs = case Map.lookup (cat,lab) labels of - Just (ty,_) -> case Map.lookup ty typs of - Just vs -> (ty,[t | - (t,_) <- sortBy (\x y -> compare (snd x) (snd y)) - (Map.assocs vs)]) - _ -> error $ render (text "doVar1" <+> A.ppTerm Unqualified 0 ty) - _ -> error $ render (text "doVar2" <+> A.ppTerm Unqualified 0 tr <+> text (show (cat,lab))) ---- debug - updateSTM ((tyvs, (tr', tr)):) - return tr' - _ -> GM.composOp doVar tr - - r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v - - r2r tr@(P p _) = case getLab tr of - Ok (cat,labs) -> P (t2t p) . mkLab $ - maybe (prtTrace tr $ 66664) snd $ - Map.lookup (cat,labs) labels - _ -> K (render (A.ppTerm Unqualified 0 tr <+> prtTrace tr (int 66665))) - - -- this goes recursively into tables (ignored) and records (accumulated) - getLab tr = case tr of - Vr (IA cat _) -> return (identC cat,[]) - Vr (IAV cat _ _) -> return (identC cat,[]) - Vr (IC s) -> return (identC cat,[]) where - cat = BS.takeWhile (/='_') s ---- also to match IAVs; no _ in a cat tolerated - ---- init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser ----- Vr _ -> error $ "getLab " ++ show tr - P p lab2 -> do - (cat,labs) <- getLab p - return (cat,labs++[lab2]) - S p _ -> getLab p - _ -> Bad "getLab" - - - mkCase ((ty,vs),(x,p)) tr = - S (V ty [mkBranch x v tr | v <- vs]) p - mkBranch x t tr = case tr of - _ | tr == x -> t - _ -> GM.composSafeOp (mkBranch x t) tr - - valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps - where - tryFV tr = case GM.appForm tr of - (c@(QC _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryFV ts)] - (FV ts,_) -> ts - _ -> [tr] - valNumFV ts = case ts of - [tr] -> let msg = render (text "DEBUG" <+> ppIdent fun <> text ": error in valNum" <+> ppTerm Qualified 0 tr) in - trace msg $ error (showIdent fun) - _ -> FV $ map valNum ts - - mkCurry trm = case trm of - V (RecType [(_,ty)]) ts -> V ty ts - V (RecType ((_,ty):ltys)) ts -> - V ty [mkCurry (V (RecType ltys) cs) | - cs <- chop (product (map (lengthtyp . snd) ltys)) ts] - _ -> trm - lengthtyp ty = case Map.lookup ty typs of - Just m -> length (Map.assocs m) - _ -> error $ "length of type " ++ show ty - chop i xs = case splitAt i xs of - (xs1,[]) -> [xs1] - (xs1,xs2) -> xs1:chop i xs2 - - - mkCurrySel t p = S t p -- done properly in CheckGFCC - - -mkLab k = LIdent (BS.pack ("_" ++ show k)) - --- remove lock fields; in fact, any empty records and record types -unlock = filter notlock where - notlock (l,(_, t)) = case t of --- need not look at l - R [] -> False - RecType [] -> False - _ -> True - -unlockTyp = filter notlock - -notlock (l, t) = case t of --- need not look at l - RecType [] -> False - _ -> True - -unlockTy ty = case ty of - RecType ls -> RecType $ GM.sortRec [(l, unlockTy t) | (l,t) <- ls, notlock (l,t)] - _ -> GM.composSafeOp unlockTy ty - - -prtTrace tr n = - trace (render (text "-- INTERNAL COMPILER ERROR" <+> A.ppTerm Unqualified 0 tr $$ text (show n))) n -prTrace tr n = trace (render (text "-- OBSERVE" <+> A.ppTerm Unqualified 0 tr <+> text (show n) <+> text (show tr))) n - - --- | this function finds out what modules are really needed in the canonical gr. --- its argument is typically a concrete module name -requiredCanModules :: Bool -> M.MGrammar a -> Ident -> [Ident] -requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where - exts = M.allExtends gr c - ops = if isSingle - then map fst (M.modules gr) - else iterFix (concatMap more) $ exts - more i = errVal [] $ do - m <- M.lookupModule gr i - return $ M.extends m ++ [o | o <- map M.openedModule (M.opens m)] - notReuse i = errVal True $ do - m <- M.lookupModule gr i - return $ M.isModRes m -- to exclude reused Cnc and Abs from required - - -realize :: C.Term -> String -realize = concat . take 1 . realizes - -realizes :: C.Term -> [String] -realizes = map (unwords . untokn) . realizest - -realizest :: C.Term -> [[C.Tokn]] -realizest trm = case trm of - C.R ts -> realizest (ts !! 0) - C.S ss -> map concat $ combinations $ map realizest ss - C.K t -> [[t]] - C.W s t -> [[C.KS (s ++ r)] | [C.KS r] <- realizest t] - C.FV ts -> concatMap realizest ts - C.TM s -> [[C.KS s]] - _ -> [[C.KS $ "REALIZE_ERROR " ++ show trm]] ---- debug - -untokn :: [C.Tokn] -> [String] -untokn ts = case ts of - C.KP d _ : [] -> d - C.KP d vs : ws -> let ss@(s:_) = untokn ws in sel d vs s ++ ss - C.KS s : ws -> s : untokn ws - [] -> [] - where - sel d vs w = case [v | C.Alt v cs <- vs, any (\c -> isPrefixOf c w) cs] of - v:_ -> v - _ -> d + predefADefs = + [(c, AbsCat (Just (L (0,0) []))) | c <- [cFloat,cInt,cString]] + + concr la = (flags, Map.fromList (predefCDefs ++ jments)) + where + flags = concatOptions [M.flags mo | (i,mo) <- M.modules cg, M.isModCnc mo, + Just r <- [lookup i (M.allExtendSpecs cg la)]] + jments = Look.allOrigInfos cg la + predefCDefs = + [(c, CncCat (Just (L (0,0) GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]] diff --git a/src/compiler/GF/Compile/PGFtoProlog.hs b/src/compiler/GF/Compile/PGFtoProlog.hs index 8c5dee166..d5839916b 100644 --- a/src/compiler/GF/Compile/PGFtoProlog.hs +++ b/src/compiler/GF/Compile/PGFtoProlog.hs @@ -127,11 +127,6 @@ instance PLPrint Literal where plp (LInt n) = plp (show n) plp (LFlt f) = plp (show f) -instance PLPrint Tokn where - plp (KS tokn) = plp tokn - plp (KP strs alts) = plTerm "kp" [plp strs, plList [plOper "/" (plp ss1) (plp ss2) | - Alt ss1 ss2 <- alts]] - ---------------------------------------------------------------------- -- basic prolog-printing |