---------------------------------------------------------------------- -- | -- 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.Internal(Symbol(..)) -- Please change this every time when the GFO format is changed gfoVersion = "GF04" instance Binary Ident where put id = put (ident2utf8 id) get = do bs <- get if bs == BS.pack "_" then return identW else return (identC (rawIdentC bs)) instance Binary ModuleName where put (MN id) = put id get = fmap MN get 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,mseqs 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 Production where put (Production res funid args) = put (res,funid,args) get = do res <- get funid <- get args <- get return (Production res funid args) instance Binary PMCFG where put (PMCFG prods funs) = put (prods,funs) get = do prods <- get funs <- get return (PMCFG prods funs) 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) = putWord8 3 >> put x 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 -> return (ResValue x) 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) = putWord8 28 >> put x 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 put (Error x) = putWord8 35 >> 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 -> return (EPatt x) 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) 35 -> get >>= \x -> return (Error 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 x y) = putWord8 13 >> put (x,y) put (PRep x) = putWord8 14 >> put 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 >>= \(x,y) -> return (PSeq x y) 14 -> get >>= \x -> return (PRep 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 n l) = putWord8 0 >> put (n,l) put (SymLit n l) = putWord8 1 >> put (n,l) 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"