-- | Read PGF files created with GF 3.5 and a few older releases
module PGF.OldBinary(getPGF,getPGF',version) where

import PGF.CId
import PGF.Data
import PGF.Optimize
import Data.Binary
import Data.Binary.Get
import Data.Array.IArray
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified Data.Set as Set
import Control.Monad

pgfMajorVersion, pgfMinorVersion :: Word16
version@(pgfMajorVersion, pgfMinorVersion) = (1,0)

getPGF = do v1 <- getWord16be
            v2 <- getWord16be
            let v=(v1,v2)
            if v==version 
              then getPGF'
              else decodingError ("version "++show v++"/="++show version)

getPGF'=do gflags <- getFlags
           absname <- getCId
           abstract <- getAbstract
           concretes <- getMap getCId getConcr
           return $ updateProductionIndices $
                      (PGF{ gflags=gflags
                          , absname=absname, abstract=abstract
                          , concretes=concretes
                          })

getCId = liftM CId get

getAbstract =
        do aflags <- getFlags
           funs <- getMap getCId getFun
           cats <- getMap getCId getCat
           return (Abstr{ aflags=aflags
                        , funs=fmap (\(w,x,y,z) -> (w,x,fmap (flip (,) []) y,z)) funs
                        , cats=fmap (\(x,y) -> (x,y,0)) cats
                        })
getFun :: Get (Type,Int,Maybe [Equation],Double)
getFun = (,,,) `fmap` getType `ap` get `ap` getMaybe (getList getEquation) `ap` get

getCat :: Get ([Hypo],[(Double, CId)])
getCat = getPair (getList getHypo) (getList (getPair get getCId))

getFlags = getMap getCId getLiteral

getConcr =
        do cflags      <- getFlags
           printnames  <- getMap getCId get
           (scnt,seqs) <- getList' getSequence
           (fcnt,cncfuns) <- getList' getCncFun
           lindefs     <- get
           productions <- getIntMap (getSet getProduction)
           cnccats     <- getMap getCId getCncCat
           totalCats   <- get
           let rseq    = listToArray [SymCat 0 0]
               rfun    = CncFun (mkCId "linref") (listToArray [scnt])
               linrefs = IntMap.fromList [(i,[fcnt])|i<-[0..totalCats-1]]
           return (Concr{ cflags=cflags, printnames=printnames
                        , sequences=toArray (scnt+1,seqs++[rseq])
                        , cncfuns=toArray (fcnt+1,cncfuns++[rfun])
                        , lindefs=lindefs, linrefs=linrefs
                        , productions=productions
                        , pproductions = IntMap.empty
                        , lproductions = Map.empty
                        , lexicon = IntMap.empty
                        , cnccats=cnccats, totalCats=totalCats
                        })

getExpr =
        do tag <- getWord8
           case tag of
             0 -> liftM3 EAbs getBindType getCId getExpr
             1 -> liftM2 EApp getExpr getExpr
             2 -> liftM  ELit getLiteral
             3 -> liftM  EMeta get
             4 -> liftM  EFun getCId
             5 -> liftM  EVar get
             6 -> liftM2 ETyped getExpr getType
             7 -> liftM  EImplArg getExpr
             _ -> decodingError "getExpr"

getPatt =
        do tag <- getWord8
           case tag of
             0 -> liftM2 PApp getCId (getList getPatt)
             1 -> liftM  PVar getCId
             2 -> liftM2 PAs getCId getPatt
             3 -> return PWild
             4 -> liftM  PLit getLiteral
             5 -> liftM  PImplArg getPatt
             6 -> liftM  PTilde getExpr
             _ -> decodingError "getPatt"

getEquation = liftM2 Equ (getList getPatt) getExpr

getType = liftM3 DTyp (getList getHypo) getCId (getList getExpr)
getHypo = (,,) `fmap` getBindType `ap` getCId `ap` getType

getBindType =
        do tag <- getWord8
           case tag of
             0 -> return Explicit
             1 -> return Implicit
             _ -> decodingError "getBindType"

getCncFun = liftM2 CncFun getCId (getArray get)

getCncCat = liftM3 CncCat get get (getArray get)

getSequence = listToArray `fmap` getSymbols

getSymbols = concat `fmap` getList getSymbol

getSymbol :: Get [Symbol]
getSymbol =
        do tag <- getWord8
           case tag of
             0 -> (:[]) `fmap` liftM2 SymCat get get
             1 -> (:[]) `fmap` liftM2 SymLit get get
             2 -> (:[]) `fmap` liftM2 SymVar get get
             3 -> liftM  (map SymKS) get
             4 -> (:[]) `fmap` liftM2 SymKP (getList getTokenSymbol) getAlternatives
             _ -> decodingError ("getSymbol "++show tag)

getAlternatives = getList (getPair (getList getTokenSymbol) get)
                  :: Get [([Symbol],[String])]
getTokenSymbol = fmap SymKS get

--getTokens = unwords `fmap` get

getPArg = get >>= \(hypos,fid) -> return (PArg (zip (repeat fidVar) hypos) fid)

getProduction =
        do tag <- getWord8
           case tag of
             0 -> liftM2 PApply  get (getList getPArg)
             1 -> liftM  PCoerce get
             _ -> decodingError "getProduction"

getLiteral =
        do tag <- getWord8
           case tag of
             0 -> liftM  LStr get
             1 -> liftM  LInt get
             2 -> liftM  LFlt get
             _ -> decodingError "getLiteral"


getArray :: IArray a e => Get e -> Get (a Int e)
getArray get1 = toArray `fmap` getList' get1

toArray (n,xs) = listArray (0::Int,n-1) xs
listToArray xs = toArray (length xs,xs)

getArray2 :: (IArray a1 (a2 Int e), IArray a2 e) => Get e -> Get (a1 Int (a2 Int e))
getArray2 get1 = getArray (getArray get1)

getList get1 = snd `fmap` getList' get1

getList' get1 = do n <- get :: Get Int
                   xs <- replicateM n get1
                   return (n,xs)

getMaybe get1 =
    do isJust <- get
       if isJust then fmap Just get1 else return Nothing

getMap getK getV = Map.fromDistinctAscList `fmap` getList (getPair getK getV)
getIntMap getV = IntMap.fromDistinctAscList `fmap` getList (getPair get getV)
getSet getV = Set.fromDistinctAscList `fmap` getList getV

getPair get1 get2 = (,) `fmap` get1 `ap` get2

decodingError explain = fail $ "Unable to read PGF file ("++explain++")"