Add binary instances

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

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]

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)