{-# LANGUAGE ImplicitParams, RankNTypes #-}

module PGF2.Internal(-- * Access the internal structures
                     FId,isPredefFId,
                     FunId,Token,Production(..),PArg(..),Symbol(..),Literal(..),
                     globalFlags, abstrFlags, concrFlags,
                     concrTotalCats, concrCategories, concrProductions,
                     concrTotalFuns, concrFunction,
                     concrTotalSeqs, concrSequence,
                     
                     -- * Building new PGFs in memory
                     build, eAbs, eApp, eMeta, eFun, eVar, eTyped, eImplArg, dTyp, hypo,
                     AbstrInfo, newAbstr, ConcrInfo, newConcr, newPGF,
                     
                     -- * Write an in-memory PGF to a file
                     writePGF
                    ) where

#include <pgf/data.h>

import PGF2
import PGF2.FFI
import PGF2.Expr
import PGF2.Type
import System.IO.Unsafe(unsafePerformIO)
import Foreign
import Foreign.C
import Data.IORef
import Data.Maybe(fromMaybe)
import Data.List(sortBy)
import Control.Exception(Exception,throwIO)
import qualified Data.Map as Map

type Token = String
data Symbol
  = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
  | SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
  | SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int
  | SymKS Token
  | SymKP [Symbol] [([Symbol],[String])]
  | SymBIND                         -- the special BIND token
  | SymNE                           -- non exist
  | SymSOFT_BIND                    -- the special SOFT_BIND token
  | SymSOFT_SPACE                   -- the special SOFT_SPACE token
  | SymCAPIT                        -- the special CAPIT token
  | SymALL_CAPIT                    -- the special ALL_CAPIT token
  deriving (Eq,Ord,Show)
data Production
  = PApply  {-# UNPACK #-} !FunId [PArg]
  | PCoerce {-# UNPACK #-} !FId
  deriving (Eq,Ord,Show)
data PArg = PArg [FId] {-# UNPACK #-} !FId deriving (Eq,Ord,Show)
type FunId = Int
type SeqId = Int
data Literal =
   LStr String                      -- ^ a string constant
 | LInt Int                         -- ^ an integer constant
 | LFlt Double                      -- ^ a floating point constant
 deriving (Eq,Ord,Show)


-----------------------------------------------------------------------
-- Access the internal structures
-----------------------------------------------------------------------

globalFlags :: PGF -> [(String,Literal)]
globalFlags p = unsafePerformIO $ do
  c_flags <- (#peek PgfPGF, gflags) (pgf p)
  flags   <- peekFlags c_flags
  touchPGF p
  return flags

abstrFlags :: PGF -> [(String,Literal)]
abstrFlags p = unsafePerformIO $ do
  c_flags <- (#peek PgfPGF, abstract.aflags) (pgf p)
  flags   <- peekFlags c_flags
  touchPGF p
  return flags

concrFlags :: Concr -> [(String,Literal)]
concrFlags c = unsafePerformIO $ do
  c_flags <- (#peek PgfConcr, cflags) (concr c)
  flags   <- peekFlags c_flags
  touchConcr c
  return flags

peekFlags :: Ptr GuSeq -> IO [(String,Literal)]
peekFlags c_flags = do
  c_len <- (#peek GuSeq, len) c_flags
  peekFlags (c_len :: CInt) (c_flags `plusPtr` (#offset GuSeq, data))
  where
    peekFlags 0     ptr = return []
    peekFlags c_len ptr = do
      name  <- (#peek PgfFlag, name)  ptr >>= peekUtf8CString
      value <- (#peek PgfFlag, value) ptr >>= peekLiteral
      flags <- peekFlags (c_len-1) (ptr `plusPtr` (#size PgfFlag))
      return ((name,value):flags)

peekLiteral :: GuVariant -> IO Literal
peekLiteral p = do
  tag <- gu_variant_tag  p
  ptr <- gu_variant_data p
  case tag of
    (#const PGF_LITERAL_STR) -> do { val <- peekUtf8CString (ptr `plusPtr` (#offset PgfLiteralStr, val));
                                     return (LStr val) }
    (#const PGF_LITERAL_INT) -> do { val <- peek (ptr `plusPtr` (#offset PgfLiteralInt, val));
                                     return (LInt (fromIntegral (val :: CInt))) }
    (#const PGF_LITERAL_FLT) -> do { val <- peek (ptr `plusPtr` (#offset PgfLiteralFlt, val));
                                     return (LFlt (realToFrac (val :: CDouble))) }
    _                        -> error "Unknown literal type in the grammar"

concrTotalCats :: Concr -> FId
concrTotalCats c = unsafePerformIO $ do
  c_total_cats <- (#peek PgfConcr, total_cats) (concr c)
  touchConcr c
  return (fromIntegral (c_total_cats :: CInt))

concrCategories :: Concr -> [(Cat,FId,FId,[String])]
concrCategories c = 
  unsafePerformIO $
    withGuPool $ \tmpPl ->
    allocaBytes (#size GuMapItor) $ \itor -> do
      exn <- gu_new_exn tmpPl
      ref <- newIORef []
      fptr <- wrapMapItorCallback (getCategories ref)
      (#poke GuMapItor, fn) itor fptr
      c_cnccats <- (#peek PgfConcr, cnccats) (concr c)
      gu_map_iter c_cnccats itor exn
      touchConcr c
      freeHaskellFunPtr fptr
      cs <- readIORef ref
      return (reverse cs)
  where
    getCategories ref itor key value exn = do
      names <- readIORef ref
      name  <- peekUtf8CString (castPtr key)
      c_cnccat <- peek (castPtr value)
      c_cats <- (#peek PgfCncCat, cats) c_cnccat
      c_len <- (#peek GuSeq, len) c_cats
      first <- peek (c_cats `plusPtr` (#offset GuSeq, data)) >>= peekFId
      last  <- peek (c_cats `plusPtr` ((#offset GuSeq, data) + (fromIntegral (c_len-1::CSizeT))*(#size PgfCCat*))) >>= peekFId
      c_n_lins <- (#peek PgfCncCat, n_lins) c_cnccat
      arr <- peekArray (fromIntegral (c_n_lins :: CSizeT)) (c_cnccat `plusPtr` (#offset PgfCncCat, labels))
      labels <- mapM peekUtf8CString arr
      writeIORef ref ((name,first,last,labels) : names)

concrProductions :: Concr -> FId -> [Production]
concrProductions c fid = unsafePerformIO $ do
  c_ccats <- (#peek PgfConcr, ccats) (concr c)
  res <- alloca $ \pfid -> do
           poke pfid (fromIntegral fid :: CInt)
           gu_map_find_default c_ccats pfid >>= peek
  if res == nullPtr
    then do touchConcr c
            return []
    else do c_prods <- (#peek PgfCCat, prods) res
            if c_prods == nullPtr
              then do touchConcr c
                      return []
              else do res <- peekSequence (deRef peekProduction) (#size GuVariant) c_prods
                      touchConcr c
                      return res
  where
    peekProduction p = do
      tag <- gu_variant_tag  p
      dt  <- gu_variant_data p
      case tag of
        (#const PGF_PRODUCTION_APPLY) -> do { c_cncfun <- (#peek PgfProductionApply, fun) dt ;
                                              c_funid  <- (#peek PgfCncFun, funid) c_cncfun ;
                                              c_args   <- (#peek PgfProductionApply, args) dt ;
                                              pargs <- peekSequence peekPArg (#size PgfPArg) c_args ;
                                              return (PApply (fromIntegral (c_funid :: CInt)) pargs) }
        (#const PGF_PRODUCTION_COERCE)-> do { c_coerce <- (#peek PgfProductionCoerce, coerce) dt ;
                                              fid <- peekFId c_coerce ;
                                              return (PCoerce fid) }
        _                             -> error "Unknown production type in the grammar"
      where
        peekPArg ptr = do
          c_hypos <- (#peek PgfPArg, hypos) ptr
          hypos <- peekSequence (deRef peekFId) (#size int) c_hypos
          c_ccat <- (#peek PgfPArg, ccat) ptr
          fid  <- peekFId c_ccat
          return (PArg hypos fid)

peekFId c_ccat = do
  c_fid <- (#peek PgfCCat, fid) c_ccat
  return (fromIntegral (c_fid :: CInt))

concrTotalFuns :: Concr -> FunId
concrTotalFuns c = unsafePerformIO $ do
  c_cncfuns <- (#peek PgfConcr, cncfuns) (concr c)
  c_len <- (#peek GuSeq, len) c_cncfuns
  touchConcr c
  return (fromIntegral (c_len :: CSizeT))

concrFunction :: Concr -> FunId -> (Fun,[SeqId])
concrFunction c funid = unsafePerformIO $ do
  c_cncfuns <- (#peek PgfConcr, cncfuns) (concr c)
  c_cncfun <- peek (c_cncfuns `plusPtr` ((#offset GuSeq, data)+funid*(#size PgfCncFun*)))
  c_absfun <- (#peek PgfCncFun, absfun) c_cncfun
  c_name <- (#peek PgfAbsFun, name) c_absfun
  name <- peekUtf8CString c_name
  c_n_lins <- (#peek PgfCncFun, n_lins) c_cncfun
  arr <- peekArray (fromIntegral (c_n_lins :: CSizeT)) (c_cncfun `plusPtr` (#offset PgfCncFun, lins))
  seqs_seq <- (#peek PgfConcr, sequences) (concr c)
  touchConcr c
  let seqs = seqs_seq `plusPtr` (#offset GuSeq, data)
  return (name, map (toSeqId seqs) arr)
  where
    toSeqId seqs seq = minusPtr seq seqs `div` (#size PgfSequence)

concrTotalSeqs :: Concr -> SeqId
concrTotalSeqs c = unsafePerformIO $ do
  seq <- (#peek PgfConcr, sequences) (concr c)
  c_len <- (#peek GuSeq, len) seq
  touchConcr c
  return (fromIntegral (c_len :: CSizeT))

concrSequence :: Concr -> SeqId -> [Symbol]
concrSequence c seqid = unsafePerformIO $ do
  c_sequences <- (#peek PgfConcr, sequences) (concr c)
  let c_sequence = c_sequences `plusPtr` ((#offset GuSeq, data)+seqid*(#size PgfSequence))
  c_syms <- (#peek PgfSequence, syms) c_sequence
  res <- peekSequence (deRef peekSymbol) (#size GuVariant) c_syms
  touchConcr c
  return res
  where
    peekSymbol p = do
      tag <- gu_variant_tag  p
      dt  <- gu_variant_data p
      case tag of
        (#const PGF_SYMBOL_CAT)        -> peekSymbolIdx SymCat dt
        (#const PGF_SYMBOL_LIT)        -> peekSymbolIdx SymLit dt
        (#const PGF_SYMBOL_VAR)        -> peekSymbolIdx SymVar dt
        (#const PGF_SYMBOL_KS)         -> peekSymbolKS dt
        (#const PGF_SYMBOL_KP)         -> peekSymbolKP dt
        (#const PGF_SYMBOL_BIND)       -> return SymBIND
        (#const PGF_SYMBOL_SOFT_BIND)  -> return SymSOFT_BIND
        (#const PGF_SYMBOL_NE)         -> return SymNE
        (#const PGF_SYMBOL_SOFT_SPACE) -> return SymSOFT_SPACE
        (#const PGF_SYMBOL_CAPIT)      -> return SymCAPIT
        (#const PGF_SYMBOL_ALL_CAPIT)  -> return SymALL_CAPIT
        _                              -> error "Unknown symbol type in the grammar"

    peekSymbolIdx constr dt = do
      c_d <- (#peek PgfSymbolIdx, d) dt
      c_r <- (#peek PgfSymbolIdx, r) dt
      return (constr (fromIntegral (c_d :: CInt)) (fromIntegral (c_r :: CInt)))

    peekSymbolKS dt = do
      token <- peekUtf8CString (dt `plusPtr` (#offset PgfSymbolKS, token))
      return (SymKS token)

    peekSymbolKP dt = do
      c_default_form <- (#peek PgfSymbolKP, default_form) dt
      default_form <- peekSequence (deRef peekSymbol) (#size GuVariant) c_default_form
      c_n_forms <- (#peek PgfSymbolKP, n_forms) dt
      forms <- peekForms (c_n_forms :: CSizeT) (dt `plusPtr` (#offset PgfSymbolKP, forms))
      return (SymKP default_form forms)

    peekForms 0   ptr = return []
    peekForms len ptr = do
      c_form <- (#peek PgfAlternative, form) ptr
      form <- peekSequence (deRef peekSymbol) (#size GuVariant) c_form
      c_prefixes <- (#peek PgfAlternative, prefixes) ptr
      prefixes <- peekSequence (deRef peekUtf8CString) (#size GuString*) c_prefixes
      forms <- peekForms (len-1) (ptr `plusPtr` (#size PgfAlternative))
      return ((form,prefixes):forms)

peekSequence peekElem size ptr = do
  c_len <- (#peek GuSeq, len) ptr
  peekElems (c_len :: CSizeT) (ptr `plusPtr` (#offset GuSeq, data))
  where
     peekElems 0   ptr = return []
     peekElems len ptr = do
       e  <- peekElem ptr
       es <- peekElems (len-1) (ptr `plusPtr` size)
       return (e:es)

deRef peekValue ptr = peek ptr >>= peekValue

fidString, fidInt, fidFloat, fidVar, fidStart :: FId
fidString = (-1)
fidInt    = (-2)
fidFloat  = (-3)
fidVar    = (-4)
fidStart  = (-5)

isPredefFId :: FId -> Bool
isPredefFId = (`elem` [fidString, fidInt, fidFloat, fidVar])


-----------------------------------------------------------------------
-- Building new PGFs in memory
-----------------------------------------------------------------------

data Builder s = Builder (Ptr GuPool) Touch
newtype B s a = B a

build :: (forall s . (?builder :: Builder s) => B s a) -> a
build f =
  unsafePerformIO $ do
    pool <- gu_new_pool
    poolFPtr <- newForeignPtr gu_pool_finalizer pool
    let ?builder = Builder pool (touchForeignPtr poolFPtr)
    let B res = f
    return res

eAbs :: (?builder :: Builder s) => BindType -> String -> B s Expr -> B s Expr
eAbs bind_type var (B (Expr body _)) =
  unsafePerformIO $
  alloca $ \pptr -> do
    ptr <- gu_alloc_variant (#const PGF_EXPR_ABS)
                            (#size PgfExprAbs)
                            (#const gu_alignof(PgfExprAbs))
                            pptr pool
    cvar <- newUtf8CString var pool
    (#poke PgfExprAbs, bind_type) ptr (cbind_type :: PgfBindType)
    (#poke PgfExprAbs, id) ptr cvar
    (#poke PgfExprAbs, body) ptr body
    e <- peek pptr
    return (B (Expr e touch))
  where
    (Builder pool touch) = ?builder

    cbind_type =
      case bind_type of
        Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
        Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)

eApp :: (?builder :: Builder s) => B s Expr -> B s Expr -> B s Expr
eApp (B (Expr fun _)) (B (Expr arg _)) =
  unsafePerformIO $
  alloca $ \pptr -> do
    ptr <- gu_alloc_variant (#const PGF_EXPR_APP)
                            (#size PgfExprApp)
                            (#const gu_alignof(PgfExprApp))
                            pptr pool
    (#poke PgfExprApp, fun) ptr fun
    (#poke PgfExprApp, arg) ptr arg
    e <- peek pptr
    return (B (Expr e touch))
  where
    (Builder pool touch) = ?builder

eMeta :: (?builder :: Builder s) => Int -> B s Expr
eMeta id =
  unsafePerformIO $
  alloca $ \pptr -> do
    ptr <- gu_alloc_variant (#const PGF_EXPR_META)
                            (fromIntegral (#size PgfExprMeta))
                            (#const gu_alignof(PgfExprMeta))
                            pptr pool
    (#poke PgfExprMeta, id) ptr (fromIntegral id :: CInt)
    e <- peek pptr
    return (B (Expr e touch))
  where
    (Builder pool touch) = ?builder

eFun :: (?builder :: Builder s) => Fun -> B s Expr
eFun fun =
  unsafePerformIO $
  alloca $ \pptr -> do
    ptr <- gu_alloc_variant (#const PGF_EXPR_FUN)
                            (fromIntegral ((#size PgfExprFun)+utf8Length fun))
                            (#const gu_flex_alignof(PgfExprFun))
                            pptr pool
    pokeUtf8CString fun (ptr `plusPtr` (#offset PgfExprFun, fun))
    e <- peek pptr
    return (B (Expr e touch))
  where
    (Builder pool touch) = ?builder

eVar :: (?builder :: Builder s) => Int -> B s Expr
eVar var =
  unsafePerformIO $
  alloca $ \pptr -> do
    ptr <- gu_alloc_variant (#const PGF_EXPR_VAR)
                            (#size PgfExprVar)
                            (#const gu_alignof(PgfExprVar))
                            pptr pool
    (#poke PgfExprVar, var) ptr (fromIntegral var :: CInt)
    e <- peek pptr
    return (B (Expr e touch))
  where
    (Builder pool touch) = ?builder

eTyped :: (?builder :: Builder s) => B s Expr -> B s Type -> B s Expr
eTyped (B (Expr e _)) (B (Type ty _)) =
  unsafePerformIO $
  alloca $ \pptr -> do
    ptr <- gu_alloc_variant (#const PGF_EXPR_TYPED)
                            (#size PgfExprTyped)
                            (#const gu_alignof(PgfExprTyped))
                            pptr pool
    (#poke PgfExprTyped, expr) ptr e
    (#poke PgfExprTyped, type) ptr ty
    e <- peek pptr
    return (B (Expr e touch))
  where
    (Builder pool touch) = ?builder

eImplArg :: (?builder :: Builder s) => B s Expr -> B s Expr
eImplArg (B (Expr e _)) =
  unsafePerformIO $
  alloca $ \pptr -> do
    ptr <- gu_alloc_variant (#const PGF_EXPR_IMPL_ARG)
                            (#size PgfExprImplArg)
                            (#const gu_alignof(PgfExprImplArg))
                            pptr pool
    (#poke PgfExprImplArg, expr) ptr e
    e <- peek pptr
    return (B (Expr e touch))
  where
    (Builder pool touch) = ?builder

hypo :: BindType -> CId -> B s Type -> (B s Hypo)
hypo bind_type var (B ty) = B (bind_type,var,ty)

dTyp :: (?builder :: Builder s) => [B s Hypo] -> Cat -> [B s Expr] -> B s Type
dTyp hypos cat es =
  unsafePerformIO $ do
    ptr <- gu_malloc_aligned pool 
                             ((#size PgfType)+n_exprs*(#size GuVariant))
                             (#const gu_flex_alignof(PgfType))
    c_hypos <- newHypos hypos pool
    c_cat <- newUtf8CString cat pool
    (#poke PgfType, hypos)   ptr c_hypos
    (#poke PgfType, cid)     ptr c_cat
    (#poke PgfType, n_exprs) ptr n_exprs
    pokeArray (ptr `plusPtr` (#offset PgfType, exprs)) [e | B (Expr e _) <- es]
    return (B (Type ptr touch))
  where
    (Builder pool touch) = ?builder
    n_exprs = fromIntegral (length es) :: CSizeT

newHypos :: [B s Hypo] -> Ptr GuPool -> IO (Ptr GuSeq)
newHypos hypos pool = do
  c_hypos <- gu_make_seq (#size PgfHypo) (fromIntegral (length hypos)) pool
  pokeHypos (c_hypos `plusPtr` (#offset GuSeq, data)) hypos
  return c_hypos
  where
    pokeHypos ptr []                                  = return ()
    pokeHypos ptr (B (bind_type,var,Type ty _):hypos) = do
      c_var <- newUtf8CString var pool
      (#poke PgfHypo, bind_type) ptr (cbind_type :: PgfBindType)
      (#poke PgfHypo, cid)       ptr c_var
      (#poke PgfHypo, type)      ptr ty
      pokeHypos (ptr `plusPtr` (#size PgfHypo)) hypos
      where
        cbind_type =
          case bind_type of
            Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
            Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)


data AbstrInfo = AbstrInfo (Ptr GuSeq) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsCat)) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsFun)) (Ptr PgfAbsFun) Touch

newAbstr :: (?builder :: Builder s) => [(String,Literal)] ->
                                       [(Cat,[B s Hypo],Float)] ->
                                       [(Fun,B s Type,Int,Float)] ->
                                       AbstrInfo
newAbstr aflags cats funs = unsafePerformIO $ do
  c_aflags <- newFlags aflags pool
  (c_cats,abscats) <- newAbsCats (sortByFst3 cats) pool
  (c_funs,absfuns) <- newAbsFuns (sortByFst4 funs) pool
  c_abs_lin_fun <- newAbsLinFun
  return (AbstrInfo c_aflags c_cats abscats c_funs absfuns c_abs_lin_fun touch)
  where
    (Builder pool touch) = ?builder

    newAbsCats values pool = do
      c_seq <- gu_make_seq (#size PgfAbsCat) (fromIntegral (length values)) pool
      abscats <- pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) Map.empty values
      return (c_seq,abscats)
      where
        pokeElems ptr abscats []     = return abscats
        pokeElems ptr abscats (x:xs) = do
          abscats <- pokeAbsCat ptr abscats x
          pokeElems (ptr `plusPtr` (#size PgfAbsCat)) abscats xs

    pokeAbsCat ptr abscats (name,hypos,prob) = do
      c_name  <- newUtf8CString name pool
      c_hypos <- newHypos hypos pool
      (#poke PgfAbsCat, name) ptr c_name
      (#poke PgfAbsCat, context) ptr c_hypos
      (#poke PgfAbsCat, prob) ptr (realToFrac prob :: CFloat)
      return (Map.insert name ptr abscats)

    newAbsFuns values pool = do
      c_seq <- gu_make_seq (#size PgfAbsFun) (fromIntegral (length values)) pool
      absfuns <- pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) Map.empty values
      return (c_seq,absfuns)
      where
        pokeElems ptr absfuns []     = return absfuns
        pokeElems ptr absfuns (x:xs) = do
          absfuns <- pokeAbsFun ptr absfuns x
          pokeElems (ptr `plusPtr` (#size PgfAbsFun)) absfuns xs

    pokeAbsFun ptr absfuns (name,B (Type c_ty _),arity,prob) = do
      pfun <- gu_alloc_variant (#const PGF_EXPR_FUN)
                               (fromIntegral ((#size PgfExprFun)+utf8Length name))
                               (#const gu_flex_alignof(PgfExprFun))
                               (ptr `plusPtr` (#offset PgfAbsFun, ep.expr)) pool
      let c_name = (pfun `plusPtr` (#offset PgfExprFun, fun))
      pokeUtf8CString name c_name
      (#poke PgfAbsFun, name) ptr c_name
      (#poke PgfAbsFun, type) ptr c_ty
      (#poke PgfAbsFun, arity) ptr (fromIntegral arity :: CInt)
      (#poke PgfAbsFun, defns) ptr nullPtr
      (#poke PgfAbsFun, ep.prob) ptr (realToFrac prob :: CFloat)
      return (Map.insert name ptr absfuns)

    newAbsLinFun = do
      ptr <- gu_malloc_aligned pool
                               (#size PgfAbsFun)
                               (#const gu_alignof(PgfAbsFun))
      c_wild <- newUtf8CString "_" pool
      c_ty   <- gu_malloc_aligned pool
                                  (#size PgfType)
                                  (#const gu_alignof(PgfType))
      (#poke PgfType, hypos)   c_ty nullPtr
      (#poke PgfType, cid)     c_ty c_wild
      (#poke PgfType, n_exprs) c_ty (0 :: CSizeT)
      (#poke PgfAbsFun, name)    ptr c_wild
      (#poke PgfAbsFun, type)    ptr c_ty
      (#poke PgfAbsFun, arity)   ptr (0 :: CSizeT)
      (#poke PgfAbsFun, defns)   ptr nullPtr
      (#poke PgfAbsFun, ep.prob) ptr (- log 0 :: CFloat)
      (#poke PgfAbsFun, ep.expr) ptr nullPtr
      return ptr


data ConcrInfo = ConcrInfo (Ptr GuSeq) (Ptr GuMap) (Ptr GuMap) (Ptr GuSeq) (Ptr GuSeq) (Ptr GuMap)

newConcr :: (?builder :: Builder s) => AbstrInfo ->
                                       [(String,Literal)] ->       -- ^ Concrete syntax flags
                                       [(String,String)] ->        -- ^ Printnames
                                       [(FId,[FunId])] ->          -- ^ Lindefs
                                       [(FId,[FunId])] ->          -- ^ Linrefs
                                       [(FId,[Production])] ->     -- ^ Productions
                                       [(Fun,[SeqId])] ->          -- ^ Concrete functions   (must be sorted by Fun)
                                       [[Symbol]] ->               -- ^ Sequences            (must be sorted)
                                       [(Cat,FId,FId,[String])] -> -- ^ Concrete categories
                                       ConcrInfo
newConcr (AbstrInfo _ _ abscats  _ absfuns c_abs_lin_fun _) cflags printnames lindefs linrefs prods cncfuns sequences cnccats = unsafePerformIO $ do
  c_cflags <- newFlags cflags pool
  c_printname <- newMap (#size GuString) gu_string_hasher newUtf8CString 
                        (#size GuString) (pokeString pool)
                        printnames pool
  c_seqs <- newSequence (#size PgfSequence) pokeSequence sequences pool
  let seqs_ptr = c_seqs `plusPtr` (#offset GuSeq, data)
  c_cncfuns <- newSequence (#size PgfCncFun*) (pokeCncFun seqs_ptr) (zip [0..] cncfuns) pool
  let funs_ptr = c_cncfuns `plusPtr` (#offset GuSeq, data)
  c_ccats <- gu_make_map (#size int) gu_int_hasher
                         (#size PgfCCat*) gu_null_struct
                         (#const GU_MAP_DEFAULT_INIT_SIZE)
                         pool
  mapM_ (addLindefs c_ccats funs_ptr) lindefs
  mapM_ (addLinrefs c_ccats funs_ptr) linrefs
  mapM_ (addProductions c_ccats funs_ptr) prods
  c_cnccats <- newMap (#size GuString) gu_string_hasher newUtf8CString (#size PgfCncCat*) (pokeCncCat c_ccats) (map (\v@(k,_,_,_) -> (k,v)) cnccats) pool
  return (ConcrInfo c_cflags c_printname c_ccats c_cncfuns c_seqs c_cnccats)
  where
    (Builder pool touch) = ?builder

    pokeCncFun seqs_ptr ptr cncfun = do
      c_cncfun <- newCncFun absfuns nullPtr cncfun pool
      poke ptr c_cncfun

    pokeSequence c_seq syms = do
      c_syms <- newSymbols syms pool
      (#poke PgfSequence, syms) c_seq c_syms
      (#poke PgfSequence, idx)  c_seq nullPtr

    addLindefs c_ccats funs_ptr (fid,funids) = do
      c_ccat <- getCCat c_ccats fid pool
      c_funs <- newSequence (#size PgfCncFun*) (pokeFunId funs_ptr) funids pool
      (#poke PgfCCat, lindefs) c_ccat c_funs

    addLinrefs c_ccats funs_ptr (fid,funids) = do
      c_ccat <- getCCat c_ccats fid pool
      c_funs <- newSequence (#size PgfCncFun*) (pokeFunId funs_ptr) funids pool
      (#poke PgfCCat, linrefs) c_ccat c_funs

    addProductions c_ccats funs_ptr (fid,prods) = do
      c_ccat  <- getCCat c_ccats fid pool
      c_prods <- gu_make_seq (#size PgfProduction) (fromIntegral (length prods)) pool
      (#poke PgfCCat, prods) c_ccat c_prods

    pokeFunId funs_ptr ptr funid = do
      let c_fun = funs_ptr `plusPtr` (funid * (#size PgfCncFun))
      (#poke PgfCncFun, absfun) c_fun c_abs_lin_fun
      poke ptr c_fun

    pokeCncCat c_ccats ptr (name,start,end,labels) = do
      let n_lins = fromIntegral (length labels) :: CSizeT
      c_cnccat <- gu_malloc_aligned pool 
                                    ((#size PgfCncCat)+n_lins*(#size GuString))
                                    (#const gu_flex_alignof(PgfCncCat))
      case Map.lookup name abscats of
        Just c_abscat -> (#poke PgfCncCat, abscat) c_cnccat c_abscat
        Nothing       -> throwIO (PGFError ("The category "++name++" is not in the abstract syntax"))
      c_ccats <- newSequence (#size PgfCCat*) pokeFId [start..end] pool
      (#poke PgfCncCat, cats) c_cnccat c_ccats
      pokeLabels (c_cnccat `plusPtr` (#offset PgfCncCat, labels)) labels
      poke ptr c_cnccat
      where
        pokeFId ptr fid = do
          c_ccat <- getCCat c_ccats fid pool
          poke ptr c_ccat
          
        pokeLabels ptr []     = return []
        pokeLabels ptr (l:ls) = do
          c_l <- newUtf8CString l pool
          poke ptr c_l
          pokeLabels (ptr `plusPtr` (#size GuString)) ls


newPGF :: (?builder :: Builder s) => [(String,Literal)] ->
                                     AbsName ->
                                     AbstrInfo ->
                                     [(ConcName,ConcrInfo)] ->
                                     B s PGF
newPGF gflags absname (AbstrInfo c_aflags c_cats _ c_funs _ c_abs_lin_fun _) concrs =
  unsafePerformIO $ do
    ptr <- gu_malloc_aligned pool
                             (#size PgfPGF)
                             (#const gu_alignof(PgfPGF))
    c_gflags  <- newFlags gflags pool
    c_absname <- newUtf8CString absname pool
    let c_abstr = ptr `plusPtr` (#offset PgfPGF, abstract)
    c_concrs  <- newSequence (#size PgfConcr) (pokeConcr c_abstr) concrs pool
    (#poke PgfPGF, major_version)   ptr (2 :: (#type uint16_t))
    (#poke PgfPGF, minor_version)   ptr (0 :: (#type uint16_t))
    (#poke PgfPGF, gflags)          ptr c_gflags
    (#poke PgfPGF, abstract.name)   ptr c_absname
    (#poke PgfPGF, abstract.aflags) ptr c_aflags
    (#poke PgfPGF, abstract.funs)   ptr c_funs
    (#poke PgfPGF, abstract.cats)   ptr c_cats
    (#poke PgfPGF, abstract.abs_lin_fun) ptr c_abs_lin_fun
    (#poke PgfPGF, concretes)       ptr c_concrs
    (#poke PgfPGF, pool)            ptr pool
    return (B (PGF ptr touch))
  where
    (Builder pool touch) = ?builder

    pokeConcr c_abstr ptr (name, ConcrInfo c_cflags c_printnames c_ccats c_cncfuns c_seqs c_cnccats) = do
      c_name <- newUtf8CString name pool
      (#poke PgfConcr, name)       ptr c_name
      (#poke PgfConcr, abstr)      ptr c_abstr
      (#poke PgfConcr, cflags)     ptr c_cflags
      (#poke PgfConcr, printnames) ptr c_printnames
      (#poke PgfConcr, ccats)      ptr c_ccats
      (#poke PgfConcr, cncfuns)    ptr c_cncfuns
      (#poke PgfConcr, sequences)  ptr c_seqs
      (#poke PgfConcr, cnccats)    ptr c_cnccats
      (#poke PgfConcr, pool)       ptr nullPtr


newFlags :: [(String,Literal)] -> Ptr GuPool -> IO (Ptr GuSeq)
newFlags flags pool = newSequence (#size PgfFlag) pokeFlag (sortByFst flags) pool
  where
    pokeFlag c_flag (name,value) = do
      c_name  <- newUtf8CString name pool
      c_value <- newLiteral value pool
      (#poke PgfFlag, name)  c_flag c_name
      (#poke PgfFlag, value) c_flag c_value

newLiteral :: Literal -> Ptr GuPool -> IO GuVariant
newLiteral (LStr val) pool =
  alloca $ \pptr -> do
    ptr <- gu_alloc_variant (#const PGF_LITERAL_STR)
                            (fromIntegral ((#size PgfLiteralStr)+utf8Length val))
                            (#const gu_flex_alignof(PgfLiteralStr))
                            pptr pool
    pokeUtf8CString val (ptr `plusPtr` (#offset PgfLiteralStr, val))
    peek pptr
newLiteral (LInt val) pool =
  alloca $ \pptr -> do
    ptr <- gu_alloc_variant (#const PGF_LITERAL_INT)
                            (fromIntegral (#size PgfLiteralInt))
                            (#const gu_alignof(PgfLiteralInt))
                            pptr pool
    (#poke PgfLiteralInt, val) ptr (fromIntegral val :: CInt)
    peek pptr
newLiteral (LFlt val) pool =
  alloca $ \pptr -> do
    ptr <- gu_alloc_variant (#const PGF_LITERAL_FLT)
                            (fromIntegral (#size PgfLiteralFlt))
                            (#const gu_alignof(PgfLiteralFlt))
                            pptr pool
    (#poke PgfLiteralFlt, val) ptr (realToFrac val :: CDouble)
    peek pptr

newCncFun absfuns seqs_ptr (funid,(fun,seqids)) pool =
  do let c_absfun = fromMaybe nullPtr (Map.lookup fun absfuns)
         c_ep     = if c_absfun == nullPtr
                      then nullPtr
                      else c_absfun `plusPtr` (#offset PgfAbsFun, ep)
         n_lins   = fromIntegral (length seqids) :: CSizeT
     ptr <- gu_malloc_aligned pool
                              ((#size PgfCncFun)+n_lins*(#size PgfSequence*))
                              (#const gu_flex_alignof(PgfCncFun))
     (#poke PgfCncFun, absfun) ptr c_absfun
     (#poke PgfCncFun, ep)     ptr c_ep
     (#poke PgfCncFun, funid)  ptr (funid :: CInt)
     (#poke PgfCncFun, n_lins) ptr n_lins
     pokeSequences seqs_ptr (ptr `plusPtr` (#offset PgfCncFun, lins)) seqids
     return ptr
  where
    pokeSequences seqs_ptr ptr []             = return ()
    pokeSequences seqs_ptr ptr (seqid:seqids) = do
      poke ptr (seqs_ptr `plusPtr` (seqid * (#size PgfSequence)))
      pokeSequences seqs_ptr (ptr `plusPtr` (#size PgfSequence*)) seqids

getCCat c_ccats fid pool =
  alloca $ \pfid -> do
    poke pfid (fromIntegral fid :: CInt)
    ptr <- gu_map_find_default c_ccats pfid
    c_ccat <- peek ptr
    if c_ccat /= nullPtr
      then return c_ccat
      else do c_ccat <- gu_malloc_aligned pool
                                          (#size PgfCCat)
                                          (#const gu_alignof(PgfCCat))
              (#poke PgfCCat, cnccat) c_ccat nullPtr
              (#poke PgfCCat, lindefs) c_ccat nullPtr
              (#poke PgfCCat, linrefs) c_ccat nullPtr
              (#poke PgfCCat, n_synprods) c_ccat (0 :: CSizeT)
              (#poke PgfCCat, prods) c_ccat nullPtr
              (#poke PgfCCat, viterbi_prob) c_ccat (0 :: CFloat)
              (#poke PgfCCat, fid) c_ccat fid
              (#poke PgfCCat, conts) c_ccat nullPtr
              (#poke PgfCCat, answers) c_ccat nullPtr
              ptr <- gu_map_insert c_ccats pfid
              poke ptr c_ccat
              return c_ccat

newSymbol :: Symbol -> Ptr GuPool -> IO GuVariant
newSymbol (SymCat d r)     pool = alloca $ \pptr -> do
                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_CAT)
                                                            (fromIntegral (#size PgfSymbolCat))
                                                            (#const gu_alignof(PgfSymbolCat))
                                                            pptr pool
                                    (#poke PgfSymbolCat, d) ptr (fromIntegral d :: CInt)
                                    (#poke PgfSymbolCat, r) ptr (fromIntegral r :: CInt)
                                    peek pptr
newSymbol (SymLit d r)     pool = alloca $ \pptr -> do
                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_LIT)
                                                            (fromIntegral (#size PgfSymbolLit))
                                                            (#const gu_alignof(PgfSymbolLit))
                                                            pptr pool
                                    (#poke PgfSymbolLit, d) ptr (fromIntegral d :: CInt)
                                    (#poke PgfSymbolLit, r) ptr (fromIntegral r :: CInt)
                                    peek pptr
newSymbol (SymVar d r)     pool = alloca $ \pptr -> do
                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_VAR)
                                                            (fromIntegral (#size PgfSymbolVar))
                                                            (#const gu_alignof(PgfSymbolVar))
                                                            pptr pool
                                    (#poke PgfSymbolVar, d) ptr (fromIntegral d :: CInt)
                                    (#poke PgfSymbolVar, r) ptr (fromIntegral r :: CInt)
                                    peek pptr
newSymbol (SymKS t)        pool = alloca $ \pptr -> do
                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_KS)
                                                            (fromIntegral ((#size PgfSymbolKS)+utf8Length t))
                                                            (#const gu_flex_alignof(PgfSymbolKS))
                                                            pptr pool
                                    pokeUtf8CString t (ptr `plusPtr` (#offset PgfSymbolKS, token))
                                    peek pptr
newSymbol (SymKP def alts) pool = alloca $ \pptr -> do
                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_KP)
                                                            (fromIntegral ((#size PgfSymbolKP)+(length alts * (#size PgfAlternative))))
                                                            (#const gu_flex_alignof(PgfSymbolKP))
                                                            pptr pool
                                    c_def <- newSymbols def pool
                                    (#poke PgfSymbolKP, default_form) ptr c_def
                                    pokeAlternatives (ptr `plusPtr` (#offset PgfSymbolKP, forms)) alts pool
                                    peek pptr
newSymbol SymBIND          pool = alloca $ \pptr -> do
                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_BIND)
                                                            (fromIntegral (#size PgfSymbolBIND))
                                                            (#const gu_alignof(PgfSymbolBIND))
                                                            pptr pool
                                    peek pptr
newSymbol SymNE            pool = alloca $ \pptr -> do
                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_NE)
                                                            (fromIntegral (#size PgfSymbolNE))
                                                            (#const gu_alignof(PgfSymbolNE))
                                                            pptr pool
                                    peek pptr
newSymbol SymSOFT_BIND     pool = alloca $ \pptr -> do
                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_SOFT_BIND)
                                                            (fromIntegral (#size PgfSymbolBIND))
                                                            (#const gu_alignof(PgfSymbolBIND))
                                                            pptr pool
                                    peek pptr
newSymbol SymSOFT_SPACE    pool = alloca $ \pptr -> do
                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_SOFT_SPACE)
                                                            (fromIntegral (#size PgfSymbolBIND))
                                                            (#const gu_alignof(PgfSymbolBIND))
                                                            pptr pool
                                    peek pptr
newSymbol SymCAPIT         pool = alloca $ \pptr -> do
                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_CAPIT)
                                                            (fromIntegral (#size PgfSymbolCAPIT))
                                                            (#const gu_alignof(PgfSymbolCAPIT))
                                                            pptr pool
                                    peek pptr
newSymbol SymALL_CAPIT     pool = alloca $ \pptr -> do
                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_ALL_CAPIT)
                                                            (fromIntegral (#size PgfSymbolCAPIT))
                                                            (#const gu_alignof(PgfSymbolCAPIT))
                                                            pptr pool
                                    peek pptr

newSymbols syms pool = newSequence (#size PgfSymbol) pokeSymbol syms pool
  where
    pokeSymbol p_sym sym = do
      c_sym <- newSymbol sym pool
      poke p_sym c_sym

pokeAlternatives ptr []                     pool = return ()
pokeAlternatives ptr ((syms,prefixes):alts) pool = do
  c_syms     <- newSymbols syms pool
  c_prefixes <- newSequence (#size GuString) (pokeString pool) prefixes pool
  (#poke PgfAlternative, form)     ptr c_syms
  (#poke PgfAlternative, prefixes) ptr c_prefixes
  pokeAlternatives (ptr `plusPtr` (#size PgfAlternative)) alts pool

pokeString pool c_elem str = do
  c_str <- newUtf8CString str pool
  poke c_elem c_str

newSequence :: CSizeT -> (Ptr a -> v -> IO ()) -> [v] -> Ptr GuPool -> IO (Ptr GuSeq)
newSequence elem_size pokeElem values pool = do
  c_seq <- gu_make_seq elem_size (fromIntegral (length values)) pool
  pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) values
  return c_seq
  where
    pokeElems ptr []     = return ()
    pokeElems ptr (x:xs) = do
      pokeElem  ptr x
      pokeElems (ptr `plusPtr` (fromIntegral elem_size)) xs

newMap key_size hasher newKey elem_size pokeElem values pool = do
  map <- gu_make_map key_size hasher
                     elem_size gu_null_struct
                     (#const GU_MAP_DEFAULT_INIT_SIZE)
                     pool
  insert map values pool
  return map
  where
    insert map []                  pool = return ()
    insert map ((key,elem):values) pool = do
      c_key  <- newKey key pool
      c_elem <- gu_map_insert map c_key
      pokeElem c_elem elem
      insert map values pool


writePGF :: FilePath -> PGF -> IO ()
writePGF fpath p = do
  pool <- gu_new_pool
  exn <- gu_new_exn pool
  withCString fpath $ \c_fpath ->
    pgf_write (pgf p) c_fpath exn
  touchPGF p
  failed <- gu_exn_is_raised exn
  if failed
    then do is_errno <- gu_exn_caught exn gu_exn_type_GuErrno
            if is_errno
              then do perrno <- (#peek GuExn, data.data) exn
                      errno  <- peek perrno
                      gu_pool_free pool
                      ioError (errnoToIOError "writePGF" (Errno errno) Nothing (Just fpath))
              else do gu_pool_free pool
                      throwIO (PGFError "The grammar cannot be stored")
    else do gu_pool_free pool
            return ()

sortByFst  = sortBy (\(x,_)     (y,_)     -> compare x y)
sortByFst3 = sortBy (\(x,_,_)   (y,_,_)   -> compare x y)
sortByFst4 = sortBy (\(x,_,_,_) (y,_,_,_) -> compare x y)