module PGF.Raw.Convert (toPGF,fromPGF) where

import PGF.CId
import PGF.Data
import PGF.Raw.Abstract

import Data.Array.IArray
import qualified Data.Map    as Map
import qualified Data.Set    as Set
import qualified Data.IntMap as IntMap

pgfMajorVersion, pgfMinorVersion :: Integer
(pgfMajorVersion, pgfMinorVersion) = (1,0)

-- convert parsed grammar to internal PGF

toPGF :: Grammar -> PGF
toPGF (Grm [
  App "pgf" (AInt v1 : AInt v2 : App a []:cs),
  App "flags"     gfs, 
  ab@(
    App "abstract" [
      App "fun"   fs,
      App "cat"   cts
      ]), 
  App "concrete" ccs
  ]) = let pgf = PGF {
    absname = mkCId a,
    cncnames = [mkCId c | App c [] <- cs],
    gflags = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- gfs],
    abstract = 
     let
      aflags  = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- gfs]
      lfuns   = [(mkCId f,(toType typ,toExp def)) | App f [typ, def] <- fs]
      funs    = Map.fromAscList lfuns
      lcats   = [(mkCId c, Prelude.map toHypo hyps) | App c hyps <- cts]
      cats    = Map.fromAscList lcats
      catfuns = Map.fromAscList 
        [(cat,[f | (f, (DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
     in Abstr aflags funs cats catfuns,
    concretes = Map.fromAscList [(mkCId lang, toConcr pgf ts) | App lang ts <- ccs]
    }
    in pgf
 where

toConcr :: PGF -> [RExp] -> Concr
toConcr pgf rexp = 
  let cnc = foldl add (Concr {cflags       = Map.empty,
                              lins         = Map.empty,
                              opers        = Map.empty,
                              lincats      = Map.empty,
                              lindefs      = Map.empty,
                              printnames   = Map.empty,
                              paramlincats = Map.empty,
                              parser       = Nothing
                             }) rexp
  in cnc
  where
    add :: Concr -> RExp -> Concr
    add cnc (App "flags" ts)     = cnc { cflags = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- ts] }
    add cnc (App "lin" ts)       = cnc { lins = mkTermMap ts }
    add cnc (App "oper" ts)      = cnc { opers = mkTermMap ts }
    add cnc (App "lincat" ts)    = cnc { lincats = mkTermMap ts }
    add cnc (App "lindef" ts)    = cnc { lindefs = mkTermMap ts }
    add cnc (App "printname" ts) = cnc { printnames = mkTermMap ts }
    add cnc (App "param" ts)     = cnc { paramlincats = mkTermMap ts }
    add cnc (App "parser" ts)    = cnc { parser = Just (toPInfo ts) }

toPInfo :: [RExp] -> ParserInfo
toPInfo [App "functions" fs, App "sequences" ss, App "productions" ps,App "categories" (t:cs)] =
  ParserInfo { functions   = functions
             , sequences   = seqs
	     , productions = productions
	     , startCats   = cats
	     , totalCats   = expToInt t
	     }
  where 
    functions   = mkArray (map toFFun fs)
    seqs        = mkArray (map toFSeq ss)
    productions = IntMap.fromList (map toProductionSet ps)
    cats        = Map.fromList [(mkCId c, (map expToInt xs)) | App c xs <- cs]

    toFFun :: RExp -> FFun
    toFFun (App f [App "P" ts,App "R" ls]) = FFun fun prof lins
      where
        fun  = mkCId f
        prof = map toProfile ts
        lins = mkArray [fromIntegral seqid | AInt seqid <- ls]

    toProfile :: RExp -> Profile
    toProfile AMet           = []
    toProfile (App "_A" [t]) = [expToInt t]
    toProfile (App "_U" ts)  = [expToInt t | App "_A" [t] <- ts]

    toFSeq :: RExp -> FSeq
    toFSeq (App "seq" ss) = mkArray [toSymbol s | s <- ss]

    toProductionSet :: RExp -> (FCat,Set.Set Production)
    toProductionSet (App "td" (rt : xs)) = (expToInt rt, Set.fromList (map toProduction xs))
      where 
        toProduction (App "A" (ruleid : at)) = FApply (expToInt ruleid) (map expToInt at)
        toProduction (App "C" [fcat])        = FCoerce (expToInt fcat)

toSymbol :: RExp -> FSymbol
toSymbol (App "P" [n,l]) = FSymCat (expToInt n) (expToInt l)
toSymbol (App "KP" (d:alts)) = FSymTok (toKP d alts)
toSymbol (AStr t) = FSymTok (KS t)

toType :: RExp -> Type
toType e = case e of
  App cat [App "H" hypos, App "X" exps] -> 
    DTyp (map toHypo hypos) (mkCId cat) (map toExp exps) 
  _ -> error $ "type " ++ show e

toHypo :: RExp -> Hypo
toHypo e = case e of
  App x [typ] -> Hyp (mkCId x) (toType typ)
  _ -> error $ "hypo " ++ show e

toExp :: RExp -> Expr
toExp e = case e of
  App "Abs" [App x [], exp] -> EAbs (mkCId x) (toExp exp)
  App "App" [e1,e2] -> EApp (toExp e1) (toExp e2)
  App "Eq" eqs -> EEq [Equ (map toExp ps) (toExp v) | App "E" (v:ps) <- eqs]
  App "Var" [App i []] -> EVar (mkCId i)
  AMet   -> EMeta  0
  AInt i -> ELit (LInt i)
  AFlt i -> ELit (LFlt i)
  AStr i -> ELit (LStr i)
  _ -> error $ "exp " ++ show e

toTerm :: RExp -> Term
toTerm e = case e of
  App "R" es    -> R  (map toTerm es)
  App "S" es    -> S  (map toTerm es)
  App "FV" es   -> FV (map toTerm es)
  App "P" [e,v] -> P  (toTerm e) (toTerm v)
  App "W" [AStr s,v] -> W s (toTerm v)
  App "A" [AInt i] -> V (fromInteger i)
  App f []  -> F (mkCId f)
  AInt i -> C (fromInteger i)
  AMet   -> TM "?"
  App "KP" (d:alts) -> K (toKP d alts)
  AStr s -> K (KS s)
  _ -> error $ "term " ++ show e
  
toKP d alts = KP (toStr d) (map toAlt alts)
  where
    toStr (App "S" vs) = [v | AStr v <- vs]
    toAlt (App "A" [x,y]) = Alt (toStr x) (toStr y)


------------------------------
--- from internal to parser --
------------------------------

fromPGF :: PGF -> Grammar
fromPGF pgf = Grm [
  App "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion
             : App (prCId (absname pgf)) [] : map (flip App [] . prCId) (cncnames pgf)), 
  App "flags" [App (prCId f) [AStr v] | (f,v) <- Map.toList (gflags pgf `Map.union` aflags apgf)],
  App "abstract" [
    App "fun"   [App (prCId f) [fromType t,fromExp d] | (f,(t,d)) <- Map.toList (funs apgf)],
    App "cat"   [App (prCId f) (map fromHypo hs) | (f,hs) <- Map.toList (cats apgf)]
    ],
  App "concrete" [App (prCId lang) (fromConcrete c) | (lang,c) <- Map.toList (concretes pgf)]
  ]
 where
  apgf = abstract pgf
  fromConcrete cnc = [
      App "flags"     [App (prCId f) [AStr v]     | (f,v) <- Map.toList (cflags cnc)],
      App "lin"       [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lins cnc)],
      App "oper"      [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (opers cnc)],
      App "lincat"    [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lincats cnc)],
      App "lindef"    [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lindefs cnc)],
      App "printname" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (printnames cnc)],
      App "param"     [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (paramlincats cnc)]
     ] ++ maybe [] (\p -> [fromPInfo p]) (parser cnc)

