module GF.Grammar.JSON( TermPrintQual(..),
                        grammar2json,
                        term2json, json2term,
                        patt2json, json2patt
                      ) where

import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.Printer(TermPrintQual(..))
import Text.JSON
import Text.JSON.Types
import Control.Monad (forM,(>=>),liftM2,guard)
import Control.Applicative ((<|>))
import qualified Data.Map as Map
import Data.Maybe (catMaybes)

grammar2json :: Grammar -> JSValue
grammar2json gr =
  makeObj [(showIdent mn, mi2json mi) | (MN mn,mi) <- modules gr]

mi2json mi = makeObj [("type", mtype2json (mtype mi))
                     ,("jments",makeObj (map jment2json (Map.toList (jments mi))))
                     ]

mtype2json MTAbstract     = showJSON "abstract"
mtype2json MTResource     = showJSON "resource"
mtype2json (MTConcrete _) = showJSON "concrete"
mtype2json MTInterface    = showJSON "interface"
mtype2json (MTInstance _) = showJSON "instance"

jment2json (id,info) = (showIdent id, info2json info)

info2json (AbsCat mb_ctxt) =
  case mb_ctxt of
    Nothing         -> makeObj []
    Just (L _ ctxt) -> makeObj [("context", showJSON (map hypo2json ctxt))]
info2json (AbsFun mb_ty mb_eqs) =
  (makeObj . catMaybes)
     [ fmap (\(L _ ty) -> ("abstype",term2json ty)) mb_ty
     , fmap (\(a,_)   -> ("arity",showJSON a)) mb_eqs
     , fmap (\(_,eqs) -> ("equations",showJSON (map (\(L _ eq) -> equation2json eq) eqs))) mb_eqs
     ]
info2json (ResParam mb_params _) =
  makeObj [("params", case mb_params of
                         Nothing           -> JSArray []
                         Just (L _ params) -> showJSON (map param2json params))]
info2json (ResValue (L _ ty) _) =
  makeObj [("paramtype",term2json ty)]
info2json (ResOper mb_ty mb_def) =
  (makeObj . catMaybes)
     [ fmap (\(L _ ty) -> ("opertype",term2json ty)) mb_ty
     , fmap (\(L _ def) -> ("operdef",term2json def)) mb_def
     ]
info2json (ResOverload mns overloads) =
  makeObj
     [ ("extends",showJSON mns)
     , ("overloads",showJSON (map overload2json overloads))
     ]
info2json (CncCat mb_ty mb_lindef mb_linref mb_pnm _) =
  (makeObj . catMaybes)
     [ fmap (\(L _ ty) -> ("lintype",term2json ty)) mb_ty
     , fmap (\(L _ def) -> ("lindef",term2json def)) mb_lindef
     , fmap (\(L _ ref) -> ("linref",term2json ref)) mb_linref
     , fmap (\(L _ prn) -> ("printname",term2json prn)) mb_pnm
     ]
info2json (CncFun _ mb_lin mb_pnm _) =
  (makeObj . catMaybes)
     [ fmap (\(L _ lin) -> ("lin",term2json lin)) mb_lin
     , fmap (\(L _ prn) -> ("printname",term2json prn)) mb_pnm
     ]
info2json (AnyInd _ mn) = showJSON mn

hypo2json (bt,x,ty) =
  makeObj [("implicit", showJSON (bt==Implicit)), ("var", showJSON x), ("type", term2json ty)]

equation2json (ps,t) =
  makeObj [("patts", showJSON (map patt2json ps)), ("term", term2json t)]

param2json (id, ctxt) =
  makeObj [("id", showJSON id), ("context", showJSON (map hypo2json ctxt))]

overload2json (L _ ty,L _ def) =
  makeObj
     [ ("opertype",term2json ty)
     , ("operdef",term2json def)
     ]

