content: ----------------------------------------------------------------------
  -- |
  -- 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.Exception(catch,ErrorCall(..),throwIO)
  
  import PGF.Internal(Binary(..),Word8,putWord8,getWord8,encodeFile,decodeFile)
  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 PGF() -- Binary instances
  import PGF.Internal(Literal(..))
  
  -- 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
  
  --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"
  