fromType :: Type -> RExp
fromType e = case e of
  DTyp hypos cat exps -> 
    App (prCId cat) [
      App "H" (map fromHypo hypos), 
      App "X" (map fromExp exps)] 

fromHypo :: Hypo -> RExp
fromHypo e = case e of
  Hyp x typ -> App (prCId x) [fromType typ]

fromExp :: Expr -> RExp
fromExp e = case e of
  EAbs x exp   -> App "Abs" [App (prCId x) [], fromExp exp]
  EApp e1 e2 -> App "App" [fromExp e1, fromExp e2]
  EVar   x -> App "Var" [App (prCId x) []]
  ELit (LStr s) -> AStr s
  ELit (LFlt d) -> AFlt d
  ELit (LInt i) -> AInt (toInteger i)
  EMeta _  -> AMet ----
  EEq eqs  -> App "Eq" [App "E" (map fromExp (v:ps)) | Equ ps v <- eqs]

fromTerm :: Term -> RExp
fromTerm e = case e of
  R es    -> App "R" (map fromTerm es)
  S es    -> App "S" (map fromTerm es)
  FV es   -> App "FV" (map fromTerm es)
  P e v   -> App "P"  [fromTerm e, fromTerm v]
  W s v   -> App "W" [AStr s, fromTerm v]
  C i     -> AInt (toInteger i)
  TM _    -> AMet
  F f     -> App (prCId f) []
  V i     -> App "A" [AInt (toInteger i)]
  K t     -> fromTokn t

