----------------------------------------------------------------------
-- |
-- 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(..))

-- 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,jments) <- get
              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc 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 Rule where
  put (Rule v w x y z) = put (v,w,x,y,z)
  get = get >>= \(v,w,x,y,z) -> return (Rule v w x y z)

instance Binary Info where
  put (AbsCat x)       = putWord8 0 >> put x
  put (AbsFun x y)     = putWord8 1 >> put (x,y)
  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 >>= \(x,y)     -> return (AbsFun x y)
             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 (Markup x y z)= putWord8 33 >> put (x,y,z)
  put (Reset w x y z)=putWord8 34 >> put (w,x,y,z)
  put (Alts x y)    = putWord8 35 >> put (x,y)
  put (Strs x)      = putWord8 36 >> 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,z) -> return (Markup x y z)
             34 -> get >>= \(w,x,y,z)->return (Reset w x y z)
             35 -> get >>= \(x,y)   -> return (Alts x y)
             36 -> 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 (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)
             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 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"