term2json :: Term -> JSValue
term2json (Vr v) = makeObj [("vr", showJSON v)]
term2json (Cn v) = makeObj [("cn", showJSON v)]
term2json (Con v) = makeObj [("con", showJSON v)]
term2json (Sort v) = makeObj [("sort", showJSON v)]
term2json (EInt n) = showJSON n
term2json (EFloat f) = showJSON f
term2json (K s) = showJSON s
term2json Empty = JSArray []
term2json (App t1 t2) = makeObj [("fun", term2json t1), ("arg", term2json t2)]
term2json (Abs bt x t) = makeObj [("implicit", showJSON (bt==Implicit)), ("var", showJSON x), ("body", term2json t)]
term2json (Meta id) = makeObj [("metaid", showJSON id)]
term2json (ImplArg t) = makeObj [("implarg", term2json t)]
term2json (Prod bt v t1 t2) = makeObj [("implicit", showJSON (bt==Implicit)), ("var", showJSON v), ("hypo", term2json t1), ("res", term2json t2)]
term2json (Typed t ty) = makeObj [("term", term2json t), ("type", term2json ty)]
term2json (Example t s) = makeObj [("term", term2json t), ("example", showJSON s)]
term2json (RecType lbls) = makeObj [("rectype", makeObj (map toRow lbls))]
                              where toRow (l,_,t) = (showLabel l, term2json t)
term2json (R lbls) = makeObj [("record", makeObj (map toRow lbls))]
                              where toRow (l,(_,t)) = (showLabel l, term2json t)
term2json (P t proj) = makeObj [("project", term2json t), ("label", showJSON (showLabel proj))]
term2json (ExtR t1 t2) = makeObj [("term", term2json t1), ("ext", term2json t2)]
term2json (Table t1 t2) = makeObj [("tblhypo", term2json t1), ("tblres", term2json t2)]
term2json (T _ cs) = makeObj [("tblcases", showJSON [(patt2json p, term2json t) | (p,t) <- cs])]
term2json (V ty ts) = makeObj [("tbltype", term2json ty), ("tblvalues", showJSON (map term2json ts))]
term2json (S t1 t2) = makeObj [("select", term2json t1), ("key", term2json t2)]
term2json (Let (v,(_,t1)) t2) = makeObj [("letvar", showJSON v), ("letdef", term2json t1), ("term", term2json t2)]
term2json (Q (m,id))  = makeObj [("mod",showJSON m),("q",  showJSON id)]
term2json (QC (m,id)) = makeObj [("mod",showJSON m),("qc", showJSON id)]
term2json (C t1 t2) = showJSON ((flatten t1 . flatten t2) [])
    where
      flatten Empty     = id
      flatten (C t1 t2) = flatten t1 . flatten t2
      flatten t         = (term2json t :)
term2json (Glue t1 t2) = makeObj [("glue1",term2json t1),("glue2", term2json t2)]
term2json (EPattType t) = makeObj [("patttype",term2json t)]
term2json (ELincat id t) = makeObj [("lincat",showJSON id), ("term",term2json t)]
term2json (ELin id t) = makeObj [("lin",showJSON id), ("term",term2json t)]
term2json (FV ts) = makeObj [("variants",showJSON (map term2json ts))]
term2json (Markup tag attrs children) = makeObj [ ("tag",showJSON tag)
                                                , ("attrs",showJSON (map (\(attr,val) -> (showJSON attr,term2json val)) attrs))
                                                , ("children",showJSON (map (term2json . unLoc) children))
                                                ]
term2json (Reset ctl ct t qid) =
  makeObj ([("ctl",showJSON ctl)]++maybe [] (\t->[("ct",term2json t)]) ct++[("term",term2json t), ("qid",showJSON qid)])
term2json (Alts def alts) = makeObj [("def",term2json def), ("alts",showJSON (map (\(t1,t2) -> (term2json t1, term2json t2)) alts))]
term2json (Strs ts) = makeObj [("strs",showJSON (map term2json ts))]
term2json (EPatt _ _ p) = makeObj [("epatt",patt2json p)]


