diff options
Diffstat (limited to 'src/compiler')
| -rw-r--r-- | src/compiler/GF/Grammar/Printer.hs | 5 | ||||
| -rw-r--r-- | src/compiler/SimpleEditor/Convert.hs | 70 |
2 files changed, 69 insertions, 6 deletions
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index 08d70928c..9f8ee45b9 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -13,6 +13,7 @@ module GF.Grammar.Printer , ppGrammar
, ppModule
, ppJudgement
+ , ppParams
, ppTerm
, ppPatt
, ppValue
@@ -20,6 +21,7 @@ module GF.Grammar.Printer , ppLocation
, ppQIdent
, ppMeta
+ , getAbs
) where
import GF.Infra.Ident
@@ -107,7 +109,7 @@ ppJudgement q (id, AbsFun ptype _ pexp poper) = ppJudgement q (id, ResParam pparams _) =
text "param" <+> ppIdent id <+>
(case pparams of
- Just (L _ ps) -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps))
+ Just (L _ ps) -> equals <+> ppParams q ps
_ -> empty) <+> semi
ppJudgement q (id, ResValue pvalue) = empty
ppJudgement q (id, ResOper ptype pexp) =
@@ -304,6 +306,7 @@ ppBind (Implicit,v) = braces (ppIdent v) ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y
+ppParams q ps = fsep (intersperse (char '|') (map (ppParam q) ps))
ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt)
ppLocation :: FilePath -> Location -> Doc
diff --git a/src/compiler/SimpleEditor/Convert.hs b/src/compiler/SimpleEditor/Convert.hs index 93844ea18..037b04986 100644 --- a/src/compiler/SimpleEditor/Convert.hs +++ b/src/compiler/SimpleEditor/Convert.hs @@ -5,17 +5,19 @@ import Control.Monad(unless,foldM,ap) import qualified Data.Map as Map import qualified Data.ByteString.Char8 as BS(pack) import Text.JSON(encode,makeObj) +import Text.PrettyPrint(render) --import GF.Compile.GetGrammar (getSourceModule) --import GF.Infra.Option(noOptions) import GF.Infra.Ident(showIdent) --import GF.Infra.UseIO(appIOE) 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 SimpleEditor.Syntax +import SimpleEditor.Syntax as S import SimpleEditor.JSON @@ -25,7 +27,7 @@ parseModule (path,source) = Left (Pn l c,msg) -> makeObj [prop "error" msg, prop "location" (show l++":"++show c)] - Right mod -> case convAbstract mod of + Right mod -> case convModule mod of Ok g -> makeObj [prop "converted" g] Bad msg -> makeObj [prop "parsed" msg] @@ -33,11 +35,19 @@ parseModule (path,source) = 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) - (cats,funs) <- convJments (jments src) + (cats,funs) <- convAbsJments (jments src) let startcat = head (cats++["-"]) -- !!! return $ Grammar (convId modid) extends (Abstract startcat cats funs) [] @@ -45,9 +55,9 @@ convExtends = mapM convExtend convExtend (modid,MIAll) = return (convId modid) convExtend _ = fail "unsupported module extension" -convJments jments = foldM convJment ([],[]) (Map.toList jments) +convAbsJments jments = foldM convAbsJment ([],[]) (Map.toList jments) -convJment (cats,funs) (name,jment) = +convAbsJment (cats,funs) (name,jment) = case jment of AbsCat octx -> do unless (null (maybe [] unLoc octx)) $ fail "category with context" @@ -69,3 +79,53 @@ convSimpleType (Vr id) = return (convId id) convSimpleType t = fail "unsupported type" convId = showIdent + +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 (convId modid) extends abs [conc] + +convOpens = mapM convOpen + +convOpen o = + case o of + OSimple id -> return (convId id) + _ -> fail "unsupported module open" + + +data CncJment = Pa S.Param | LC Lincat | Op Oper | Li Lin + +convCncJments = mapM convCncJment . Map.toList + +convCncJment (name,jment) = + case jment of + ResParam ops _ -> + return $ Pa $ Param i (maybe "" (render . ppParams q . unLoc) ops) + CncCat (Just (L _ typ)) Nothing Nothing _ -> + 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)) + CncFun _ (Just ldef) Nothing _ -> + 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" |