content: {-# LANGUAGE NoMonomorphismRestriction #-}
  module SimpleEditor.Convert where
  
  import Control.Monad(unless,foldM,ap,mplus)
  import Data.List(sortBy)
  import Data.Function(on)
  import qualified Data.Map as Map
  import Text.JSON(makeObj) --encode
  import GF.Text.Pretty(render,(<+>))
  
  import qualified Data.ByteString.UTF8 as UTF8(fromString)
  
  import GF.Infra.Option(optionsGFO)
  import GF.Infra.Ident(showIdent,ModuleName(..))
  import GF.Grammar.Grammar
  import GF.Grammar.Printer(ppParams,ppTerm,getAbs,TermPrintQual(..))
  import GF.Grammar.Parser(runP,pModDef)
  import GF.Grammar.Lexer(Posn(..))
  import GF.Data.ErrM
  import PGF.Internal(Literal(LStr))
  
  import SimpleEditor.Syntax as S
  import SimpleEditor.JSON
  
  
  parseModule (path,source) =
     (path.=) $
     case runP pModDef (UTF8.fromString source) of
       Left (Pn l c,msg) ->
           makeObj ["error".=msg, "location".= show l++":"++show c]
       Right mod -> case convModule mod of
                      Ok g -> makeObj ["converted".=g]
                      Bad msg -> makeObj ["parsed".=msg]
  
  {-
  convAbstractFile path =
      appIOE (fmap encode . convAbstract =<< getSourceModule noOptions path)
  -}
  
  convModule m@(modid,src) =
    if isModAbs src
    then convAbstract m
    else if isModCnc src
         then convConcrete m
         else fail "An abstract or concrete syntax module was expected"
  
  convAbstract (modid,src) =
    do unless (isModAbs src) $ fail "Abstract syntax expected"
       unless (isCompleteModule src) $ fail "A complete abstract syntax expected"
       extends <- convExtends (mextend src)
       (cats0,funs0) <- convAbsJments (jments src)
       let cats = reverse cats0
           funs = reverse funs0
           flags = optionsGFO (mflags src)
           startcat =
             case lookup "startcat" flags of
               Just (LStr cat) -> cat
               _               -> "-"
       return $ Grammar (convModId modid) extends (Abstract startcat cats funs) []
  
  convExtends = mapM convExtend
  convExtend (modid,MIAll) = return (convModId modid)
  convExtend _ = fail "unsupported module extension"
  
  convAbsJments jments = foldM convAbsJment ([],[]) (jmentList jments)
  
  convAbsJment (cats,funs) (name,jment) =
    case jment of
      AbsCat octx -> do unless (null (maybe [] unLoc octx)) $
                               fail "category with context"
                        let cat = convId name
                        return (cat:cats,funs)
      AbsFun (Just lt) _ oeqns _ -> do unless (null (maybe [] id oeqns)) $
                                              fail "function with equations"
                                       let f = convId name
                                       typ <- convType (unLoc lt)
                                       let fun = Fun f typ
                                       return (cats,fun:funs)
      _ -> fail $ "unsupported judgement form: "++show jment
  
  convType (Prod _ _ t1 t2) = (:) `fmap` convSimpleType t1 `ap` convType t2
  convType t = (:[]) `fmap` convSimpleType t
  
  
  convSimpleType (Vr id) = return (convId id)
  convSimpleType t = fail "unsupported type"
  
  convId = showIdent
  convModId (MN m) = convId m
  
  convConcrete (modid,src) =
    do unless (isModCnc src) $ fail "Concrete syntax expected"
       unless (isCompleteModule src) $ fail "A complete concrete syntax expected"
       extends <- convExtends (mextend src)
       opens <- convOpens (mopens src)
       js <- convCncJments (jments src)
       let ps  = [p  | Pa p <-js]
           lcs = [lc | LC lc<-js]
           os  = [o  | Op o <-js]
           ls  = [l  | Li l <-js]
           langcode = "" -- !!!
           conc = Concrete langcode opens ps lcs os ls
           abs = Abstract "-" [] [] -- dummy
       return $ Grammar (convModId modid) extends abs [conc]
  
  convOpens = mapM convOpen
  
  convOpen o =
    case o of
      OSimple id -> return (convModId id)
      _ -> fail "unsupported module open"
  
  
  data CncJment = Pa S.Param | LC Lincat | Op Oper | Li Lin | Ignored
  
  convCncJments = mapM convCncJment . jmentList
  
  convCncJment (name,jment) =
    case jment of
      ResParam ops _ ->
        return $ Pa $ Param i (maybe "" (render . ppParams q . unLoc) ops)
      ResValue _ -> return Ignored
      CncCat (Just (L _ typ)) Nothing Nothing pprn _ -> -- ignores printname !!
        return $ LC $ Lincat i (render $ ppTerm q 0 typ)
      ResOper oltyp (Just lterm) -> return $ Op $ Oper lhs rhs
        where
          lhs = i++maybe "" ((" : "++) . render . ppTerm q 0 . unLoc) oltyp
          rhs = render (" ="<+>ppTerm q 0 (unLoc lterm))
      ResOverload [] defs -> return $ Op $ Oper lhs rhs
        where
          lhs = i
          rhs = render $ " = overload"<+>ppTerm q 0 r
          r =  R [(lab,(Just ty,fu)) | (L _ ty,L _ fu) <-defs]
          lab = ident2label name
      CncFun _ (Just ldef) pprn _ -> -- ignores printname !!
        do let (xs,e') = getAbs (unLoc ldef)
               lin = render $ ppTerm q 0 e'
           args <- mapM convBind xs
           return $ Li $ Lin i args lin
      _ -> fail $ "unsupported judgement form: "++show jment
    where
      i = convId name
      q = Unqualified
  
  convBind (Explicit,v) = return $ convId v
  convBind (Implicit,v) = fail "implicit binding not supported"
  
  jmentList = sortBy (compare `on` (jmentLocation.snd)) . Map.toList
  
  jmentLocation jment =
    case jment of
      AbsCat ctxt      -> fmap loc ctxt
      AbsFun ty _ _ _  -> fmap loc ty
      ResParam ops _   -> fmap loc ops
      CncCat ty _ _ _ _ ->fmap loc ty
      ResOper ty rhs   -> fmap loc rhs `mplus` fmap loc ty
      CncFun _ rhs _ _ -> fmap loc rhs
      _ -> Nothing
  
  
  loc (L l _) = l
  