diff --git a/src/compiler/GF/Compile/GrammarToLPGF.hs b/src/compiler/GF/Compile/GrammarToLPGF.hs index e9f328db9..bd3b044f7 100644 --- a/src/compiler/GF/Compile/GrammarToLPGF.hs +++ b/src/compiler/GF/Compile/GrammarToLPGF.hs @@ -1,18 +1,9 @@ --- {-# LANGUAGE BangPatterns, FlexibleContexts #-} module GF.Compile.GrammarToLPGF (mkCanon2lpgf) where import LPGF (LPGF (..)) import qualified LPGF as L ---import GF.Compile.Export --- import GF.Compile.GeneratePMCFG --- import GF.Compile.GenerateBC --- import PGF.CId --- import PGF.Internal(fidInt,fidFloat,fidString,fidVar) --- import PGF.Internal(updateProductionIndices) --- import qualified PGF.Internal as C --- import qualified PGF.Internal as D import GF.Grammar.Predef import GF.Grammar.Grammar import qualified GF.Grammar.Lookup as Look @@ -26,11 +17,8 @@ import GF.Data.Operations import Control.Monad (forM_) import Data.List (elemIndex) --- import qualified Data.Set as Set import qualified Data.Map as Map import Data.Maybe (mapMaybe) --- import qualified Data.IntMap as IntMap --- import Data.Array.IArray mkCanon2lpgf :: Options -> SourceGrammar -> ModuleName -> IOE LPGF mkCanon2lpgf opts gr am = do @@ -42,30 +30,22 @@ mkCanon2lpgf opts gr am = do L.concretes = Map.fromList cncs } where --- cenv = resourceValues opts gr - mkAbstr :: ModuleName -> IOE (CId, L.Abstr) mkAbstr am = do let --- aflags = err (const noOptions) mflags (lookupModule gr am) - adefs = [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++ Look.allOrigInfos gr am --- flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF aflags] + -- funs = Map.fromList [ (i2i f, mkType [] ty) + -- | ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs + -- , let arity = mkArity ma mdef ty + -- ] + -- + -- cats = Map.fromList [ (i2i c, ()) + -- | ((m,c),AbsCat (Just (L _ cont))) <- adefs + -- ] - funs = Map.fromList [ (i2i f, mkType [] ty) - | ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs - , let arity = mkArity ma mdef ty - ] - - cats = Map.fromList [ (i2i c, ()) - | ((m,c),AbsCat (Just (L _ cont))) <- adefs - ] - --- catfuns cat = --- [(0,i2i f) | ((m,f),AbsFun (Just (L _ ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat] return (mi2i am, L.Abstr { -- L.cats = cats, -- L.funs = funs @@ -104,7 +84,7 @@ mkCanon2lpgf opts gr am = do R asgns -> do ts <- sequence [ term2lin cxt mtype term | (_, (mtype, term)) <- asgns ] return $ L.LFTuple ts - QC qiV -> do -- qi = ZeroEng.Sg + QC qiV -> do QC qiP <- mtype let vs = [ ic | QC ic <- fromErr [] $ Look.lookupParamValues gr qiP ] ix <- elemIndex qiV vs @@ -116,253 +96,18 @@ mkCanon2lpgf opts gr am = do L.lins = lins }) --- let cflags = err (const noOptions) mflags (lookupModule gr cm) --- ciCmp | flag optCaseSensitive cflags = compare --- | otherwise = C.compareCaseInsensitve --- --- (ex_seqs,cdefs) <- addMissingPMCFGs --- Map.empty --- ([((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++ --- Look.allOrigInfos gr cm) --- --- let flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF cflags] --- --- seqs = (mkArray . C.sortNubBy ciCmp . concat) $ --- (Map.keys ex_seqs : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm]) --- --- ex_seqs_arr = mkMapArray ex_seqs :: Array SeqId Sequence --- --- !(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs --- !(!fid_cnt2,!productions,!lindefs,!linrefs,!cncfuns) --- = genCncFuns gr am cm ex_seqs_arr ciCmp seqs cdefs fid_cnt1 cnccats --- --- printnames = genPrintNames cdefs --- return (mi2i cm, D.Concr flags --- printnames --- cncfuns --- lindefs --- linrefs --- seqs --- productions --- IntMap.empty --- Map.empty --- cnccats --- IntMap.empty --- fid_cnt2) --- where --- -- if some module was compiled with -no-pmcfg, then --- -- we have to create the PMCFG code just before linking --- addMissingPMCFGs seqs [] = return (seqs,[]) --- addMissingPMCFGs seqs (((m,id), info):is) = do --- (seqs,info) <- addPMCFG opts gr cenv Nothing am cm seqs id info --- (seqs,is ) <- addMissingPMCFGs seqs is --- return (seqs, ((m,id), info) : is) - i2i :: Ident -> CId i2i = utf8CId . ident2utf8 mi2i :: ModuleName -> CId mi2i (MN i) = i2i i -mkType :: [Ident] -> A.Type -> L.Type -mkType scope t = - case GM.typeForm t of - (hyps,(_,cat),args) -> L.Type (map (\(bt,i,t) -> i2i i) hyps) (i2i cat) - -- (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps - -- in D.Type hyps' (i2i cat) (map (mkExp scope') args) +-- mkType :: [Ident] -> A.Type -> L.Type +-- mkType scope t = +-- case GM.typeForm t of +-- (hyps,(_,cat),args) -> L.Type (map (\(bt,i,t) -> i2i i) hyps) (i2i cat) --- mkExp :: [Ident] -> A.Term -> C.Expr --- mkExp scope t = --- case t of --- Q (_,c) -> C.EFun (i2i c) --- QC (_,c) -> C.EFun (i2i c) --- Vr x -> case lookup x (zip scope [0..]) of --- Just i -> C.EVar i --- Nothing -> C.EMeta 0 --- Abs b x t-> C.EAbs b (i2i x) (mkExp (x:scope) t) --- App t1 t2-> C.EApp (mkExp scope t1) (mkExp scope t2) --- EInt i -> C.ELit (C.LInt (fromIntegral i)) --- EFloat f -> C.ELit (C.LFlt f) --- K s -> C.ELit (C.LStr s) --- Meta i -> C.EMeta i --- _ -> C.EMeta 0 --- --- mkPatt scope p = --- case p of --- A.PP (_,c) ps->let (scope',ps') = mapAccumL mkPatt scope ps --- in (scope',C.PApp (i2i c) ps') --- A.PV x -> (x:scope,C.PVar (i2i x)) --- A.PAs x p -> let (scope',p') = mkPatt scope p --- in (x:scope',C.PAs (i2i x) p') --- A.PW -> ( scope,C.PWild) --- A.PInt i -> ( scope,C.PLit (C.LInt (fromIntegral i))) --- A.PFloat f -> ( scope,C.PLit (C.LFlt f)) --- A.PString s -> ( scope,C.PLit (C.LStr s)) --- A.PImplArg p-> let (scope',p') = 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,(bt,i2i x,ty')) --- else (x:scope,(bt,i2i x,ty'))) scope hyps --- --- mkDef gr arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] --- ,generateByteCode gr arity eqs --- ) --- mkDef gr arity Nothing = Nothing - -mkArity (Just a) _ ty = a -- known arity, i.e. defined function -mkArity Nothing (Just _) ty = 0 -- defined function with no arity - must be an axiom -mkArity Nothing _ ty = let (ctxt, _, _) = GM.typeForm ty -- constructor - in length ctxt - --- genCncCats gr am cm cdefs = --- let (index,cats) = mkCncCats 0 cdefs --- in (index, Map.fromList cats) --- where --- mkCncCats index [] = (index,[]) --- mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _ _):cdefs) --- | id == cInt = --- let cc = pgfCncCat gr lincat fidInt --- (index',cats) = mkCncCats index cdefs --- in (index', (i2i id,cc) : cats) --- | id == cFloat = --- let cc = pgfCncCat gr lincat fidFloat --- (index',cats) = mkCncCats index cdefs --- in (index', (i2i id,cc) : cats) --- | id == cString = --- let cc = pgfCncCat gr lincat fidString --- (index',cats) = mkCncCats index cdefs --- in (index', (i2i id,cc) : cats) --- | otherwise = --- let cc@(C.CncCat _s e _) = pgfCncCat gr lincat index --- (index',cats) = mkCncCats (e+1) cdefs --- in (index', (i2i id,cc) : cats) --- mkCncCats index (_ :cdefs) = mkCncCats index cdefs --- --- genCncFuns :: Grammar --- -> ModuleName --- -> ModuleName --- -> Array SeqId Sequence --- -> (Sequence -> Sequence -> Ordering) --- -> Array SeqId Sequence --- -> [(QIdent, Info)] --- -> FId --- -> Map.Map CId D.CncCat --- -> (FId, --- IntMap.IntMap (Set.Set D.Production), --- IntMap.IntMap [FunId], --- IntMap.IntMap [FunId], --- Array FunId D.CncFun) --- genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccats = --- let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt 0 [] IntMap.empty IntMap.empty --- (fid_cnt2,funs_cnt2,funs2,prods) = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty --- in (fid_cnt2,prods,lindefs,linrefs,array (0,funs_cnt2-1) funs2) --- where --- mkCncCats [] fid_cnt funs_cnt funs lindefs linrefs = --- (fid_cnt,funs_cnt,funs,lindefs,linrefs) --- mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs linrefs = --- let !funs_cnt' = let (s_funid, e_funid) = bounds funs0 --- in funs_cnt+(e_funid-s_funid+1) --- lindefs' = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0 --- linrefs' = foldl' (toLinRef (am,id) funs_cnt) linrefs prods0 --- funs' = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) funs (assocs funs0) --- in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs' linrefs' --- mkCncCats (_ :cdefs) fid_cnt funs_cnt funs lindefs linrefs = --- mkCncCats cdefs fid_cnt funs_cnt funs lindefs linrefs --- --- mkCncFuns [] fid_cnt funs_cnt funs lindefs crc prods = --- (fid_cnt,funs_cnt,funs,prods) --- mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs crc prods = --- let ---Ok ty_C = fmap GM.typeForm (Look.lookupFunType gr am id) --- ty_C = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id) --- !funs_cnt' = let (s_funid, e_funid) = bounds funs0 --- in funs_cnt+(e_funid-s_funid+1) --- !(fid_cnt',crc',prods') --- = foldl' (toProd lindefs ty_C funs_cnt) --- (fid_cnt,crc,prods) prods0 --- funs' = foldl' (toCncFun funs_cnt (m,id)) funs (assocs funs0) --- in mkCncFuns cdefs fid_cnt' funs_cnt' funs' lindefs crc' prods' --- mkCncFuns (_ :cdefs) fid_cnt funs_cnt funs lindefs crc prods = --- mkCncFuns cdefs fid_cnt funs_cnt funs lindefs crc prods --- --- toProd lindefs (ctxt_C,res_C,_) offs st (Production fid0 funid0 args0) = --- let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0) --- set0 = Set.fromList (map (C.PApply (offs+funid0)) (sequence args)) --- fid = mkFId res_C fid0 --- !prods' = case IntMap.lookup fid prods of --- Just set -> IntMap.insert fid (Set.union set0 set) prods --- Nothing -> IntMap.insert fid set0 prods --- in (fid_cnt,crc,prods') --- where --- mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s ) = --- case fid0s of --- [fid0] -> (st,map (flip C.PArg (mkFId arg_C fid0)) ctxt) --- fid0s -> case Map.lookup fids crc of --- Just fid -> (st,map (flip C.PArg fid) ctxt) --- Nothing -> let !crc' = Map.insert fids fid_cnt crc --- !prods' = IntMap.insert fid_cnt (Set.fromList (map C.PCoerce fids)) prods --- in ((fid_cnt+1,crc',prods'),map (flip C.PArg fid_cnt) ctxt) --- where --- (hargs_C,arg_C) = GM.catSkeleton ty --- ctxt = mapM (mkCtxt lindefs) hargs_C --- fids = map (mkFId arg_C) fid0s --- --- mkLinDefId id = prefixIdent "lindef " id --- --- toLinDef res offs lindefs (Production fid0 funid0 args) = --- if args == [[fidVar]] --- then IntMap.insertWith (++) fid [offs+funid0] lindefs --- else lindefs --- where --- fid = mkFId res fid0 --- --- toLinRef res offs linrefs (Production fid0 funid0 [fargs]) = --- if fid0 == fidVar --- then foldr (\fid -> IntMap.insertWith (++) fid [offs+funid0]) linrefs fids --- else linrefs --- where --- fids = map (mkFId res) fargs --- --- mkFId (_,cat) fid0 = --- case Map.lookup (i2i cat) cnccats of --- Just (C.CncCat s e _) -> s+fid0 --- Nothing -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat) --- --- mkCtxt lindefs (_,cat) = --- case Map.lookup (i2i cat) cnccats of --- Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]] --- Nothing -> error "GrammarToPGF.mkCtxt failed" --- --- toCncFun offs (m,id) funs (funid0,lins0) = --- let mseqs = case lookupModule gr m of --- Ok (ModInfo{mseqs=Just mseqs}) -> mseqs --- _ -> ex_seqs --- in (offs+funid0,C.CncFun (i2i id) (amap (newIndex mseqs) lins0)):funs --- where --- newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs) --- --- binSearch v arr (i,j) --- | i <= j = case ciCmp v (arr ! k) of --- LT -> binSearch v arr (i,k-1) --- EQ -> k --- GT -> binSearch v arr (k+1,j) --- | otherwise = error "binSearch" --- where --- k = (i+j) `div` 2 --- --- genPrintNames cdefs = --- Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info] --- where --- prn (CncFun _ _ (Just (L _ tr)) _) = [flatten tr] --- prn (CncCat _ _ _ (Just (L _ tr)) _) = [flatten tr] --- prn _ = [] --- --- flatten (K s) = s --- flatten (Alts x _) = flatten x --- flatten (C x y) = flatten x +++ flatten y --- --- mkArray lst = listArray (0,length lst-1) lst --- mkMapArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] +-- mkArity (Just a) _ ty = a -- known arity, i.e. defined function +-- mkArity Nothing (Just _) ty = 0 -- defined function with no arity - must be an axiom +-- mkArity Nothing _ ty = let (ctxt, _, _) = GM.typeForm ty -- constructor +-- in length ctxt diff --git a/src/runtime/haskell/LPGF.hs b/src/runtime/haskell/LPGF.hs index 44cb1c775..fd4003698 100644 --- a/src/runtime/haskell/LPGF.hs +++ b/src/runtime/haskell/LPGF.hs @@ -8,6 +8,7 @@ import PGF.CId import PGF.Expr (Expr) import PGF.Tree (Tree (..), expr2tree, prTree) +import Data.Binary (Binary, get, put, encodeFile, decodeFile) import qualified Data.Map as Map import Text.Printf (printf) @@ -16,30 +17,30 @@ data LPGF = LPGF { absname :: CId, abstract :: Abstr, concretes :: Map.Map CId Concr -} deriving (Read, Show) +} deriving (Show) -- | Abstract syntax data Abstr = Abstr { -- cats :: Map.Map CId (), -- funs :: Map.Map CId Type -} deriving (Read, Show) +} deriving (Show) -- | Concrete syntax data Concr = Concr { -- lincats :: Map.Map CId LinType, -- ^ assigning a linearization type to each category lins :: Map.Map CId LinFun -- ^ assigning a linearization function to each function -} deriving (Read, Show) +} deriving (Show) -- | Abstract function type -data Type = Type [CId] CId - deriving (Read, Show) +-- data Type = Type [CId] CId +-- deriving (Show) -- | Linearisation type data LinType = LTStr | LTInt Int | LTProduct [LinType] - deriving (Read, Show) + deriving (Show) -- | Linearisation function data LinFun = @@ -50,16 +51,47 @@ data LinFun = | LFTuple [LinFun] | LFProjection LinFun LinFun -- ^ In order for the projection to be well-formed, t1 must be a tuple and t2 an integer within the bounds of the size of the tuple | LFArgument Int - deriving (Read, Show) + deriving (Show, Read) + +instance Binary LPGF where + put lpgf = do + put (absname lpgf) + put (abstract lpgf) + put (concretes lpgf) + get = do + an <- get + abs <- get + concs <- get + return $ LPGF { + absname = an, + abstract = abs, + concretes = concs + } + +instance Binary Abstr where + put abs = return () + get = return $ Abstr {} + +instance Binary Concr where + put concr = put (lins concr) + get = do + ls <- get + return $ Concr { + lins = ls + } + +instance Binary LinFun where + put = put . show + get = read <$> get abstractName :: LPGF -> CId abstractName = absname encodeFile :: FilePath -> LPGF -> IO () -encodeFile path lpgf = writeFile path (show lpgf) +encodeFile = Data.Binary.encodeFile readLPGF :: FilePath -> IO LPGF -readLPGF path = read <$> readFile path +readLPGF = Data.Binary.decodeFile -- | Helper for building concat trees mkConcat :: [LinFun] -> LinFun @@ -81,12 +113,11 @@ linearizeConcr concr expr = lin2string $ lin (expr2tree expr) where lin :: Tree -> LinFun lin tree = case tree of - Fun f as -> v - where - Just t = Map.lookup f (lins concr) - ts = map lin as - v = eval ts t - x -> error $ printf "Cannot lin %s" (prTree x) + Fun f as -> + case Map.lookup f (lins concr) of + Just t -> eval (map lin as) t + _ -> error $ printf "Lookup failed for function: %s" (showCId f) + x -> error $ printf "Cannot lin: %s" (prTree x) -- | Evaluation context is a sequence of terms type Context = [LinFun] diff --git a/testsuite/lpgf/run.hs b/testsuite/lpgf/run.hs index c4b0288ab..57e0e749d 100644 --- a/testsuite/lpgf/run.hs +++ b/testsuite/lpgf/run.hs @@ -1,5 +1,5 @@ import LPGF -import PGF (Tree, mkCId, mkApp, readLanguage, showLanguage, showExpr) +import PGF (Tree, mkCId, mkApp, showLanguage, showExpr) import GF (compileToLPGF, writeLPGF) import GF.Support (noOptions)