GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 11:42:49 -06:00
Code Issues Packages Projects Releases Wiki Activity

gfse: text mode improvements

Browse Source 
+ Preserve the startcat flag.
+ Preserve judgement order when possible (GF's parser does not preserve order
  and does not record exact source locations, only line numbers)
This commit is contained in:
hallgren
2012-02-27 16:50:06 +00:00
parent 686fcca9a4
commit c41974422f
1 changed files with 26 additions and 6 deletions
Download Patch File Download Diff File Expand all files Collapse all files

32
src/compiler/SimpleEditor/Convert.hs
View File

@@ -1,14 +1,16 @@
{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE NoMonomorphismRestriction #-}
module SimpleEditor.Convert where module SimpleEditor.Convert where
import Control.Monad(unless,foldM,ap) import Control.Monad(unless,foldM,ap,mplus)
import Data.List(sortBy)
import Data.Function(on)
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as BS(pack) import qualified Data.ByteString.Char8 as BS(pack)
import Text.JSON(encode,makeObj) import Text.JSON(encode,makeObj)
import Text.PrettyPrint(render) import Text.PrettyPrint(render)
--import GF.Compile.GetGrammar (getSourceModule) --import GF.Compile.GetGrammar (getSourceModule)
--import GF.Infra.Option(noOptions) import GF.Infra.Option(optionsGFO)
import GF.Infra.Ident(showIdent) import GF.Infra.Ident(showIdent)
--import GF.Infra.UseIO(appIOE) --import GF.Infra.UseIO(appIOE)
import GF.Grammar.Grammar import GF.Grammar.Grammar
@@ -47,15 +49,18 @@ convAbstract (modid,src) =
do unless (isModAbs src) $ fail "Abstract syntax expected" do unless (isModAbs src) $ fail "Abstract syntax expected"
unless (isCompleteModule src) $ fail "A complete abstract syntax expected" unless (isCompleteModule src) $ fail "A complete abstract syntax expected"
extends <- convExtends (mextend src) extends <- convExtends (mextend src)
(cats,funs) <- convAbsJments (jments src) (cats0,funs0) <- convAbsJments (jments src)
let startcat = head (cats++["-"]) -- !!! let cats = reverse cats0
funs = reverse funs0
flags = optionsGFO (mflags src)
startcat = maybe "-" id $ lookup "startcat" flags
return $ Grammar (convId modid) extends (Abstract startcat cats funs) [] return $ Grammar (convId modid) extends (Abstract startcat cats funs) []
convExtends = mapM convExtend convExtends = mapM convExtend
convExtend (modid,MIAll) = return (convId modid) convExtend (modid,MIAll) = return (convId modid)
convExtend _ = fail "unsupported module extension" convExtend _ = fail "unsupported module extension"
convAbsJments jments = foldM convAbsJment ([],[]) (Map.toList jments) convAbsJments jments = foldM convAbsJment ([],[]) (jmentList jments)
convAbsJment (cats,funs) (name,jment) = convAbsJment (cats,funs) (name,jment) =
case jment of case jment of
@@ -105,7 +110,7 @@ convOpen o =
data CncJment = Pa S.Param | LC Lincat | Op Oper | Li Lin | Ignored data CncJment = Pa S.Param | LC Lincat | Op Oper | Li Lin | Ignored
convCncJments = mapM convCncJment . Map.toList convCncJments = mapM convCncJment . jmentList
convCncJment (name,jment) = convCncJment (name,jment) =
case jment of case jment of
@@ -130,3 +135,18 @@ convCncJment (name,jment) =
convBind (Explicit,v) = return $ convId v convBind (Explicit,v) = return $ convId v
convBind (Implicit,v) = fail "implicit binding not supported" 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