json2term o  = Vr      <$> o!:"vr"
    <|>  curry Q       <$> o!:"mod" <*> o!:"cn"
    <|>  curry QC      <$> o!:"mod" <*> o!:"con"
    <|>        Cn      <$> o!:"cn"
    <|>        Con     <$> o!:"con"
    <|>        Sort    <$> o!:"sort"
    <|>        EInt    <$> readJSON o
    <|>        EFloat  <$> readJSON o
    <|>        K       <$> readJSON o
    <|>        App     <$> o!<"fun" <*> o!<"arg"
    <|>        Abs     <$> fmap toBindType (o!:"implicit") <*> o!:"var" <*> o!<"body"
    <|>        Meta    <$> o!:"metaid"
    <|>        ImplArg <$> o!<"implarg"
    <|>        Prod    <$> fmap toBindType (o!:"implicit") <*> o!:"var" <*> o!<"hypo" <*> o!<"res"
    <|>        Typed   <$> o!<"term" <*> o!<"type"
    <|>        Example <$> o!<"term" <*> o!:"example"
    <|>        RecType <$> (o!:"rectype" >>= \o -> mapM fromRow  (assocsJSObject o))
    <|>        R       <$> (o!:"record"  >>= \o -> mapM fromRow' (assocsJSObject o))
    <|>        P       <$> o!<"project" <*> fmap readLabel (o!:"label")
    <|>        ExtR    <$> o!<"term" <*> o!<"ext"
    <|>        Table   <$> o!<"tblhypo" <*> o!<"tblres"
    <|>        do o  <- readJSON o
                  cs <- valFromObj "tblcases" o
                  cs <- forM cs $ \(p,t) -> do
                          p <- json2patt p
                          t <- json2term t
                          return (p,t)
                  return (T TRaw cs)
    <|>        do o  <- readJSON o
                  ty <- valFromObj "tbltype" o >>= json2term
                  ts <- valFromObj "tblvalues" o >>= mapM json2term
                  return (V ty ts)
    <|>        S       <$> o!<"select" <*> o!<":.key"
    <|>  (\v t1 -> Let (v,(Nothing,t1))) <$> o!:"letvar" <*> o!<"letdef" <*> o!<"term"
    <|>      mkC       <$> (readJSON o >>= mapM json2term)
    <|>        Glue    <$> o!<"glue1" <*> o!<"glue2"
    <|>      EPattType <$> o!<"patttype"
    <|>        ELincat <$> o!:"lincat" <*> o!<"term"
    <|>        ELin    <$> o!:"lin" <*> o!<"term"
    <|>        FV      <$> (o!:"variants" >>= mapM json2term)
    <|>        Markup  <$> (o!:"tag") <*>
                           (o!:"attrs" >>= mapM (\(attr,val) -> fmap ((,)attr) (json2term val))) <*>
                           (o!:"children" >>= mapM (fmap noLoc . json2term))
    <|>        Reset   <$> o!:"ctl" <*> fmap Just (o!<"ct") <*> o!<"term" <*> o!:"qid"
    <|>        Reset   <$> o!:"ctl" <*> pure Nothing <*> o!<"term" <*> o!:"qid"
    <|>        Alts    <$> (o!<"def") <*> (o!:"alts" >>= mapM (\(x,y) -> liftM2 (,) (json2term x) (json2term y)))
    <|>        Strs    <$> (o!:"strs" >>= mapM json2term)
    where
      fromRow  (lbl, jsvalue) = do value <- json2term jsvalue
                                   return (readLabel lbl,[],value)

      fromRow' (lbl, jsvalue) = do value <- json2term jsvalue
                                   return (readLabel lbl,(Nothing,value))

      toBindType True  = Implicit
      toBindType False = Explicit

      mkC []     = Empty
      mkC (t:ts) = foldl C t ts

patt2json (PC id ps)     = makeObj [("pc",showJSON id),("args",showJSON (map patt2json ps))]
patt2json (PP (mn,id) ps) = makeObj [("mod",showJSON mn),("pc",showJSON id),("args",showJSON (map patt2json ps))]
patt2json (PV id)        = makeObj [("pv",showJSON id)]
patt2json (PR lbls)      = makeObj (("record", showJSON True) : map toRow lbls)
                               where toRow (l,t) = (showLabel l, patt2json t)
patt2json (PString s)    = showJSON s
patt2json (PInt n)       = showJSON n
patt2json (PFloat d)     = showJSON d
patt2json (PT ty p)      = makeObj [("type", term2json ty), ("patt", patt2json p)]
patt2json (PAs id p)     = makeObj [("as", showJSON id), ("patt", patt2json p)]
patt2json (PImplArg p)   = makeObj [("implarg", patt2json p)]
patt2json (PTilde t)     = makeObj [("tilde", term2json t)]
patt2json (PNeg p)       = makeObj [("neg", patt2json p)]
patt2json (PAlt p1 p2)   = makeObj [("alt1", patt2json p1), ("alt2", patt2json p2)]
patt2json (PSeq min1 max1 p1 min2 max2 p2)
                           = makeObj [("min1",  showJSON min1)
                                     ,("max1",  showJSON max1)
                                     ,("patt1", patt2json p1)
                                     ,("min2",  showJSON min2)
                                     ,("max2",  showJSON max2)
                                     ,("patt2", patt2json p2)
                                     ]
patt2json (PRep min max p)=makeObj [("min",  showJSON min)
                                   ,("max",  showJSON max)
                                   ,("patt", patt2json p)
                                   ]
patt2json PChar          = makeObj [("char",showJSON True)]
patt2json (PChars cs)    = makeObj [("chars",showJSON cs)]
patt2json (PMacro id)    = makeObj [("macro",showJSON id)]
patt2json (PM (mn,id))   = makeObj [("mod",showJSON mn), ("macro",showJSON id)]

json2patt :: JSValue -> Result Patt
json2patt o = PP <$> (liftM2 (\mn id -> (mn,id)) (o!:"mod") (o!:"pc")) <*> (o!:"args" >>= mapM json2patt)
    <|>       PC <$> (o!:"pc") <*> (o!:"args" >>= mapM json2patt)
    <|>       PV <$> (o!:"pv")
    <|> (const PR) <$> (o!:"record" >>= guard) <*> mapM fromRow (assocsJSObject o)
    <|>  PString <$> readJSON o
    <|>  PInt    <$> readJSON o
    <|>  PFloat  <$> readJSON o
    <|>  PT      <$> o!<"type" <*> o!>"patt"
    <|>  PAs     <$> o!:"as" <*> o!>"patt"
    <|>  PImplArg<$> o!>"implarg"
    <|>  PTilde  <$> o!<"tilde"
    <|>  PNeg    <$> o!>"neg"
    <|>  PAlt    <$> o!>"alt1" <*> o!>"alt2"
    <|>  PSeq    <$> o!:"min1" <*> o!:"max1" <*> o!>"patt1" <*> o!:"min2" <*> o!:"max2" <*> o!>"patt2"
    <|>  PRep    <$> o!:"min" <*> o!:"max" <*> o!>"rep"
    <|>  (o!:"char" >>= guard >> return PChar)
    <|>  PChars  <$> o!:"chars"
    <|>  PM      <$> liftM2 (,) (o!:"mod") (o!:"macro")
    <|>  PMacro  <$> o!:"macro"
    where
      fromRow  (lbl, jsvalue) = do patt <- json2patt jsvalue
                                   return (readLabel lbl,patt)


showLabel :: Label -> String
showLabel (LIdent s) = showRawIdent s
showLabel (LVar i)   = '$':show i

readLabel ('$':s) = LVar (read s)
readLabel s = LIdent (rawIdentS s)

(!<) :: JSValue -> String -> Result Term
obj !< key = maybe (fail $ "(!<): could not find key: " ++ key)
            json2term
            (lookup key (assocsJSObject obj))

(!>) :: JSValue -> String -> Result Patt
obj !> key = maybe (fail $ "(!>): could not find key: " ++ key)
             json2patt
             (lookup key (assocsJSObject obj))

(!:) :: JSON a => JSValue -> String -> Result a
obj !: key = maybe (fail $ "(!:): could not find key: " ++ key)
             readJSON
             (lookup key (assocsJSObject obj))

assocsJSObject :: JSValue -> [(String, JSValue)]
assocsJSObject (JSObject o) = fromJSObject o
assocsJSObject (JSArray  _) = fail $ "assocsJSObject: Expected a JSON object, found an Array"
assocsJSObject  jsvalue     = fail $ "assocsJSObject: Expected a JSON object, found " ++ show jsvalue