fromTokn :: Tokn -> RExp
fromTokn (KS s)    = AStr s
fromTokn (KP d vs) = App "KP" (str d : [App "A" [str v, str x] | Alt v x <- vs])
 where
   str v = App "S" (map AStr v)

-- ** Parsing info

fromPInfo :: ParserInfo -> RExp
fromPInfo p = App "parser" [
          App "functions"   [fromFFun fun | fun <- elems (functions p)],
          App "sequences"   [fromFSeq seq | seq <- elems (sequences p)],
          App "productions" [fromProductionSet xs  | xs <- IntMap.toList (productions p)],
          App "categories"  (intToExp (totalCats p) : [App (prCId f) (map intToExp xs) | (f,xs) <- Map.toList (startCats p)])
        ]

fromFFun :: FFun -> RExp
fromFFun (FFun fun prof lins) = App (prCId fun) [App "P" (map fromProfile prof), App "R" [intToExp seqid | seqid <- elems lins]]
  where
    fromProfile :: Profile -> RExp
    fromProfile []   = AMet
    fromProfile [x]  = daughter x
    fromProfile args = App "_U" (map daughter args)
    
    daughter n = App "_A" [intToExp n]

fromSymbol :: FSymbol -> RExp
fromSymbol (FSymCat n l) = App "P" [intToExp n, intToExp l]
fromSymbol (FSymTok t)   = fromTokn t

fromFSeq :: FSeq -> RExp
fromFSeq seq = App "seq" [fromSymbol s | s <- elems seq]

fromProductionSet :: (FCat,Set.Set Production) -> RExp
fromProductionSet (cat,xs) = App "td" (intToExp cat : map fromPassive (Set.toList xs))
  where
    fromPassive (FApply ruleid args) = App "A" (intToExp ruleid : map intToExp args)
    fromPassive (FCoerce fcat)       = App "C" [intToExp fcat]

-- ** Utilities

mkTermMap :: [RExp] -> Map.Map CId Term
mkTermMap ts = Map.fromAscList [(mkCId f,toTerm v) | App f [v] <- ts]

mkArray :: IArray a e => [e] -> a Int e
mkArray xs = listArray (0, length xs - 1) xs

expToInt :: Integral a => RExp -> a
expToInt (App "neg" [AInt i]) = fromIntegral (negate i)
expToInt (AInt i) = fromIntegral i

expToStr :: RExp -> String
expToStr (AStr s) = s

intToExp :: Integral a => a -> RExp
intToExp x | x < 0 = App "neg" [AInt (fromIntegral (negate x))]
           | otherwise =  AInt (fromIntegral x)