msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Add binary instances

Browse Source
This commit is contained in:
John J. Camilleri
2021-01-25 14:42:00 +01:00
parent 32b0860925
commit 270e7f021f
3 changed files with 64 additions and 288 deletions
Download Patch File Download Diff File Expand all files Collapse all files

289
src/compiler/GF/Compile/GrammarToLPGF.hs
View File

@@ -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

61
src/runtime/haskell/LPGF.hs
View File

@@ -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]

2
testsuite/lpgf/run.hs
View File

@@ -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)