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

module for analysing source grammars

Browse Source
This commit is contained in:
aarne
2011-09-20 16:00:56 +00:00
parent a2ccf1ce69
commit 33a42b1c7c
3 changed files with 31 additions and 19 deletions
Download Patch File Download Diff File Expand all files Collapse all files

29
src/compiler/GF/Grammar/Analyse.hs Normal file
View File

@@ -0,0 +1,29 @@
module GF.Grammar.Analyse (
stripSourceGrammar
) where
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Option ---
import GF.Infra.Modules
import GF.Data.Operations
import qualified Data.Map as Map
stripSourceGrammar :: SourceGrammar -> SourceGrammar
stripSourceGrammar sgr = mGrammar [(i, m{jments = Map.map stripInfo (jments m)}) | (i,m) <- modules sgr]
stripInfo :: Info -> Info
stripInfo i = case i of
AbsCat _ -> i
AbsFun mt mi me mb -> AbsFun mt mi Nothing mb
ResParam mp mt -> ResParam mp Nothing
ResValue lt -> i ----
ResOper mt md -> ResOper mt Nothing
ResOverload is fs -> ResOverload is [(lty, L loc (EInt 0)) | (lty,L loc _) <- fs]
CncCat mty mte mtf -> CncCat mty Nothing Nothing
CncFun mict mte mtf -> CncFun mict Nothing Nothing
AnyInd b f -> i

17
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -16,7 +16,6 @@
module GF.Grammar.Grammar (SourceGrammar,
emptySourceGrammar,mGrammar,
stripSourceGrammar,
SourceModInfo,
SourceModule,
mapSourceModule,
@@ -241,19 +240,3 @@ label2ident :: Label -> Ident
label2ident (LIdent s) = identC s
label2ident (LVar i) = identC (BS.pack ('$':show i))
stripSourceGrammar :: SourceGrammar -> SourceGrammar
stripSourceGrammar sgr = sgr --mGrammar [(i, m{jments = Map.map }) | (i,m) <- modules sgr]
stripInfo :: Info -> Info
stripInfo i = case i of
AbsCat _ -> i
AbsFun mt mi me mb -> AbsFun mt mi Nothing mb
ResParam mp mt -> ResParam mp Nothing
ResValue lt -> i ----
ResOper mt md -> ResOper mt Nothing
ResOverload is fs -> ResOverload is [(lty, L loc (EInt 0)) | (lty,L loc _) <- fs]
CncCat mty mte mtf -> CncCat mty Nothing Nothing
CncFun mict mte mtf -> CncFun mict Nothing Nothing
AnyInd b f -> i

4
src/compiler/GF/Grammar/Printer.hs
View File

@@ -107,7 +107,7 @@ ppJudgement q (id, ResOper ptype pexp) =
ppJudgement q (id, ResOverload ids defs) =
text "oper" <+> ppIdent id <+> equals <+>
(text "overload" <+> lbrace $$
nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e) | (L _ ty,L _ e) <- defs]) $$
nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e <+> semi) | (L _ ty,L _ e) <- defs]) $$
rbrace) <+> semi
ppJudgement q (id, CncCat ptype pexp pprn) =
(case ptype of
@@ -127,7 +127,7 @@ ppJudgement q (id, CncFun ptype pdef pprn) =
(case pprn of
Just (L _ prn) -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
Nothing -> empty)
ppJudgement q (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi
ppJudgement q (id, AnyInd cann mid) = text "-- ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi
ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e)
in prec d 0 (char '\\' <> commaPunct ppBind xs <+> text "->" <+> ppTerm q 0 e')