From 992a7ffb381190ffa67f59f33d0dfadf41f84e78 Mon Sep 17 00:00:00 2001 From: krasimir Date: Fri, 18 Jun 2010 12:55:58 +0000 Subject: [PATCH] Yay!! Direct generation of PMCFG from GF grammar --- src/compiler/GF/Command/Importing.hs | 5 +- src/compiler/GF/Compile.hs | 17 +- src/compiler/GF/Compile/Abstract/TC.hs | 2 +- .../GF/Compile/Concrete/AppPredefined.hs | 11 +- src/compiler/GF/Compile/GeneratePMCFG.hs | 640 +++++++++++------- src/compiler/GF/Compile/GrammarToPGF.hs | 559 ++------------- src/compiler/GF/Compile/PGFtoProlog.hs | 5 - src/compiler/GF/Grammar/Grammar.hs | 4 +- src/compiler/GF/Grammar/Lexer.x | 2 +- src/compiler/GF/Grammar/Macros.hs | 12 +- src/compiler/GF/Grammar/Predef.hs | 6 +- src/compiler/GF/Grammar/Printer.hs | 4 +- src/compiler/GFC.hs | 6 +- src/runtime/haskell/PGF/Check.hs | 173 ----- src/runtime/haskell/PGF/Data.hs | 16 - src/runtime/haskell/PGF/Macros.hs | 9 - src/runtime/haskell/PGF/VisualizeTree.hs | 25 +- 17 files changed, 500 insertions(+), 996 deletions(-) delete mode 100644 src/runtime/haskell/PGF/Check.hs diff --git a/src/compiler/GF/Command/Importing.hs b/src/compiler/GF/Command/Importing.hs index 06deab6c6..194c993ba 100644 --- a/src/compiler/GF/Command/Importing.hs +++ b/src/compiler/GF/Command/Importing.hs @@ -4,13 +4,14 @@ import PGF import PGF.Data import GF.Compile -import GF.Grammar.Grammar (SourceGrammar) -- for cc command +import GF.Grammar (identC, SourceGrammar) -- for cc command import GF.Grammar.CF import GF.Infra.UseIO import GF.Infra.Option import GF.Data.ErrM import Data.List (nubBy) +import qualified Data.ByteString.Char8 as BS import System.FilePath -- import a grammar in an environment where it extends an existing grammar @@ -25,7 +26,7 @@ importGrammar pgf0 opts files = Ok g -> return g Bad s -> error s ---- Ok gr <- appIOE $ compileSourceGrammar opts gf - epgf <- appIOE $ link opts (cnc ++ "Abs") gr + epgf <- appIOE $ link opts (identC (BS.pack (cnc ++ "Abs"))) gr case epgf of Ok pgf -> return pgf Bad s -> error s ---- diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index bf872c138..ecb533c3f 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -35,9 +35,9 @@ import qualified Data.Set as Set import Data.List(nub) import Data.Maybe (isNothing) import Data.Binary +import qualified Data.ByteString.Char8 as BS import Text.PrettyPrint -import PGF.Check import PGF.CId import PGF.Data import PGF.Macros @@ -49,20 +49,15 @@ compileToPGF :: Options -> [FilePath] -> IOE PGF compileToPGF opts fs = do gr <- batchCompile opts fs let name = justModuleName (last fs) - link opts name gr + link opts (identC (BS.pack name)) gr -link :: Options -> String -> SourceGrammar -> IOE PGF +link :: Options -> Ident -> SourceGrammar -> IOE PGF link opts cnc gr = do let isv = (verbAtLeast opts Normal) putPointE Normal opts "linking ... " $ do - gc0 <- ioeIO (mkCanon2pgf opts cnc gr) - case checkPGF gc0 of - Ok (gc,b) -> do case (isv,b) of - (True, True) -> ioeIO $ putStrLn "OK" - (False,True) -> return () - _ -> ioeIO $ putStrLn $ "Corrupted PGF" - return $ if flag optOptimizePGF opts then optimizePGF gc else gc - Bad s -> fail s + gc <- ioeIO (mkCanon2pgf opts cnc gr) + ioeIO $ putStrLn "OK" + return $ if flag optOptimizePGF opts then optimizePGF gc else gc batchCompile :: Options -> [FilePath] -> IOE SourceGrammar batchCompile opts files = do 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)] -profileGrammar lang (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfrules = do + 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 + +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 - rformat :: Show a => Int -> a -> String - rformat n x = replicate (n-length s) ' ' ++ s - where - s = show x + 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' + + (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 +-- 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. -newtype BranchM a = BM (forall b . (a -> ([ProtoFCat],[Symbol]) -> Branch b) -> ([ProtoFCat],[Symbol]) -> Branch b) +data Branch a + = Case Int Path [(Term,Branch a)] + | Variant [Branch a] + | Return a -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 +newtype CnvMonad a = CM {unCM :: SourceGrammar + -> forall b . (a -> ([ProtoFCat],[Symbol]) -> Branch b) + -> ([ProtoFCat],[Symbol]) + -> Branch b} -instance MonadState ([ProtoFCat],[Symbol]) BranchM where - get = BM (\c s -> c s s) - put s = BM (\c _ -> c () s) +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 Functor BranchM where - fmap f (BM m) = BM (\c s -> m (c . f) s) +instance MonadState ([ProtoFCat],[Symbol]) CnvMonad where + get = CM (\gr c s -> c s s) + put s = CM (\gr c _ -> c () s) -runBranchM :: BranchM (Value a) -> ([ProtoFCat],[Symbol]) -> Branch a -runBranchM (BM m) s = m (\v s -> Return v) s +instance Functor CnvMonad where + fmap f (CM m) = CM (\gr c s -> m gr (c . f) s) -variants :: [a] -> BranchM a -variants xs = BM (\c s -> Variant [c x s | x <- xs]) +runCnvMonad :: SourceGrammar -> CnvMonad a -> ([ProtoFCat],[Symbol]) -> Branch a +runCnvMonad gr (CM m) s = m gr (\v s -> Return v) 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) +-- | backtracking for all variants +variants :: [a] -> CnvMonad a +variants xs = CM (\gr c s -> Variant [c x s | x <- xs]) - restrictArg path index (PFCat n cat rcs tcs) = PFCat n cat rcs (addConstraint path index tcs) +-- | 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]) - 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 + 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" -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 []) +-- | 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 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]) + +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 ---------------------------------------------------------------------- -- term conversion -type CnvMonad a = BranchM a +type Value a = Schema Branch a Term -type FPath = [LIndex] -data ProtoFCat = PFCat Int CId [FPath] [(FPath,[LIndex])] -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 +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))) - -protoFCat :: (Int,CId) -> Term -> ProtoFCat -protoFCat (n,cat) ctype = - let (rcs,tcs) = loop [] [] [] ctype' - in PFCat n cat rcs tcs +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 - 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) + 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) -data Branch a - = Case Int FPath [Branch a] - | Variant [Branch a] - | Return (Value a) +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) -data Value a - = Rec [Branch a] - | Str a - | Con LIndex +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) -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 +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 -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 +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 -addSequences' :: GrammarEnv -> Branch [Symbol] -> (GrammarEnv, Branch SeqId) -addSequences' env (Case nr path bs) = let (env1,bs1) = List.mapAccumL addSequences' env bs +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) + 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..])) - 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) + lincats = + Map.insert cVar (Sort cStr) $ + Map.fromAscList + [(c, ty) | (c,GF.Grammar.CncCat (Just (L _ ty)) _ _) <- Map.toList (M.jments mo)] -expandHOAS opts abs_defs lincats lindefs env = + +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] -getFCats :: GrammarEnv -> ProtoFCat -> [FId] -getFCats (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat rcs tcs) = - case IntMap.lookup n catSet >>= Map.lookup cat of - Just (start,end,ms,_) -> reverse (solutions (variants ms tcs start) ()) - where - variants _ [] fcat = return fcat - variants (m:ms) ((_,indices) : tcs) fcat = do index <- member indices - variants ms tcs ((m*index) + fcat) + 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 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) + +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') + 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) +restrictHead :: Path -> Term -> 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) +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)] + (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)] - mkDef (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] - mkDef Nothing = Nothing + 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] - 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 + 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] +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] - 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 - - 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 + predefADefs = + [(c, AbsCat (Just (L (0,0) []))) | c <- [cFloat,cInt,cString]] - 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 + 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 diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index 2e6f1f1a7..19e786b2a 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -119,7 +119,7 @@ data Term = | Cn Ident -- ^ constant | Con Ident -- ^ constructor | Sort Ident -- ^ basic type - | EInt Integer -- ^ integer literal + | EInt Int -- ^ integer literal | EFloat Double -- ^ floating point literal | K String -- ^ string literal or token: @\"foo\"@ | Empty -- ^ the empty string @[]@ @@ -171,7 +171,7 @@ data Patt = | PW -- ^ wild card pattern: @_@ | PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ -- only concrete | PString String -- ^ string literal pattern: @\"foo\"@ -- only abstract - | PInt Integer -- ^ integer literal pattern: @12@ -- only abstract + | PInt Int -- ^ integer literal pattern: @12@ -- only abstract | PFloat Double -- ^ float literal pattern: @1.2@ -- only abstract | PT Type Patt -- ^ type-annotated pattern diff --git a/src/compiler/GF/Grammar/Lexer.x b/src/compiler/GF/Grammar/Lexer.x index 492c7ce8e..ca796808b 100644 --- a/src/compiler/GF/Grammar/Lexer.x +++ b/src/compiler/GF/Grammar/Lexer.x @@ -112,7 +112,7 @@ data Token | T_where | T_with | T_String String -- string literals - | T_Integer Integer -- integer literals + | T_Integer Int -- integer literals | T_Double Double -- double precision float literals | T_LString String | T_Ident Ident diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index 3380a55c0..9b9c45ba7 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/src/compiler/GF/Grammar/Macros.hs @@ -166,6 +166,12 @@ unzipR r = (ls, map snd ts) where (ls,ts) = unzip r mkAssign :: [(Label,Term)] -> [Assign] mkAssign lts = [assign l t | (l,t) <- lts] +projectRec :: Label -> [Assign] -> Term +projectRec l rs = + case lookup l rs of + Just (_,t) -> t + Nothing -> error (render (text "no value for label" <+> ppLabel l)) + zipAssign :: [Label] -> [Term] -> [Assign] zipAssign ls ts = [assign l t | (l,t) <- zip ls ts] @@ -199,7 +205,7 @@ typeTok = Sort cTok typeStrs = Sort cStrs typeString, typeFloat, typeInt :: Term -typeInts :: Integer -> Term +typeInts :: Int -> Term typePBool :: Term typeError :: Term @@ -210,7 +216,7 @@ typeInts i = App (cnPredef cInts) (EInt i) typePBool = cnPredef cPBool typeError = cnPredef cErrorType -isTypeInts :: Term -> Maybe Integer +isTypeInts :: Term -> Maybe Int isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i isTypeInts _ = Nothing @@ -299,7 +305,7 @@ freshAsTerm s = Vr (varX (readIntArg s)) string2term :: String -> Term string2term = K -int2term :: Integer -> Term +int2term :: Int -> Term int2term = EInt float2term :: Double -> Term diff --git a/src/compiler/GF/Grammar/Predef.hs b/src/compiler/GF/Grammar/Predef.hs index 370497cc7..f16765433 100644 --- a/src/compiler/GF/Grammar/Predef.hs +++ b/src/compiler/GF/Grammar/Predef.hs @@ -19,6 +19,7 @@ module GF.Grammar.Predef , cInt , cFloat , cString + , cVar , cInts , cPBool , cErrorType @@ -73,6 +74,9 @@ cFloat = identC (BS.pack "Float") cString :: Ident cString = identC (BS.pack "String") +cVar :: Ident +cVar = identC (BS.pack "__gfVar") + cInts :: Ident cInts = identC (BS.pack "Ints") @@ -89,7 +93,7 @@ cUndefinedType :: Ident cUndefinedType = identC (BS.pack "UndefinedType") isLiteralCat :: Ident -> Bool -isLiteralCat c = elem c [cInt,cString,cFloat] +isLiteralCat c = elem c [cInt,cString,cFloat,cVar] cPTrue :: Ident cPTrue = identC (BS.pack "PTrue") diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index 69c9e8860..3f97dd390 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -171,7 +171,7 @@ ppTerm q d (Q id) = ppQIdent q id ppTerm q d (QC id) = ppQIdent q id ppTerm q d (Sort id) = ppIdent id ppTerm q d (K s) = str s -ppTerm q d (EInt n) = integer n +ppTerm q d (EInt n) = int n ppTerm q d (EFloat f) = double f ppTerm q d (Meta _) = char '?' ppTerm q d (Empty) = text "[]" @@ -204,7 +204,7 @@ ppPatt q d (PMacro id) = char '#' <> ppIdent id ppPatt q d (PM id) = char '#' <> ppQIdent q id ppPatt q d PW = char '_' ppPatt q d (PV id) = ppIdent id -ppPatt q d (PInt n) = integer n +ppPatt q d (PInt n) = int n ppPatt q d (PFloat f) = double f ppPatt q d (PString s) = str s ppPatt q d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs])) diff --git a/src/compiler/GFC.hs b/src/compiler/GFC.hs index 352827f6d..0cd8a343b 100644 --- a/src/compiler/GFC.hs +++ b/src/compiler/GFC.hs @@ -9,6 +9,7 @@ import GF.Compile import GF.Compile.Export import GF.Grammar.CF ---- should this be on a deeper level? AR 15/10/2008 +import GF.Grammar (identC) import GF.Infra.UseIO import GF.Infra.Option @@ -16,6 +17,7 @@ import GF.Data.ErrM import Data.Maybe import Data.Binary +import qualified Data.ByteString.Char8 as BS import System.FilePath import System.IO import Control.Exception @@ -37,7 +39,7 @@ compileSourceFiles opts fs = let cnc = justModuleName (last fs) if flag optStopAfterPhase opts == Compile then return () - else do pgf <- link opts cnc gr + else do pgf <- link opts (identC (BS.pack cnc)) gr writePGF opts pgf writeOutputs opts pgf @@ -49,7 +51,7 @@ compileCFFiles opts fs = gr <- compileSourceGrammar opts gf if flag optStopAfterPhase opts == Compile then return () - else do pgf <- link opts cnc gr + else do pgf <- link opts (identC (BS.pack cnc)) gr writePGF opts pgf writeOutputs opts pgf diff --git a/src/runtime/haskell/PGF/Check.hs b/src/runtime/haskell/PGF/Check.hs deleted file mode 100644 index 94713a745..000000000 --- a/src/runtime/haskell/PGF/Check.hs +++ /dev/null @@ -1,173 +0,0 @@ -module PGF.Check (checkPGF,checkLin) where - -import PGF.CId -import PGF.Data -import PGF.Macros -import GF.Data.ErrM - -import qualified Data.Map as Map -import Control.Monad -import Data.Maybe(fromMaybe) -import Debug.Trace - -checkPGF :: PGF -> Err (PGF,Bool) -checkPGF pgf = return (pgf,True) {- do - (cs,bs) <- mapM (checkConcrete pgf) - (Map.assocs (concretes pgf)) >>= return . unzip - return (pgf {concretes = Map.fromAscList cs}, and bs) --} - --- errors are non-fatal; replace with 'fail' to change this -msg s = trace s (return ()) - -andMapM :: Monad m => (a -> m Bool) -> [a] -> m Bool -andMapM f xs = mapM f xs >>= return . and - -labelBoolErr :: String -> Err (x,Bool) -> Err (x,Bool) -labelBoolErr ms iob = do - (x,b) <- iob - if b then return (x,b) else (msg ms >> return (x,b)) - -{- -checkConcrete :: PGF -> (CId,Concr) -> Err ((CId,Concr),Bool) -checkConcrete pgf (lang,cnc) = - labelBoolErr ("happened in language " ++ showCId lang) $ do - (rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip - return ((lang,cnc{lins = Map.fromAscList rs}),and bs) - where - checkl = checkLin pgf lang --} - -type PGFSig = (Map.Map CId (Type,Int,Maybe [Equation]),Map.Map CId Term,Map.Map CId Term) - -checkLin :: PGFSig -> CId -> (CId,Term) -> Err ((CId,Term),Bool) -checkLin pgf lang (f,t) = - labelBoolErr ("happened in function " ++ showCId f) $ do - (t',b) <- checkTerm (lintype pgf lang f) t --- $ inline pgf lang t - return ((f,t'),b) - -inferTerm :: [CType] -> Term -> Err (Term,CType) -inferTerm args trm = case trm of - K _ -> returnt str - C i -> returnt $ ints i - V i -> do - testErr (i < length args) ("too large index " ++ show i) - returnt $ args !! i - S ts -> do - (ts',tys) <- mapM infer ts >>= return . unzip - let tys' = filter (/=str) tys - testErr (null tys') - ("expected Str in " ++ show trm ++ " not " ++ unwords (map show tys')) - return (S ts',str) - R ts -> do - (ts',tys) <- mapM infer ts >>= return . unzip - return $ (R ts',tuple tys) - P t u -> do - (t',tt) <- infer t - (u',tu) <- infer u - case tt of - R tys -> case tu of - R vs -> infer $ foldl P t' [P u' (C i) | i <- [0 .. length vs - 1]] - --- R [v] -> infer $ P t v - --- R (v:vs) -> infer $ P (head tys) (R vs) - - C i -> do - testErr (i < length tys) - ("required more than " ++ show i ++ " fields in " ++ show (R tys)) - return (P t' u', tys !! i) -- record: index must be known - _ -> do - let typ = head tys - testErr (all (==typ) tys) ("different types in table " ++ show trm) - return (P t' u', typ) -- table: types must be same - _ -> Bad $ "projection from " ++ show t ++ " : " ++ show tt - FV [] -> returnt tm0 ---- - FV (t:ts) -> do - (t',ty) <- infer t - (ts',tys) <- mapM infer ts >>= return . unzip - testErr (all (eqType True ty) tys) ("different types in variants " ++ show trm) - return (FV (t':ts'),ty) - W s r -> infer r - _ -> Bad ("no type inference for " ++ show trm) - where - returnt ty = return (trm,ty) - infer = inferTerm args - -checkTerm :: LinType -> Term -> Err (Term,Bool) -checkTerm (args,val) trm = case inferTerm args trm of - Ok (t,ty) -> if eqType False ty val - then return (t,True) - else do - msg ("term: " ++ show trm ++ - "\nexpected type: " ++ show val ++ - "\ninferred type: " ++ show ty) - return (t,False) - Bad s -> do - msg s - return (trm,False) - --- symmetry in (Ints m == Ints n) is all we can use in variants - -eqType :: Bool -> CType -> CType -> Bool -eqType symm inf exp = case (inf,exp) of - (C k, C n) -> if symm then True else k <= n -- only run-time corr. - (R rs,R ts) -> length rs == length ts && and [eqType symm r t | (r,t) <- zip rs ts] - (TM _, _) -> True ---- for variants [] ; not safe - _ -> inf == exp - --- should be in a generic module, but not in the run-time DataGFCC - -type CType = Term -type LinType = ([CType],CType) - -tuple :: [CType] -> CType -tuple = R - -ints :: Int -> CType -ints = C - -str :: CType -str = S [] - -lintype :: PGFSig -> CId -> CId -> LinType -lintype pgf lang fun = case typeSkeleton (lookFun pgf fun) of - (cs,c) -> (map vlinc cs, linc c) ---- HOAS - where - linc = lookLincat pgf lang - vlinc (0,c) = linc c - vlinc (i,c) = case linc c of - R ts -> R (ts ++ replicate i str) - -composOp :: Monad m => (Term -> m Term) -> Term -> m Term -composOp f trm = case trm of - R ts -> liftM R $ mapM f ts - S ts -> liftM S $ mapM f ts - FV ts -> liftM FV $ mapM f ts - P t u -> liftM2 P (f t) (f u) - W s t -> liftM (W s) $ f t - _ -> return trm - -composSafeOp :: (Term -> Term) -> Term -> Term -composSafeOp f = maybe undefined id . composOp (return . f) - --- from GF.Data.Oper - -maybeErr :: String -> Maybe a -> Err a -maybeErr s = maybe (Bad s) Ok - -testErr :: Bool -> String -> Err () -testErr cond msg = if cond then return () else Bad msg - -errVal :: a -> Err a -> a -errVal a = err (const a) id - -errIn :: String -> Err a -> Err a -errIn msg = err (\s -> Bad (s ++ "\nOCCURRED IN\n" ++ msg)) return - -err :: (String -> b) -> (a -> b) -> Err a -> b -err d f e = case e of - Ok a -> f a - Bad s -> d s - -lookFun (abs,lin,lincats) f = (\(a,b,c) -> a) $ fromMaybe (error "No abs") (Map.lookup f abs) -lookLincat (abs,lin,lincats) _ c = fromMaybe (error "No lincat") (Map.lookup c lincats) -lookLin (abs,lin,lincats) _ f = fromMaybe (error "No lin") (Map.lookup f lin) diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs index 12f945151..8b2fb41f8 100644 --- a/src/runtime/haskell/PGF/Data.hs +++ b/src/runtime/haskell/PGF/Data.hs @@ -68,22 +68,6 @@ data Alternative = Alt [String] [String] deriving (Eq,Ord,Show) -data Term = - R [Term] - | P Term Term - | S [Term] - | K Tokn - | V Int - | C Int - | FV [Term] - | W String Term - | TM String - deriving (Eq,Ord,Show) - -data Tokn = - KS String - | KP [String] [Alternative] - deriving (Eq,Ord,Show) -- merge two PGFs; fails is differens absnames; priority to second arg diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs index 1bee56b9b..f6116ba60 100644 --- a/src/runtime/haskell/PGF/Macros.hs +++ b/src/runtime/haskell/PGF/Macros.hs @@ -117,15 +117,6 @@ contextLength ty = case ty of showPrintName :: PGF -> Language -> CId -> String showPrintName pgf lang id = lookMap (showCId id) id $ printnames $ lookMap (error "no lang") lang $ concretes pgf -term0 :: CId -> Term -term0 = TM . showCId - -tm0 :: Term -tm0 = TM "?" - -kks :: String -> Term -kks = K . KS - -- lookup with default value lookMap :: (Show i, Ord i) => a -> i -> Map.Map i a -> a lookMap d c m = Map.findWithDefault d c m diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs index 68392422f..226fc5fa8 100644 --- a/src/runtime/haskell/PGF/VisualizeTree.hs +++ b/src/runtime/haskell/PGF/VisualizeTree.hs @@ -28,7 +28,8 @@ import PGF.CId (CId,showCId,ppCId,pCId,mkCId) import PGF.Data import PGF.Expr (showExpr, Tree) import PGF.Linearize -import PGF.Macros (lookValCat, lookMap, _B, _V, BracketedString(..), flattenBracketedString) +import PGF.Macros (lookValCat, lookMap, _B, _V, + BracketedString(..), BracketedTokn(..), flattenBracketedString) import qualified Data.Map as Map import qualified Data.IntMap as IntMap @@ -274,7 +275,7 @@ tag i -- -- Uuuuugly!!! I hope that this code will be removed one day. -type LinTable = Array LIndex [Tokn] +type LinTable = Array LIndex [BracketedTokn] linTree :: PGF -> Language -> (Maybe CId -> [Int] -> LinTable -> LinTable) -> Expr -> [LinTable] @@ -299,7 +300,7 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e lin path xs mb_fid (ETyped e _) es = lin path xs mb_fid e es lin path xs mb_fid (EImplArg e) es = lin path xs mb_fid e es - ss s = listArray (0,0) [[KS s]] + ss s = listArray (0,0) [[LeafKS [s]]] apply path xs mb_fid f es = case Map.lookup f lp of @@ -332,15 +333,15 @@ linTree pgf lang mark e = lin0 [] [] [] Nothing e compute (SymCat d r) = (args !! d) ! r compute (SymLit d r) = (args !! d) ! r - compute (SymKS ts) = map KS ts - compute (SymKP ts alts) = [KP ts alts] + compute (SymKS ts) = [LeafKS ts] + compute (SymKP ts alts) = [LeafKP ts alts] -untokn :: [Tokn] -> [String] +untokn :: [BracketedTokn] -> [String] untokn ts = case ts of - KP d _ : [] -> d - KP d vs : ws -> let ss@(s:_) = untokn ws in sel d vs s ++ ss - KS s : ws -> s : untokn ws - [] -> [] + LeafKP d _ : [] -> d + LeafKP d vs : ws -> let ss@(s:_) = untokn ws in sel d vs s ++ ss + LeafKS s : ws -> s ++ untokn ws + [] -> [] where sel d vs w = case [v | Alt v cs <- vs, any (\c -> isPrefixOf c w) cs] of v:_ -> v @@ -353,8 +354,8 @@ markLinearizes pgf lang = map (unwords . untokn . (! 0)) . linTree pgf lang mark where mark mb_f path lint = amap (bracket mb_f path) lint - bracket Nothing path ts = [KS ("("++show (reverse path))] ++ ts ++ [KS ")"] - bracket (Just f) path ts = [KS ("(("++showCId f++","++show (reverse path)++")")] ++ ts ++ [KS ")"] + bracket Nothing path ts = [LeafKS ["("++show (reverse path)]] ++ ts ++ [LeafKS [")"]] + bracket (Just f) path ts = [LeafKS ["(("++showCId f++","++show (reverse path)++")"]] ++ ts ++ [LeafKS [")"]] graphvizDependencyTree :: String -> Bool -> Maybe Labels -> Maybe String -> PGF -> CId -> Expr -> String