module GF.GFCC.DataGFCC where

import GF.GFCC.AbsGFCC
import GF.GFCC.PrintGFCC
import GF.Infra.CompactPrint
import GF.Text.UTF8

import Data.Map
import Data.List

-- internal datatypes for GFCC

data GFCC = GFCC {
  absname   :: CId ,
  cncnames  :: [CId] ,
  gflags    :: Map CId String,   -- value of a global flag
  abstract  :: Abstr ,
  concretes :: Map CId Concr
  }

data Abstr = Abstr {
  aflags  :: Map CId String,     -- value of a flag
  funs    :: Map CId (Type,Exp), -- type and def of a fun
  cats    :: Map CId [Hypo],     -- context of a cat
  catfuns :: Map CId [CId]       -- funs to a cat (redundant, for fast lookup)
  }

data Concr = Concr {
  cflags  :: Map CId String,    -- value of a flag
  lins    :: Map CId Term,      -- lin of a fun
  opers   :: Map CId Term,      -- oper generated by subex elim
  lincats :: Map CId Term,      -- lin type of a cat
  lindefs :: Map CId Term,      -- lin default of a cat
  printnames :: Map CId Term,   -- printname of a cat or a fun
  paramlincats :: Map CId Term  -- lin type of cat, with printable param names
  }

statGFCC :: GFCC -> String
statGFCC gfcc = unlines [
  "Abstract\t" ++ pr (absname gfcc), 
  "Concretes\t" ++ unwords (lmap pr (cncnames gfcc)), 
  "Categories\t" ++ unwords (lmap pr (keys (cats (abstract gfcc)))) 
  ]
 where pr (CId s) = s

-- convert parsed grammar to internal GFCC

mkGFCC :: Grammar -> GFCC
mkGFCC (Grm a cs gfs ab@(Abs afls fs cts) ccs) = GFCC {
  absname = a,
  cncnames = cs,
  gflags = fromAscList [(f,v) | Flg f v <- gfs],
  abstract = 
    let
      aflags  = fromAscList [(f,v) | Flg f v <- afls]
      lfuns   = [(fun,(typ,def)) | Fun fun typ def <- fs]
      funs    = fromAscList lfuns
      lcats   = [(c,hyps) | Cat c hyps <- cts]
      cats    = fromAscList lcats
      catfuns = fromAscList 
        [(cat,[f | (f, (DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
    in Abstr aflags funs cats catfuns,
  concretes = fromAscList (lmap mkCnc ccs)
  }
 where
   mkCnc (Cnc lang fls ls ops lincs linds prns params) = (lang, 
    Concr {
     cflags     = fromAscList [(f,v) | Flg f v <- fls],
     lins       = fromAscList [(f,v) | Lin f v <- ls],  
     opers      = fromAscList [(f,v) | Lin f v <- ops],  
     lincats    = fromAscList [(f,v) | Lin f v <- lincs],  
     lindefs    = fromAscList [(f,v) | Lin f v <- linds],  
     printnames = fromAscList [(f,v) | Lin f v <- prns],  
     paramlincats = fromAscList [(f,v) | Lin f v <- params]  
     }
    )

-- convert internal GFCC and pretty-print it

printGFCC :: GFCC -> String
printGFCC gfcc0 = compactPrintGFCC $ printTree $ Grm
  (absname gfcc) 
  (cncnames gfcc)
  [Flg f v | (f,v) <- assocs (gflags gfcc)]
  (Abs
    [Flg f v     | (f,v) <- assocs (aflags (abstract gfcc))]
    [Fun f ty df | (f,(ty,df)) <- assocs (funs (abstract gfcc))]
    [Cat f v     | (f,v) <- assocs (cats (abstract gfcc))]
    )
  [fromCnc lang cnc | (lang,cnc) <- assocs (concretes gfcc)]
 where
   fromCnc lang cnc = Cnc lang 
     [Flg f v | (f,v) <- assocs (cflags cnc)]
     [Lin f v | (f,v) <- assocs (lins cnc)]
     [Lin f v | (f,v) <- assocs (opers cnc)]
     [Lin f v | (f,v) <- assocs (lincats cnc)]
     [Lin f v | (f,v) <- assocs (lindefs cnc)]
     [Lin f v | (f,v) <- assocs (printnames cnc)]
     [Lin f v | (f,v) <- assocs (paramlincats cnc)]
   gfcc = utf8GFCC gfcc0


-- merge two GFCCs; fails is differens absnames; priority to second arg

unionGFCC :: GFCC -> GFCC -> GFCC
unionGFCC one two = case absname one of
  CId "" -> two                  -- extending empty grammar
  n | n == absname two -> one {  -- extending grammar with same abstract
      concretes = Data.Map.union (concretes two) (concretes one),
      cncnames  = Data.List.union (cncnames two) (cncnames one)
    }
  _ -> one   -- abstracts don't match ---- print error msg

emptyGFCC :: GFCC
emptyGFCC = GFCC {
  absname   = CId "",
  cncnames  = [] ,
  gflags    = empty,
  abstract  = error "empty grammar, no abstract",
  concretes = empty
  }


-- default map and filter are for Map here
lmap = Prelude.map
lfilter = Prelude.filter
mmap = Data.Map.map

-- encode idenfifiers and strings in UTF8

utf8GFCC :: GFCC -> GFCC
utf8GFCC gfcc = gfcc {
  concretes = mmap u8concr (concretes gfcc)
  }
 where 
   u8concr cnc = cnc {
     lins = mmap u8term (lins cnc),
     opers = mmap u8term (opers cnc)
     }
   u8term = convertStringsInTerm encodeUTF8

---- TODO: convert identifiers and flags

convertStringsInTerm conv t = case t of
  K (KS s) -> K (KS (conv s))
  W s r    -> W (conv s) (convs r)
  R ts     -> R $ lmap convs ts
  S ts     -> S $ lmap convs ts
  FV ts    -> FV $ lmap convs ts
  P u v    -> P (convs u) (convs v)
  _        -> t
 where
  convs = convertStringsInTerm conv

