----------------------------------------------------------------------
-- |
-- Module      : GF.Grammar.Binary
-- Maintainer  : Krasimir Angelov
-- Stability   : (stable)
-- Portability : (portable)
--
-----------------------------------------------------------------------------

module GF.Grammar.Binary(decodeModule,decodeModuleHeader,encodeModule) where

import Prelude hiding (catch)
import Control.Exception(catch,ErrorCall(..),throwIO)

--import Data.Char
import PGF.Internal(Binary(..),Word8,putWord8,getWord8,encodeFile,decodeFile)
--import Control.Monad
import qualified Data.Map as Map
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 = "GF03"

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 SourceGrammar where
  put = put . modules
  get = fmap mGrammar get

instance Binary SourceModInfo 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

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"
{-
decodeModuleHeader fpath = decodeFile_ fpath getVersionedMod
  where
    getVersionedMod = do
      ver <- getGFOVersion
      if ver == gfoVersion
        then do (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) <- get
                return (Just (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty))
        else return Nothing
--}
--{-
decodeModuleHeader fpath = fmap check $ decodeFile' fpath
  where
    check (Tagged (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc)) =
        (Just (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty))
    check _ = Nothing
--}
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"
