mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-21 10:49:33 -06:00
383 lines
15 KiB
Haskell
383 lines
15 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : GF.Grammar.Binary
|
|
-- Maintainer : Krasimir Angelov
|
|
-- Stability : (stable)
|
|
-- Portability : (portable)
|
|
--
|
|
-----------------------------------------------------------------------------
|
|
|
|
module GF.Grammar.Binary(VersionTagged(..),decodeModuleHeader,decodeModule,encodeModule) where
|
|
|
|
import Prelude hiding (catch)
|
|
import Control.Monad
|
|
import Control.Exception(catch,ErrorCall(..),throwIO)
|
|
import Data.Binary
|
|
import qualified Data.Map as Map(empty)
|
|
import qualified Data.ByteString.Char8 as BS
|
|
|
|
import GF.Data.Operations
|
|
import GF.Infra.Ident
|
|
import GF.Infra.Option
|
|
import GF.Infra.UseIO(MonadIO(..))
|
|
import GF.Grammar.Grammar
|
|
|
|
import PGF2(Literal(..))
|
|
import PGF2.Transactions(Symbol(..))
|
|
|
|
-- Please change this every time when the GFO format is changed
|
|
gfoVersion = "GF05"
|
|
|
|
instance Binary Grammar where
|
|
put = put . modules
|
|
get = fmap mGrammar get
|
|
|
|
instance Binary ModuleInfo where
|
|
put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,jments mi)
|
|
get = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,mseqs,jments) <- get
|
|
return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments)
|
|
|
|
instance Binary ModuleType where
|
|
put MTAbstract = putWord8 0
|
|
put MTResource = putWord8 2
|
|
put (MTConcrete i) = putWord8 3 >> put i
|
|
put MTInterface = putWord8 4
|
|
put (MTInstance i) = putWord8 5 >> put i
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> return MTAbstract
|
|
2 -> return MTResource
|
|
3 -> get >>= return . MTConcrete
|
|
4 -> return MTInterface
|
|
5 -> get >>= return . MTInstance
|
|
_ -> decodingError
|
|
|
|
instance Binary MInclude where
|
|
put MIAll = putWord8 0
|
|
put (MIOnly xs) = putWord8 1 >> put xs
|
|
put (MIExcept xs) = putWord8 2 >> put xs
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> return MIAll
|
|
1 -> fmap MIOnly get
|
|
2 -> fmap MIExcept get
|
|
_ -> decodingError
|
|
|
|
instance Binary OpenSpec where
|
|
put (OSimple i) = putWord8 0 >> put i
|
|
put (OQualif i j) = putWord8 1 >> put (i,j)
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> get >>= return . OSimple
|
|
1 -> get >>= \(i,j) -> return (OQualif i j)
|
|
_ -> decodingError
|
|
|
|
instance Binary ModuleStatus where
|
|
put MSComplete = putWord8 0
|
|
put MSIncomplete = putWord8 1
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> return MSComplete
|
|
1 -> return MSIncomplete
|
|
_ -> decodingError
|
|
|
|
instance Binary Options where
|
|
put = put . optionsGFO
|
|
get = do opts <- get
|
|
case parseModuleOptions ["--" ++ flag ++ "=" ++ toString value | (flag,value) <- opts] of
|
|
Ok x -> return x
|
|
Bad msg -> fail msg
|
|
where
|
|
toString (LStr s) = s
|
|
toString (LInt n) = show n
|
|
toString (LFlt d) = show d
|
|
|
|
instance Binary LParam where
|
|
put (LParam r rs) = put (r,rs)
|
|
get = get >>= \(r,rs) -> return (LParam r rs)
|
|
|
|
instance Binary PArg where
|
|
put (PArg x y) = put (x,y)
|
|
get = get >>= \(x,y) -> return (PArg x y)
|
|
|
|
instance Binary Production where
|
|
put (Production ps args res rules) = put (ps,args,res,rules)
|
|
get = get >>= \(ps,args,res,rules) -> return (Production ps args res rules)
|
|
|
|
instance Binary Info where
|
|
put (AbsCat x) = putWord8 0 >> put x
|
|
put (AbsFun w x y z) = putWord8 1 >> put (w,x,y,z)
|
|
put (ResParam x y) = putWord8 2 >> put (x,y)
|
|
put (ResValue x y) = putWord8 3 >> put (x,y)
|
|
put (ResOper x y) = putWord8 4 >> put (x,y)
|
|
put (ResOverload x y)= putWord8 5 >> put (x,y)
|
|
put (CncCat v w x y z)=putWord8 6 >> put (v,w,x,y,z)
|
|
put (CncFun w x y z) = putWord8 7 >> put (w,x,y,z)
|
|
put (AnyInd x y) = putWord8 8 >> put (x,y)
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> get >>= \x -> return (AbsCat x)
|
|
1 -> get >>= \(w,x,y,z) -> return (AbsFun w x y z)
|
|
2 -> get >>= \(x,y) -> return (ResParam x y)
|
|
3 -> get >>= \(x,y) -> return (ResValue x y)
|
|
4 -> get >>= \(x,y) -> return (ResOper x y)
|
|
5 -> get >>= \(x,y) -> return (ResOverload x y)
|
|
6 -> get >>= \(v,w,x,y,z)->return (CncCat v w x y z)
|
|
7 -> get >>= \(w,x,y,z) -> return (CncFun w x y z)
|
|
8 -> get >>= \(x,y) -> return (AnyInd x y)
|
|
_ -> decodingError
|
|
|
|
instance Binary Location where
|
|
put NoLoc = putWord8 0
|
|
put (Local x y) = putWord8 1 >> put (x,y)
|
|
put (External x y) = putWord8 2 >> put (x,y)
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> return NoLoc
|
|
1 -> get >>= \(x,y) -> return (Local x y)
|
|
2 -> get >>= \(x,y) -> return (External x y)
|
|
|
|
instance Binary a => Binary (L a) where
|
|
put (L x y) = put (x,y)
|
|
get = get >>= \(x,y) -> return (L x y)
|
|
|
|
instance Binary Term where
|
|
put (Vr x) = putWord8 0 >> put x
|
|
put (Cn x) = putWord8 1 >> put x
|
|
put (Con x) = putWord8 2 >> put x
|
|
put (Sort x) = putWord8 3 >> put x
|
|
put (EInt x) = putWord8 4 >> put x
|
|
put (EFloat x) = putWord8 5 >> put x
|
|
put (K x) = putWord8 6 >> put x
|
|
put (Empty) = putWord8 7
|
|
put (App x y) = putWord8 8 >> put (x,y)
|
|
put (Abs x y z) = putWord8 9 >> put (x,y,z)
|
|
put (Meta x) = putWord8 10 >> put x
|
|
put (ImplArg x) = putWord8 11 >> put x
|
|
put (Prod w x y z)= putWord8 12 >> put (w,x,y,z)
|
|
put (Typed x y) = putWord8 13 >> put (x,y)
|
|
put (Example x y) = putWord8 14 >> put (x,y)
|
|
put (RecType x) = putWord8 15 >> put x
|
|
put (R x) = putWord8 16 >> put x
|
|
put (P x y) = putWord8 17 >> put (x,y)
|
|
put (ExtR x y) = putWord8 18 >> put (x,y)
|
|
put (Table x y) = putWord8 19 >> put (x,y)
|
|
put (T x y) = putWord8 20 >> put (x,y)
|
|
put (V x y) = putWord8 21 >> put (x,y)
|
|
put (S x y) = putWord8 22 >> put (x,y)
|
|
put (Let x y) = putWord8 23 >> put (x,y)
|
|
put (Q x) = putWord8 24 >> put x
|
|
put (QC x) = putWord8 25 >> put x
|
|
put (C x y) = putWord8 26 >> put (x,y)
|
|
put (Glue x y) = putWord8 27 >> put (x,y)
|
|
put (EPatt x y z) = putWord8 28 >> put (x,y,z)
|
|
put (EPattType x) = putWord8 29 >> put x
|
|
put (ELincat x y) = putWord8 30 >> put (x,y)
|
|
put (ELin x y) = putWord8 31 >> put (x,y)
|
|
put (FV x) = putWord8 32 >> put x
|
|
put (Alts x y) = putWord8 33 >> put (x,y)
|
|
put (Strs x) = putWord8 34 >> put x
|
|
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> get >>= \x -> return (Vr x)
|
|
1 -> get >>= \x -> return (Cn x)
|
|
2 -> get >>= \x -> return (Con x)
|
|
3 -> get >>= \x -> return (Sort x)
|
|
4 -> get >>= \x -> return (EInt x)
|
|
5 -> get >>= \x -> return (EFloat x)
|
|
6 -> get >>= \x -> return (K x)
|
|
7 -> return (Empty)
|
|
8 -> get >>= \(x,y) -> return (App x y)
|
|
9 -> get >>= \(x,y,z) -> return (Abs x y z)
|
|
10 -> get >>= \x -> return (Meta x)
|
|
11 -> get >>= \x -> return (ImplArg x)
|
|
12 -> get >>= \(w,x,y,z)->return (Prod w x y z)
|
|
13 -> get >>= \(x,y) -> return (Typed x y)
|
|
14 -> get >>= \(x,y) -> return (Example x y)
|
|
15 -> get >>= \x -> return (RecType x)
|
|
16 -> get >>= \x -> return (R x)
|
|
17 -> get >>= \(x,y) -> return (P x y)
|
|
18 -> get >>= \(x,y) -> return (ExtR x y)
|
|
19 -> get >>= \(x,y) -> return (Table x y)
|
|
20 -> get >>= \(x,y) -> return (T x y)
|
|
21 -> get >>= \(x,y) -> return (V x y)
|
|
22 -> get >>= \(x,y) -> return (S x y)
|
|
23 -> get >>= \(x,y) -> return (Let x y)
|
|
24 -> get >>= \x -> return (Q x)
|
|
25 -> get >>= \x -> return (QC x)
|
|
26 -> get >>= \(x,y) -> return (C x y)
|
|
27 -> get >>= \(x,y) -> return (Glue x y)
|
|
28 -> get >>= \(x,y,z) -> return (EPatt x y z)
|
|
29 -> get >>= \x -> return (EPattType x)
|
|
30 -> get >>= \(x,y) -> return (ELincat x y)
|
|
31 -> get >>= \(x,y) -> return (ELin x y)
|
|
32 -> get >>= \x -> return (FV x)
|
|
33 -> get >>= \(x,y) -> return (Alts x y)
|
|
34 -> get >>= \x -> return (Strs x)
|
|
_ -> decodingError
|
|
|
|
instance Binary Patt where
|
|
put (PC x y) = putWord8 0 >> put (x,y)
|
|
put (PP x y) = putWord8 1 >> put (x,y)
|
|
put (PV x) = putWord8 2 >> put x
|
|
put (PW) = putWord8 3
|
|
put (PR x) = putWord8 4 >> put x
|
|
put (PString x) = putWord8 5 >> put x
|
|
put (PInt x) = putWord8 6 >> put x
|
|
put (PFloat x) = putWord8 7 >> put x
|
|
put (PT x y) = putWord8 8 >> put (x,y)
|
|
put (PAs x y) = putWord8 10 >> put (x,y)
|
|
put (PNeg x) = putWord8 11 >> put x
|
|
put (PAlt x y) = putWord8 12 >> put (x,y)
|
|
put (PSeq minx maxx x miny maxy y) = putWord8 13 >> put (minx,maxx,x,miny,maxy,y)
|
|
put (PRep minx maxx x)= putWord8 14 >> put (minx,maxx,x)
|
|
put (PChar) = putWord8 15
|
|
put (PChars x) = putWord8 16 >> put x
|
|
put (PMacro x) = putWord8 17 >> put x
|
|
put (PM x) = putWord8 18 >> put x
|
|
put (PTilde x) = putWord8 19 >> put x
|
|
put (PImplArg x) = putWord8 20 >> put x
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> get >>= \(x,y) -> return (PC x y)
|
|
1 -> get >>= \(x,y) -> return (PP x y)
|
|
2 -> get >>= \x -> return (PV x)
|
|
3 -> return (PW)
|
|
4 -> get >>= \x -> return (PR x)
|
|
5 -> get >>= \x -> return (PString x)
|
|
6 -> get >>= \x -> return (PInt x)
|
|
7 -> get >>= \x -> return (PFloat x)
|
|
8 -> get >>= \(x,y) -> return (PT x y)
|
|
10 -> get >>= \(x,y) -> return (PAs x y)
|
|
11 -> get >>= \x -> return (PNeg x)
|
|
12 -> get >>= \(x,y) -> return (PAlt x y)
|
|
13 -> get >>= \(minx,maxx,x,miny,maxy,y) -> return (PSeq minx maxx x miny maxy y)
|
|
14 -> get >>= \(minx,maxx,x)-> return (PRep minx maxx x)
|
|
15 -> return (PChar)
|
|
16 -> get >>= \x -> return (PChars x)
|
|
17 -> get >>= \x -> return (PMacro x)
|
|
18 -> get >>= \x -> return (PM x)
|
|
19 -> get >>= \x -> return (PTilde x)
|
|
20 -> get >>= \x -> return (PImplArg x)
|
|
_ -> decodingError
|
|
|
|
instance Binary TInfo where
|
|
put TRaw = putWord8 0
|
|
put (TTyped t) = putWord8 1 >> put t
|
|
put (TComp t) = putWord8 2 >> put t
|
|
put (TWild t) = putWord8 3 >> put t
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> return TRaw
|
|
1 -> fmap TTyped get
|
|
2 -> fmap TComp get
|
|
3 -> fmap TWild get
|
|
_ -> decodingError
|
|
|
|
instance Binary Label where
|
|
put (LIdent bs) = putWord8 0 >> put bs
|
|
put (LVar i) = putWord8 1 >> put i
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> fmap LIdent get
|
|
1 -> fmap LVar get
|
|
_ -> decodingError
|
|
|
|
instance Binary BindType where
|
|
put Explicit = putWord8 0
|
|
put Implicit = putWord8 1
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> return Explicit
|
|
1 -> return Implicit
|
|
_ -> decodingError
|
|
|
|
instance Binary Literal where
|
|
put (LStr s) = putWord8 0 >> put s
|
|
put (LInt i) = putWord8 1 >> put i
|
|
put (LFlt d) = putWord8 2 >> put d
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> liftM LStr get
|
|
1 -> liftM LInt get
|
|
2 -> liftM LFlt get
|
|
_ -> decodingError
|
|
|
|
instance Binary Symbol where
|
|
put (SymCat d r) = putWord8 0 >> put (d,r)
|
|
put (SymLit d r) = putWord8 1 >> put (d,r)
|
|
put (SymVar n l) = putWord8 2 >> put (n,l)
|
|
put (SymKS ts) = putWord8 3 >> put ts
|
|
put (SymKP d vs) = putWord8 4 >> put (d,vs)
|
|
put SymBIND = putWord8 5
|
|
put SymSOFT_BIND = putWord8 6
|
|
put SymNE = putWord8 7
|
|
put SymSOFT_SPACE = putWord8 8
|
|
put SymCAPIT = putWord8 9
|
|
put SymALL_CAPIT = putWord8 10
|
|
get = do tag <- getWord8
|
|
case tag of
|
|
0 -> liftM2 SymCat get get
|
|
1 -> liftM2 SymLit get get
|
|
2 -> liftM2 SymVar get get
|
|
3 -> liftM SymKS get
|
|
4 -> liftM2 (\d vs -> SymKP d vs) get get
|
|
5 -> return SymBIND
|
|
6 -> return SymSOFT_BIND
|
|
7 -> return SymNE
|
|
8 -> return SymSOFT_SPACE
|
|
9 -> return SymCAPIT
|
|
10-> return SymALL_CAPIT
|
|
_ -> decodingError
|
|
|
|
--putGFOVersion = mapM_ (putWord8 . fromIntegral . ord) gfoVersion
|
|
--getGFOVersion = replicateM (length gfoVersion) (fmap (chr . fromIntegral) getWord8)
|
|
--putGFOVersion = put gfoVersion
|
|
--getGFOVersion = get :: Get VersionMagic
|
|
|
|
|
|
data VersionTagged a = Tagged {unV::a} | WrongVersion
|
|
|
|
instance Binary a => Binary (VersionTagged a) where
|
|
put (Tagged a) = put (gfoBinVersion,a)
|
|
get = do ver <- get
|
|
if ver==gfoBinVersion
|
|
then fmap Tagged get
|
|
else return WrongVersion
|
|
|
|
instance Functor VersionTagged where
|
|
fmap f (Tagged a) = Tagged (f a)
|
|
fmap f WrongVersion = WrongVersion
|
|
|
|
gfoBinVersion = (b1,b2,b3,b4)
|
|
where [b1,b2,b3,b4] = map (toEnum.fromEnum) gfoVersion :: [Word8]
|
|
|
|
|
|
decodeModule :: MonadIO io => FilePath -> io SourceModule
|
|
decodeModule fpath = liftIO $ check =<< decodeFile' fpath
|
|
where
|
|
check (Tagged m) = return m
|
|
check _ = fail ".gfo file version mismatch"
|
|
|
|
-- | Read just the module header, the returned 'Module' will have an empty body
|
|
decodeModuleHeader :: MonadIO io => FilePath -> io (VersionTagged Module)
|
|
decodeModuleHeader = liftIO . fmap (fmap conv) . decodeFile'
|
|
where
|
|
conv (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) =
|
|
(m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty)
|
|
|
|
encodeModule :: MonadIO io => FilePath -> SourceModule -> io ()
|
|
encodeModule fpath mo = liftIO $ encodeFile fpath (Tagged mo)
|
|
|
|
-- | like 'decodeFile' but adds file name to error message if there was an error
|
|
decodeFile' fpath = addFPath fpath (decodeFile fpath)
|
|
|
|
-- | Adds file name to error message if there was an error,
|
|
-- | but laziness can cause errors to slip through
|
|
addFPath fpath m = m `catch` handle
|
|
where
|
|
handle (ErrorCall msg) = throwIO (ErrorCall (fpath++": "++msg))
|
|
|
|
decodingError = fail "This file was compiled with different version of GF"
|