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

Founding the newly structured GF2.0 cvs archive.

Browse Source
This commit is contained in:
aarne
2003-09-22 13:16:55 +00:00
commit b1402e8bd6
162 changed files with 25569 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

242
src/GF/Source/AbsGF.hs Normal file
View File

@@ -0,0 +1,242 @@
module AbsGF where
import Ident --H
-- Haskell module generated by the BNF converter, except for --H
-- newtype Ident = Ident String deriving (Eq,Ord,Show) --H
newtype LString = LString String deriving (Eq,Ord,Show)
data Grammar =
Gr [ModDef]
deriving (Eq,Ord,Show)
data ModDef =
MMain Ident Ident [ConcSpec]
| MAbstract Ident Extend Opens [TopDef]
| MResource Ident Extend Opens [TopDef]
| MResourceInt Ident Extend Opens [TopDef]
| MResourceImp Ident Ident Opens [TopDef]
| MConcrete Ident Ident Extend Opens [TopDef]
| MConcreteInt Ident Ident Extend Opens [TopDef]
| MConcreteImp Open Ident Ident
| MTransfer Ident Open Open Extend Opens [TopDef]
| MReuseAbs Ident Ident
| MReuseCnc Ident Ident
| MReuseAll Ident Extend Ident
deriving (Eq,Ord,Show)
data ConcSpec =
ConcSpec Ident ConcExp
deriving (Eq,Ord,Show)
data ConcExp =
ConcExp Ident [Transfer]
deriving (Eq,Ord,Show)
data Transfer =
TransferIn Open
| TransferOut Open
deriving (Eq,Ord,Show)
data Extend =
Ext Ident
| NoExt
deriving (Eq,Ord,Show)
data Opens =
NoOpens
| Opens [Open]
deriving (Eq,Ord,Show)
data Open =
OName Ident
| OQual Ident Ident
deriving (Eq,Ord,Show)
data Def =
DDecl [Ident] Exp
| DDef [Ident] Exp
| DPatt Ident [Patt] Exp
| DFull [Ident] Exp Exp
deriving (Eq,Ord,Show)
data TopDef =
DefCat [CatDef]
| DefFun [FunDef]
| DefDef [Def]
| DefData [ParDef]
| DefTrans [FlagDef]
| DefPar [ParDef]
| DefOper [Def]
| DefLincat [PrintDef]
| DefLindef [Def]
| DefLin [Def]
| DefPrintCat [PrintDef]
| DefPrintFun [PrintDef]
| DefFlag [FlagDef]
| DefPrintOld [PrintDef]
| DefLintype [Def]
| DefPattern [Def]
deriving (Eq,Ord,Show)
data CatDef =
CatDef Ident [DDecl]
deriving (Eq,Ord,Show)
data FunDef =
FunDef [Ident] Exp
deriving (Eq,Ord,Show)
data ParDef =
ParDef Ident [ParConstr]
| ParDefIndir Ident Ident
| ParDefAbs Ident
deriving (Eq,Ord,Show)
data ParConstr =
ParConstr Ident [DDecl]
deriving (Eq,Ord,Show)
data PrintDef =
PrintDef [Ident] Exp
deriving (Eq,Ord,Show)
data FlagDef =
FlagDef Ident Ident
deriving (Eq,Ord,Show)
data LocDef =
LDDecl [Ident] Exp
| LDDef [Ident] Exp
| LDFull [Ident] Exp Exp
deriving (Eq,Ord,Show)
data Exp =
EIdent Ident
| EConstr Ident
| ECons Ident
| ESort Sort
| EString String
| EInt Integer
| EMeta
| EEmpty
| EStrings String
| ERecord [LocDef]
| ETuple [TupleComp]
| EIndir Ident
| ETyped Exp Exp
| EProj Exp Label
| EQConstr Ident Ident
| EQCons Ident Ident
| EApp Exp Exp
| ETable [Case]
| ETTable Exp [Case]
| ECase Exp [Case]
| EVariants [Exp]
| EPre Exp [Altern]
| EStrs [Exp]
| EConAt Ident Exp
| ESelect Exp Exp
| ETupTyp Exp Exp
| EExtend Exp Exp
| EAbstr [Bind] Exp
| ECTable [Bind] Exp
| EProd Decl Exp
| ETType Exp Exp
| EConcat Exp Exp
| EGlue Exp Exp
| ELet [LocDef] Exp
| EEqs [Equation]
| ELString LString
| ELin Ident
deriving (Eq,Ord,Show)
data Patt =
PW
| PV Ident
| PCon Ident
| PQ Ident Ident
| PInt Integer
| PStr String
| PR [PattAss]
| PTup [PattTupleComp]
| PC Ident [Patt]
| PQC Ident Ident [Patt]
deriving (Eq,Ord,Show)
data PattAss =
PA [Ident] Patt
deriving (Eq,Ord,Show)
data Label =
LIdent Ident
| LVar Integer
deriving (Eq,Ord,Show)
data Sort =
Sort_Type
| Sort_PType
| Sort_Tok
| Sort_Str
| Sort_Strs
deriving (Eq,Ord,Show)
data PattAlt =
AltP Patt
deriving (Eq,Ord,Show)
data Bind =
BIdent Ident
| BWild
deriving (Eq,Ord,Show)
data Decl =
DDec [Bind] Exp
| DExp Exp
deriving (Eq,Ord,Show)
data TupleComp =
TComp Exp
deriving (Eq,Ord,Show)
data PattTupleComp =
PTComp Patt
deriving (Eq,Ord,Show)
data Case =
Case [PattAlt] Exp
deriving (Eq,Ord,Show)
data Equation =
Equ [Patt] Exp
deriving (Eq,Ord,Show)
data Altern =
Alt Exp Exp
deriving (Eq,Ord,Show)
data DDecl =
DDDec [Bind] Exp
| DDExp Exp
deriving (Eq,Ord,Show)
data OldGrammar =
OldGr Include [TopDef]
deriving (Eq,Ord,Show)
data Include =
NoIncl
| Incl [FileName]
deriving (Eq,Ord,Show)
data FileName =
FString String
| FIdent Ident
| FSlash FileName
| FDot FileName
| FMinus FileName
| FAddId Ident FileName
deriving (Eq,Ord,Show)

141
src/GF/Source/CompileM.hs Normal file
View File

@@ -0,0 +1,141 @@
module CompileM where
import Grammar
import Ident
import Option
import PrGrammar
import Update
import Lookup
import Modules
---import Rename
import Operations
import UseIO
import Monad
compileMGrammar :: Options -> SourceGrammar -> IOE SourceGrammar
compileMGrammar opts sgr = do
ioeErr $ checkUniqueModuleNames sgr
deps <- ioeErr $ moduleDeps sgr
deplist <- either return
(\ms -> ioeBad $ "circular modules" +++ unwords (map show ms)) $
topoTest deps
let deps' = closureDeps deps
foldM (compileModule opts deps' sgr) emptyMGrammar deplist
checkUniqueModuleNames :: MGrammar i f a r c -> Err ()
checkUniqueModuleNames gr = do
let ms = map fst $ tree2list $ modules gr
msg = checkUnique ms
if null msg then return () else Bad $ unlines msg
-- to decide what modules immediately depend on what, and check if the
-- dependencies are appropriate
moduleDeps :: MGrammar i f a c r -> Err Dependencies
moduleDeps gr = mapM deps $ tree2list $ modules gr where
deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of
ModAbs m -> chDep (IdentM c MTAbstract)
(extends m) MTAbstract (opens m) MTAbstract
ModRes m -> chDep (IdentM c MTResource)
(extends m) MTResource (opens m) MTResource
ModCnc m -> do
a:ops <- case opens m of
os@(_:_) -> return os
_ -> Bad "no abstract indicated for concrete module"
aty <- lookupModuleType gr a
testErr (aty == MTAbstract) "the for-module is not an abstract syntax"
chDep (IdentM c (MTConcrete a)) (extends m) MTResource ops MTResource
chDep it es ety os oty = do
ests <- mapM (lookupModuleType gr) es
testErr (all (==ety) ests) "inappropriate extension module type"
osts <- mapM (lookupModuleType gr) os
testErr (all (==oty) osts) "inappropriate open module type"
return (it, [IdentM e ety | e <- es] ++ [IdentM o oty | o <- os])
type Dependencies = [(IdentM Ident,[IdentM Ident])]
---compileModule :: Options -> Dependencies -> SourceGrammar ->
--- CanonGrammar -> IdentM -> IOE CanonGrammar
compileModule opts deps sgr cgr i = do
let name = identM i
testIfCompiled deps name
mi <- ioeErr $ lookupModule sgr name
mi' <- case typeM i of
-- previously compiled cgr used as symbol table
MTAbstract -> compileAbstract cgr mi
MTResource -> compileResource cgr mi
MTConcrete a -> compileConcrete a cgr mi
ifIsOpt doOutput $ writeCanonFile name mi'
return $ addModule cgr name mi'
where
ifIsOpt o f = if (oElem o opts) then f else return ()
doOutput = iOpt "o"
testIfCompiled :: Dependencies -> Ident -> IOE Bool
testIfCompiled _ _ = return False ----
---writeCanonFile :: Ident -> CanonModInfo -> IOE ()
writeCanonFile name mi' = ioeIO $ writeFile (canonFileName name) [] ----
canonFileName n = n ++ ".gfc" ---- elsewhere!
---compileAbstract :: CanonGrammar -> SourceModInfo -> IOE CanonModInfo
compileAbstract can (ModAbs m0) = do
let m1 = renameMAbstract m0
{-
checkUnique
typeCheck
generateCode
addToCanon
-}
ioeBad "compile abs not yet"
---compileResource :: CanonGrammar -> SourceModInfo -> IOE CanonModInfo
compileResource can md = do
{-
checkUnique
typeCheck
topoSort
compileOpers -- conservative, since more powerful than lin
generateCode
addToCanon
-}
ioeBad "compile res not yet"
---compileConcrete :: Ident -> CanonGrammar -> SourceModInfo -> IOE CanonModInfo
compileConcrete ab can md = do
{-
checkUnique
checkComplete ab
typeCheck
topoSort
compileOpers
optimize
createPreservedOpers
generateCode
addToCanon
-}
ioeBad "compile cnc not yet"
-- to be imported
closureDeps :: [(a,[a])] -> [(a,[a])]
closureDeps ds = ds ---- fix-point iteration

181
src/GF/Source/GrammarToSource.hs Normal file
View File

@@ -0,0 +1,181 @@
module GrammarToSource where
import Operations
import Grammar
import Modules
import Option
import qualified AbsGF as P
import Ident
-- AR 13/5/2003
-- translate internal to parsable and printable source
trGrammar :: SourceGrammar -> P.Grammar
trGrammar (MGrammar ms) = P.Gr (map trModule ms) -- no includes
trModule :: (Ident,SourceModInfo) -> P.ModDef
trModule (i,mo) = case mo of
ModMod m -> mkModule i' (trExtend (extends m)) (mkOpens (map trOpen (opens m)))
(mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++
(map trFlag (flags m))))
where
i' = tri i
mkModule = case typeOfModule mo of
MTResource -> P.MResource
MTAbstract -> P.MAbstract
MTConcrete a -> P.MConcrete (tri a)
trExtend :: Maybe Ident -> P.Extend
trExtend i = maybe P.NoExt (P.Ext . tri) i
---- this has to be completed with other mtys
forName (MTConcrete a) = tri a
trOpen :: OpenSpec Ident -> P.Open
trOpen o = case o of
OSimple i -> P.OName (tri i)
OQualif i j -> P.OQual (tri i) (tri j)
mkOpens ds = if null ds then P.NoOpens else P.Opens ds
mkTopDefs ds = ds
trAnyDef :: (Ident,Info) -> [P.TopDef]
trAnyDef (i,info) = let i' = tri i in case info of
AbsCat (Yes co) _ -> [P.DefCat [P.CatDef i' (map trDecl co)]]
AbsFun (Yes ty) _ -> [P.DefFun [P.FunDef [i'] (trt ty)]]
AbsFun (May b) _ -> [P.DefFun [P.FunDef [i'] (P.EIndir (tri b))]]
---- don't destroy definitions!
ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]]
ResParam pp -> [P.DefPar [case pp of
Yes ps -> P.ParDef i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps]
May b -> P.ParDefIndir i' $ tri b
_ -> P.ParDefAbs i']]
CncCat (Yes ty) Nope _ ->
[P.DefLincat [P.PrintDef [i'] (trt ty)]]
CncCat pty ptr ppr ->
[P.DefLindef [trDef i' pty ptr]]
---- P.DefPrintCat [P.PrintDef i' (trt pr)]]
CncFun _ ptr ppr ->
[P.DefLin [trDef i' nope ptr]]
---- P.DefPrintFun [P.PrintDef i' (trt pr)]]
_ -> []
trDef :: Ident -> Perh Type -> Perh Term -> P.Def
trDef i pty ptr = case (pty,ptr) of
(Nope, Nope) -> P.DDef [i] (P.EMeta) ---
(_, Nope) -> P.DDecl [i] (trPerh pty)
(Nope, _ ) -> P.DDef [i] (trPerh ptr)
(_, _ ) -> P.DFull [i] (trPerh pty) (trPerh ptr)
trPerh p = case p of
Yes t -> trt t
May b -> P.EIndir $ tri b
_ -> P.EMeta ---
trFlag :: Option -> P.TopDef
trFlag o = case o of
Opt (f,[x]) -> P.DefFlag [P.FlagDef (identC f) (identC x)]
_ -> P.DefFlag [] --- warning?
trt :: Term -> P.Exp
trt trm = case trm of
Vr s -> P.EIdent $ tri s
Cn s -> P.ECons $ tri s
Con s -> P.EConstr $ tri s
---- ConAt id typ -> P.EConAt (tri id) (trt typ)
Sort s -> P.ESort $ case s of
"Type" -> P.Sort_Type
"PType" -> P.Sort_PType
"Tok" -> P.Sort_Tok
"Str" -> P.Sort_Str
"Strs" -> P.Sort_Strs
_ -> error $ "not yet sort " +++ show trm ----
App c a -> P.EApp (trt c) (trt a)
Abs x b -> P.EAbstr [trb x] (trt b)
---- Eqs pts -> "fn" +++ prCurlyList [prtBranchOld pst | pst <- pts] ---
---- ECase e bs -> "case" +++ prt e +++ "of" +++ prCurlyList (map prtBranch bs)
Meta m -> P.EMeta
Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b)
Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b)
R r -> P.ERecord $ map trAssign r
RecType r -> P.ERecord $ map trLabelling r
ExtR x y -> P.EExtend (trt x) (trt y)
P t l -> P.EProj (trt t) (trLabel l)
Q t l -> P.EQCons (tri t) (tri l)
QC t l -> P.EQConstr (tri t) (tri l)
T (TTyped ty) cc -> P.ETTable (trt ty) (map trCase cc)
T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc)
T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc)
T _ cc -> P.ETable (map trCase cc)
Table x v -> P.ETType (trt x) (trt v)
S f x -> P.ESelect (trt f) (trt x)
---- Alias c a t -> "{-" +++ prt c +++ "=" +++ "-}" +++ prt t
-- Alias c a t -> prt (Let (c,(Just a,t)) (Vr c)) -- thus Alias is only internal
Let (x,(ma,b)) t ->
P.ELet [maybe (P.LDDef x' b') (\ty -> P.LDFull x' (trt ty) b') ma] (trt t)
where
b' = trt b
x' = [tri x]
Empty -> P.EEmpty
K [] -> P.EEmpty
K a -> P.EString a
C a b -> P.EConcat (trt a) (trt b)
EInt i -> P.EInt $ toInteger i
Glue a b -> P.EGlue (trt a) (trt b)
Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt]
FV ts -> P.EVariants $ map trt ts
Strs tt -> P.EStrs $ map trt tt
_ -> error $ "not yet" +++ show trm ----
trp :: Patt -> P.Patt
trp p = case p of
PV s | isWildIdent s -> P.PW
PV s -> P.PV $ tri s
PC c [] -> P.PCon $ tri c
PC c a -> P.PC (tri c) (map trp a)
PP p c [] -> P.PQ (tri p) (tri c)
PP p c a -> P.PQC (tri p) (tri c) (map trp a)
PR r -> P.PR [P.PA [trLabelIdent l] (trp p) | (l,p) <- r]
---- PT t p -> prt p ---- prParenth (prt p +++ ":" +++ prt t)
trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty
where
t' = trt t
x = [trLabelIdent lab]
trLabelling (lab,ty) = P.LDDecl [trLabelIdent lab] (trt ty)
trCase (patt,trm) = P.Case [P.AltP (trp patt)] (trt trm)
trDecl (x,ty) = P.DDDec [trb x] (trt ty)
tri :: Ident -> Ident
tri i = case prIdent i of
s@('_':_:_) -> identC $ 'h':s ---- unsafe; needed since _3 etc are generated
s -> identC $ s
trb i = if isWildIdent i then P.BWild else P.BIdent (tri i)
trLabel i = case i of
LIdent s -> P.LIdent $ identC s
LVar i -> P.LVar $ toInteger i
trLabelIdent i = identC $ case i of
LIdent s -> s
LVar i -> "v" ++ show i --- should not happen

127
src/GF/Source/LexGF.hs Normal file
View File

@@ -0,0 +1,127 @@
module LexGF where
import Alex
import ErrM
pTSpec p = PT p . TS
mk_LString p = PT p . eitherResIdent T_LString
ident p = PT p . eitherResIdent TV
string p = PT p . TL . unescapeInitTail
int p = PT p . TI
data Tok =
TS String -- reserved words
| TL String -- string literals
| TI String -- integer literals
| TV String -- identifiers
| TD String -- double precision float literals
| TC String -- character literals
| T_LString String
deriving (Eq,Show)
data Token =
PT Posn Tok
| Err Posn
deriving Show
tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
tokenPos _ = "end of file"
prToken t = case t of
PT _ (TS s) -> s
PT _ (TI s) -> s
PT _ (TV s) -> s
PT _ (TD s) -> s
PT _ (TC s) -> s
_ -> show t
tokens:: String -> [Token]
tokens inp = scan tokens_scan inp
tokens_scan:: Scan Token
tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx
where
stop_act p "" = []
stop_act p inp = [Err p]
eitherResIdent :: (String -> Tok) -> String -> Tok
eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where
isResWord s = isInTree s $
B "let" (B "concrete" (B "Tok" (B "Str" (B "PType" (B "Lin" N N) N) (B "Strs" N N)) (B "case" (B "abstract" (B "Type" N N) N) (B "cat" N N))) (B "fun" (B "flags" (B "def" (B "data" N N) N) (B "fn" N N)) (B "in" (B "grammar" N N) (B "include" N N)))) (B "pattern" (B "of" (B "lindef" (B "lincat" (B "lin" N N) N) (B "lintype" N N)) (B "out" (B "oper" (B "open" N N) N) (B "param" N N))) (B "strs" (B "resource" (B "printname" (B "pre" N N) N) (B "reuse" N N)) (B "transfer" (B "table" N N) (B "variants" N N))))
data BTree = N | B String BTree BTree deriving (Show)
isInTree :: String -> BTree -> Bool
isInTree x tree = case tree of
N -> False
B a left right
| x < a -> isInTree x left
| x > a -> isInTree x right
| x == a -> True
unescapeInitTail :: String -> String
unescapeInitTail = unesc . tail where
unesc s = case s of
'\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
'\\':'n':cs -> '\n' : unesc cs
'\\':'t':cs -> '\t' : unesc cs
'"':[] -> []
c:cs -> c : unesc cs
_ -> []
tokens_acts = [("ident",ident),("int",int),("mk_LString",mk_LString),("pTSpec",pTSpec),("string",string)]
tokens_lx :: [(Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))]
tokens_lx = [lx__0_0,lx__1_0,lx__2_0,lx__3_0,lx__4_0,lx__5_0,lx__6_0,lx__7_0,lx__8_0,lx__9_0,lx__10_0,lx__11_0,lx__12_0,lx__13_0,lx__14_0,lx__15_0,lx__16_0,lx__17_0,lx__18_0,lx__19_0,lx__20_0,lx__21_0]
lx__0_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__0_0 = (False,[],-1,(('\t','\255'),[('\t',10),('\n',10),('\v',10),('\f',10),('\r',10),(' ',10),('!',14),('"',18),('$',14),('\'',15),('(',14),(')',14),('*',11),('+',13),(',',14),('-',1),('.',14),('/',14),('0',21),('1',21),('2',21),('3',21),('4',21),('5',21),('6',21),('7',21),('8',21),('9',21),(':',14),(';',14),('<',14),('=',12),('>',14),('?',14),('@',14),('A',17),('B',17),('C',17),('D',17),('E',17),('F',17),('G',17),('H',17),('I',17),('J',17),('K',17),('L',17),('M',17),('N',17),('O',17),('P',17),('Q',17),('R',17),('S',17),('T',17),('U',17),('V',17),('W',17),('X',17),('Y',17),('Z',17),('[',14),('\\',14),(']',14),('_',14),('a',17),('b',17),('c',17),('d',17),('e',17),('f',17),('g',17),('h',17),('i',17),('j',17),('k',17),('l',17),('m',17),('n',17),('o',17),('p',17),('q',17),('r',17),('s',17),('t',17),('u',17),('v',17),('w',17),('x',17),('y',17),('z',17),('{',4),('|',14),('}',14),('\192',17),('\193',17),('\194',17),('\195',17),('\196',17),('\197',17),('\198',17),('\199',17),('\200',17),('\201',17),('\202',17),('\203',17),('\204',17),('\205',17),('\206',17),('\207',17),('\208',17),('\209',17),('\210',17),('\211',17),('\212',17),('\213',17),('\214',17),('\216',17),('\217',17),('\218',17),('\219',17),('\220',17),('\221',17),('\222',17),('\223',17),('\224',17),('\225',17),('\226',17),('\227',17),('\228',17),('\229',17),('\230',17),('\231',17),('\232',17),('\233',17),('\234',17),('\235',17),('\236',17),('\237',17),('\238',17),('\239',17),('\240',17),('\241',17),('\242',17),('\243',17),('\244',17),('\245',17),('\246',17),('\248',17),('\249',17),('\250',17),('\251',17),('\252',17),('\253',17),('\254',17),('\255',17)]))
lx__1_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__1_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('-','>'),[('-',2),('>',14)]))
lx__2_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__2_0 = (False,[],2,(('\n','\n'),[('\n',3)]))
lx__3_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__3_0 = (True,[(0,"",[],Nothing,Nothing)],-1,(('0','0'),[]))
lx__4_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__4_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('-','-'),[('-',5)]))
lx__5_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__5_0 = (False,[],5,(('-','-'),[('-',8)]))
lx__6_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__6_0 = (False,[],5,(('-','}'),[('-',8),('}',7)]))
lx__7_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__7_0 = (True,[(1,"",[],Nothing,Nothing)],5,(('-','-'),[('-',8)]))
lx__8_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__8_0 = (False,[],5,(('-','}'),[('-',6),('}',9)]))
lx__9_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__9_0 = (True,[(1,"",[],Nothing,Nothing)],-1,(('0','0'),[]))
lx__10_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__10_0 = (True,[(2,"",[],Nothing,Nothing)],-1,(('\t',' '),[('\t',10),('\n',10),('\v',10),('\f',10),('\r',10),(' ',10)]))
lx__11_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__11_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('*','*'),[('*',14)]))
lx__12_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__12_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('>','>'),[('>',14)]))
lx__13_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__13_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('+','+'),[('+',14)]))
lx__14_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__14_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('0','0'),[]))
lx__15_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__15_0 = (False,[],15,(('\'','\''),[('\'',16)]))
lx__16_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__16_0 = (True,[(4,"mk_LString",[],Nothing,Nothing)],15,(('\'','\''),[('\'',16)]))
lx__17_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__17_0 = (True,[(5,"ident",[],Nothing,Nothing)],-1,(('\'','\255'),[('\'',17),('0',17),('1',17),('2',17),('3',17),('4',17),('5',17),('6',17),('7',17),('8',17),('9',17),('A',17),('B',17),('C',17),('D',17),('E',17),('F',17),('G',17),('H',17),('I',17),('J',17),('K',17),('L',17),('M',17),('N',17),('O',17),('P',17),('Q',17),('R',17),('S',17),('T',17),('U',17),('V',17),('W',17),('X',17),('Y',17),('Z',17),('_',17),('a',17),('b',17),('c',17),('d',17),('e',17),('f',17),('g',17),('h',17),('i',17),('j',17),('k',17),('l',17),('m',17),('n',17),('o',17),('p',17),('q',17),('r',17),('s',17),('t',17),('u',17),('v',17),('w',17),('x',17),('y',17),('z',17),('\192',17),('\193',17),('\194',17),('\195',17),('\196',17),('\197',17),('\198',17),('\199',17),('\200',17),('\201',17),('\202',17),('\203',17),('\204',17),('\205',17),('\206',17),('\207',17),('\208',17),('\209',17),('\210',17),('\211',17),('\212',17),('\213',17),('\214',17),('\216',17),('\217',17),('\218',17),('\219',17),('\220',17),('\221',17),('\222',17),('\223',17),('\224',17),('\225',17),('\226',17),('\227',17),('\228',17),('\229',17),('\230',17),('\231',17),('\232',17),('\233',17),('\234',17),('\235',17),('\236',17),('\237',17),('\238',17),('\239',17),('\240',17),('\241',17),('\242',17),('\243',17),('\244',17),('\245',17),('\246',17),('\248',17),('\249',17),('\250',17),('\251',17),('\252',17),('\253',17),('\254',17),('\255',17)]))
lx__18_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__18_0 = (False,[],18,(('\n','\\'),[('\n',-1),('"',20),('\\',19)]))
lx__19_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__19_0 = (False,[],-1,(('"','t'),[('"',18),('\'',18),('\\',18),('n',18),('t',18)]))
lx__20_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__20_0 = (True,[(6,"string",[],Nothing,Nothing)],-1,(('0','0'),[]))
lx__21_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
lx__21_0 = (True,[(7,"int",[],Nothing,Nothing)],-1,(('0','9'),[('0',21),('1',21),('2',21),('3',21),('4',21),('5',21),('6',21),('7',21),('8',21),('9',21)]))

435
src/GF/Source/PrintGF.hs Normal file
View File

@@ -0,0 +1,435 @@
module PrintGF where
-- pretty-printer generated by the BNF converter, except --H
import AbsGF
import Ident --H
import Char
-- the top-level printing method
printTree :: Print a => a -> String
printTree = render . prt 0
-- you may want to change render and parenth
render :: [String] -> String
render = rend 0 where
rend i ss = case ss of
--H these three are hand-written
"{0" :ts -> cons "{" $ rend (i+1) ts
t :"}0" :ts -> cons t $ space "}" $ rend (i-1) ts
t : "." :ts -> cons t $ cons "." $ rend i ts
"[" :ts -> cons "[" $ rend i ts
"(" :ts -> cons "(" $ rend i ts
"{" :ts -> cons "{" $ new (i+1) $ rend (i+1) ts
"}" : ";":ts -> new (i-1) $ space "}" $ cons ";" $ new (i-1) $ rend (i-1) ts
"}" :ts -> new (i-1) $ cons "}" $ new (i-1) $ rend (i-1) ts
";" :ts -> cons ";" $ new i $ rend i ts
t : "," :ts -> cons t $ space "," $ rend i ts
t : ")" :ts -> cons t $ cons ")" $ rend i ts
t : "]" :ts -> cons t $ cons "]" $ rend i ts
t :ts -> space t $ rend i ts
_ -> ""
cons s t = s ++ t
new i s = '\n' : replicate (2*i) ' ' ++ dropWhile isSpace s
space t s = if null s then t else t ++ " " ++ s
parenth :: [String] -> [String]
parenth ss = ["("] ++ ss ++ [")"]
-- the printer class does the job
class Print a where
prt :: Int -> a -> [String]
prtList :: [a] -> [String]
prtList = concat . map (prt 0)
instance Print a => Print [a] where
prt _ = prtList
instance Print Integer where
prt _ = (:[]) . show
instance Print Double where
prt _ = (:[]) . show
instance Print Char where
prt _ s = ["'" ++ mkEsc s ++ "'"]
prtList s = ["\"" ++ concatMap mkEsc s ++ "\""]
mkEsc s = case s of
_ | elem s "\\\"'" -> '\\':[s]
'\n' -> "\\n"
'\t' -> "\\t"
_ -> [s]
prPrec :: Int -> Int -> [String] -> [String]
prPrec i j = if j<i then parenth else id
instance Print Ident where
prt _ i = [prIdent i] --H
prtList es = case es of
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [","] , prt 0 xs])
instance Print LString where
prt _ (LString i) = [i]
instance Print Grammar where
prt i e = case e of
Gr moddefs -> prPrec i 0 (concat [prt 0 moddefs])
instance Print ModDef where
prt i e = case e of
MMain id0 id concspecs -> prPrec i 0 (concat [["grammar"] , prt 0 id0 , ["="] , ["{"] , ["abstract"] , ["="] , prt 0 id , [";"] , prt 0 concspecs , ["}"]])
MAbstract id extend opens topdefs -> prPrec i 0 (concat [["abstract"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
MResource id extend opens topdefs -> prPrec i 0 (concat [["resource"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
MResourceInt id extend opens topdefs -> prPrec i 0 (concat [["resource"] , ["abstract"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
MResourceImp id0 id opens topdefs -> prPrec i 0 (concat [["resource"] , prt 0 id0 , ["of"] , prt 0 id , ["="] , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
MConcrete id0 id extend opens topdefs -> prPrec i 0 (concat [["concrete"] , prt 0 id0 , ["of"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
MConcreteInt id0 id extend opens topdefs -> prPrec i 0 (concat [["concrete"] , ["abstract"] , ["of"] , prt 0 id0 , ["in"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
MConcreteImp open id0 id -> prPrec i 0 (concat [["concrete"] , ["of"] , prt 0 open , ["="] , prt 0 id0 , ["**"] , prt 0 id])
MTransfer id open0 open extend opens topdefs -> prPrec i 0 (concat [["transfer"] , prt 0 id , [":"] , prt 0 open0 , ["->"] , prt 0 open , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
MReuseAbs id0 id -> prPrec i 0 (concat [["resource"] , ["abstract"] , prt 0 id0 , ["="] , ["reuse"] , prt 0 id])
MReuseCnc id0 id -> prPrec i 0 (concat [["resource"] , ["concrete"] , prt 0 id0 , ["="] , ["reuse"] , prt 0 id])
MReuseAll id0 extend id -> prPrec i 0 (concat [["resource"] , prt 0 id0 , ["="] , prt 0 extend , ["reuse"] , prt 0 id])
prtList es = case es of
[] -> (concat [])
x:xs -> (concat [prt 0 x , prt 0 xs])
instance Print ConcSpec where
prt i e = case e of
ConcSpec id concexp -> prPrec i 0 (concat [prt 0 id , ["="] , prt 0 concexp])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print ConcExp where
prt i e = case e of
ConcExp id transfers -> prPrec i 0 (concat [prt 0 id , prt 0 transfers])
instance Print Transfer where
prt i e = case e of
TransferIn open -> prPrec i 0 (concat [["("] , ["transfer"] , ["in"] , prt 0 open , [")"]])
TransferOut open -> prPrec i 0 (concat [["("] , ["transfer"] , ["out"] , prt 0 open , [")"]])
prtList es = case es of
[] -> (concat [])
x:xs -> (concat [prt 0 x , prt 0 xs])
instance Print Extend where
prt i e = case e of
Ext id -> prPrec i 0 (concat [prt 0 id , ["**"]])
NoExt -> prPrec i 0 (concat [])
instance Print Opens where
prt i e = case e of
NoOpens -> prPrec i 0 (concat [])
Opens opens -> prPrec i 0 (concat [["open"] , prt 0 opens , ["in"]])
instance Print Open where
prt i e = case e of
OName id -> prPrec i 0 (concat [prt 0 id])
OQual id0 id -> prPrec i 0 (concat [["("] , prt 0 id0 , ["="] , prt 0 id , [")"]])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [","] , prt 0 xs])
instance Print Def where
prt i e = case e of
DDecl ids exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp])
DDef ids exp -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 exp])
DPatt id patts exp -> prPrec i 0 (concat [prt 0 id , prt 0 patts , ["="] , prt 0 exp])
DFull ids exp0 exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp0 , ["="] , prt 0 exp])
prtList es = case es of
[x] -> (concat [prt 0 x , [";"]])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print TopDef where
prt i e = case e of
DefCat catdefs -> prPrec i 0 (concat [["cat"] , prt 0 catdefs])
DefFun fundefs -> prPrec i 0 (concat [["fun"] , prt 0 fundefs])
DefDef defs -> prPrec i 0 (concat [["def"] , prt 0 defs])
DefData pardefs -> prPrec i 0 (concat [["data"] , prt 0 pardefs])
DefTrans flagdefs -> prPrec i 0 (concat [["transfer"] , prt 0 flagdefs])
DefPar pardefs -> prPrec i 0 (concat [["param"] , prt 0 pardefs])
DefOper defs -> prPrec i 0 (concat [["oper"] , prt 0 defs])
DefLincat printdefs -> prPrec i 0 (concat [["lincat"] , prt 0 printdefs])
DefLindef defs -> prPrec i 0 (concat [["lindef"] , prt 0 defs])
DefLin defs -> prPrec i 0 (concat [["lin"] , prt 0 defs])
DefPrintCat printdefs -> prPrec i 0 (concat [["printname"] , ["cat"] , prt 0 printdefs])
DefPrintFun printdefs -> prPrec i 0 (concat [["printname"] , ["fun"] , prt 0 printdefs])
DefFlag flagdefs -> prPrec i 0 (concat [["flags"] , prt 0 flagdefs])
DefPrintOld printdefs -> prPrec i 0 (concat [["printname"] , prt 0 printdefs])
DefLintype defs -> prPrec i 0 (concat [["lintype"] , prt 0 defs])
DefPattern defs -> prPrec i 0 (concat [["pattern"] , prt 0 defs])
prtList es = case es of
[] -> (concat [])
x:xs -> (concat [prt 0 x , prt 0 xs])
instance Print CatDef where
prt i e = case e of
CatDef id ddecls -> prPrec i 0 (concat [prt 0 id , prt 0 ddecls])
prtList es = case es of
[x] -> (concat [prt 0 x , [";"]])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print FunDef where
prt i e = case e of
FunDef ids exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp])
prtList es = case es of
[x] -> (concat [prt 0 x , [";"]])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print ParDef where
prt i e = case e of
ParDef id parconstrs -> prPrec i 0 (concat [prt 0 id , ["="] , prt 0 parconstrs])
ParDefIndir id0 id -> prPrec i 0 (concat [prt 0 id0 , ["="] , ["("] , ["in"] , prt 0 id , [")"]])
ParDefAbs id -> prPrec i 0 (concat [prt 0 id])
prtList es = case es of
[x] -> (concat [prt 0 x , [";"]])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print ParConstr where
prt i e = case e of
ParConstr id ddecls -> prPrec i 0 (concat [prt 0 id , prt 0 ddecls])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs])
instance Print PrintDef where
prt i e = case e of
PrintDef ids exp -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 exp])
prtList es = case es of
[x] -> (concat [prt 0 x , [";"]])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print FlagDef where
prt i e = case e of
FlagDef id0 id -> prPrec i 0 (concat [prt 0 id0 , ["="] , prt 0 id])
prtList es = case es of
[x] -> (concat [prt 0 x , [";"]])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print LocDef where
prt i e = case e of
LDDecl ids exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp])
LDDef ids exp -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 exp])
LDFull ids exp0 exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp0 , ["="] , prt 0 exp])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print Exp where
prt i e = case e of
EIdent id -> prPrec i 4 (concat [prt 0 id])
EConstr id -> prPrec i 4 (concat [["{0"] , prt 0 id , ["}0"]]) --H
ECons id -> prPrec i 4 (concat [["["] , prt 0 id , ["]"]])
ESort sort -> prPrec i 4 (concat [prt 0 sort])
EString str -> prPrec i 4 (concat [prt 0 str])
EInt n -> prPrec i 4 (concat [prt 0 n])
EMeta -> prPrec i 4 (concat [["?"]])
EEmpty -> prPrec i 4 (concat [["["] , ["]"]])
EStrings str -> prPrec i 4 (concat [["["] , prt 0 str , ["]"]])
ERecord locdefs -> prPrec i 4 (concat [["{"] , prt 0 locdefs , ["}"]])
ETuple tuplecomps -> prPrec i 4 (concat [["<"] , prt 0 tuplecomps , [">"]])
EIndir id -> prPrec i 4 (concat [["("] , ["in"] , prt 0 id , [")"]])
ETyped exp0 exp -> prPrec i 4 (concat [["<"] , prt 0 exp0 , [":"] , prt 0 exp , [">"]])
EProj exp label -> prPrec i 3 (concat [prt 3 exp , ["."] , prt 0 label])
EQConstr id0 id -> prPrec i 3 (concat [["{0"] , prt 0 id0 , ["."] , prt 0 id , ["}0"]]) --H
EQCons id0 id -> prPrec i 3 (concat [["["] , prt 0 id0 , ["."] , prt 0 id , ["]"]])
EApp exp0 exp -> prPrec i 2 (concat [prt 2 exp0 , prt 3 exp])
ETable cases -> prPrec i 2 (concat [["table"] , ["{"] , prt 0 cases , ["}"]])
ETTable exp cases -> prPrec i 2 (concat [["table"] , prt 4 exp , ["{"] , prt 0 cases , ["}"]])
ECase exp cases -> prPrec i 2 (concat [["case"] , prt 0 exp , ["of"] , ["{"] , prt 0 cases , ["}"]])
EVariants exps -> prPrec i 2 (concat [["variants"] , ["{"] , prt 0 exps , ["}"]])
EPre exp alterns -> prPrec i 2 (concat [["pre"] , ["{"] , prt 0 exp , [";"] , prt 0 alterns , ["}"]])
EStrs exps -> prPrec i 2 (concat [["strs"] , ["{"] , prt 0 exps , ["}"]])
EConAt id exp -> prPrec i 2 (concat [prt 0 id , ["@"] , prt 4 exp])
ESelect exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , ["!"] , prt 2 exp])
ETupTyp exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , ["*"] , prt 2 exp])
EExtend exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , ["**"] , prt 2 exp])
EAbstr binds exp -> prPrec i 0 (concat [["\\"] , prt 0 binds , ["->"] , prt 0 exp])
ECTable binds exp -> prPrec i 0 (concat [["\\"] , ["\\"] , prt 0 binds , ["=>"] , prt 0 exp])
EProd decl exp -> prPrec i 0 (concat [prt 0 decl , ["->"] , prt 0 exp])
ETType exp0 exp -> prPrec i 0 (concat [prt 1 exp0 , ["=>"] , prt 0 exp])
EConcat exp0 exp -> prPrec i 0 (concat [prt 1 exp0 , ["++"] , prt 0 exp])
EGlue exp0 exp -> prPrec i 0 (concat [prt 1 exp0 , ["+"] , prt 0 exp])
ELet locdefs exp -> prPrec i 0 (concat [["let"] , ["{"] , prt 0 locdefs , ["}"] , ["in"] , prt 0 exp])
EEqs equations -> prPrec i 0 (concat [["fn"] , ["{"] , prt 0 equations , ["}"]])
ELString lstring -> prPrec i 4 (concat [prt 0 lstring])
ELin id -> prPrec i 2 (concat [["Lin"] , prt 0 id])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print Patt where
prt i e = case e of
PW -> prPrec i 1 (concat [["_"]])
PV id -> prPrec i 1 (concat [prt 0 id])
PCon id -> prPrec i 1 (concat [["{0"] , prt 0 id , ["}0"]]) --H
PQ id0 id -> prPrec i 1 (concat [prt 0 id0 , ["."] , prt 0 id])
PInt n -> prPrec i 1 (concat [prt 0 n])
PStr str -> prPrec i 1 (concat [prt 0 str])
PR pattasss -> prPrec i 1 (concat [["{"] , prt 0 pattasss , ["}"]])
PTup patttuplecomps -> prPrec i 1 (concat [["<"] , prt 0 patttuplecomps , [">"]])
PC id patts -> prPrec i 0 (concat [prt 0 id , prt 0 patts])
PQC id0 id patts -> prPrec i 0 (concat [prt 0 id0 , ["."] , prt 0 id , prt 0 patts])
prtList es = case es of
[x] -> (concat [prt 1 x])
x:xs -> (concat [prt 1 x , prt 0 xs])
instance Print PattAss where
prt i e = case e of
PA ids patt -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 patt])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print Label where
prt i e = case e of
LIdent id -> prPrec i 0 (concat [prt 0 id])
LVar n -> prPrec i 0 (concat [["$"] , prt 0 n])
instance Print Sort where
prt i e = case e of
Sort_Type -> prPrec i 0 (concat [["Type"]])
Sort_PType -> prPrec i 0 (concat [["PType"]])
Sort_Tok -> prPrec i 0 (concat [["Tok"]])
Sort_Str -> prPrec i 0 (concat [["Str"]])
Sort_Strs -> prPrec i 0 (concat [["Strs"]])
instance Print PattAlt where
prt i e = case e of
AltP patt -> prPrec i 0 (concat [prt 0 patt])
prtList es = case es of
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs])
instance Print Bind where
prt i e = case e of
BIdent id -> prPrec i 0 (concat [prt 0 id])
BWild -> prPrec i 0 (concat [["_"]])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [","] , prt 0 xs])
instance Print Decl where
prt i e = case e of
DDec binds exp -> prPrec i 0 (concat [["("] , prt 0 binds , [":"] , prt 0 exp , [")"]])
DExp exp -> prPrec i 0 (concat [prt 2 exp])
instance Print TupleComp where
prt i e = case e of
TComp exp -> prPrec i 0 (concat [prt 0 exp])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [","] , prt 0 xs])
instance Print PattTupleComp where
prt i e = case e of
PTComp patt -> prPrec i 0 (concat [prt 0 patt])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [","] , prt 0 xs])
instance Print Case where
prt i e = case e of
Case pattalts exp -> prPrec i 0 (concat [prt 0 pattalts , ["=>"] , prt 0 exp])
prtList es = case es of
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print Equation where
prt i e = case e of
Equ patts exp -> prPrec i 0 (concat [prt 0 patts , ["->"] , prt 0 exp])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print Altern where
prt i e = case e of
Alt exp0 exp -> prPrec i 0 (concat [prt 0 exp0 , ["/"] , prt 0 exp])
prtList es = case es of
[] -> (concat [])
[x] -> (concat [prt 0 x])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
instance Print DDecl where
prt i e = case e of
DDDec binds exp -> prPrec i 0 (concat [["("] , prt 0 binds , [":"] , prt 0 exp , [")"]])
DDExp exp -> prPrec i 0 (concat [prt 4 exp])
prtList es = case es of
[] -> (concat [])
x:xs -> (concat [prt 0 x , prt 0 xs])
instance Print OldGrammar where
prt i e = case e of
OldGr include topdefs -> prPrec i 0 (concat [prt 0 include , prt 0 topdefs])
instance Print Include where
prt i e = case e of
NoIncl -> prPrec i 0 (concat [])
Incl filenames -> prPrec i 0 (concat [["include"] , prt 0 filenames])
instance Print FileName where
prt i e = case e of
FString str -> prPrec i 0 (concat [prt 0 str])
FIdent id -> prPrec i 0 (concat [prt 0 id])
FSlash filename -> prPrec i 0 (concat [["/"] , prt 0 filename])
FDot filename -> prPrec i 0 (concat [["."] , prt 0 filename])
FMinus filename -> prPrec i 0 (concat [["-"] , prt 0 filename])
FAddId id filename -> prPrec i 0 (concat [prt 0 id , prt 0 filename])
prtList es = case es of
[x] -> (concat [prt 0 x , [";"]])
x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])

289
src/GF/Source/SkelGF.hs Normal file
View File

@@ -0,0 +1,289 @@
module SkelGF where
-- Haskell module generated by the BNF converter
import AbsGF
import Ident
import ErrM
type Result = Err String
failure :: Show a => a -> Result
failure x = Bad $ "Undefined case: " ++ show x
transIdent :: Ident -> Result
transIdent x = case x of
_ -> failure x
transLString :: LString -> Result
transLString x = case x of
LString str -> failure x
transGrammar :: Grammar -> Result
transGrammar x = case x of
Gr moddefs -> failure x
transModDef :: ModDef -> Result
transModDef x = case x of
MMain id0 id concspecs -> failure x
MAbstract id extend opens topdefs -> failure x
MResource id extend opens topdefs -> failure x
MResourceInt id extend opens topdefs -> failure x
MResourceImp id0 id opens topdefs -> failure x
MConcrete id0 id extend opens topdefs -> failure x
MConcreteInt id0 id extend opens topdefs -> failure x
MConcreteImp open id0 id -> failure x
MTransfer id open0 open extend opens topdefs -> failure x
MReuseAbs id0 id -> failure x
MReuseCnc id0 id -> failure x
MReuseAll id0 extend id -> failure x
transConcSpec :: ConcSpec -> Result
transConcSpec x = case x of
ConcSpec id concexp -> failure x
transConcExp :: ConcExp -> Result
transConcExp x = case x of
ConcExp id transfers -> failure x
transTransfer :: Transfer -> Result
transTransfer x = case x of
TransferIn open -> failure x
TransferOut open -> failure x
transExtend :: Extend -> Result
transExtend x = case x of
Ext id -> failure x
NoExt -> failure x
transOpens :: Opens -> Result
transOpens x = case x of
NoOpens -> failure x
Opens opens -> failure x
transOpen :: Open -> Result
transOpen x = case x of
OName id -> failure x
OQual id0 id -> failure x
transDef :: Def -> Result
transDef x = case x of
DDecl ids exp -> failure x
DDef ids exp -> failure x
DPatt id patts exp -> failure x
DFull ids exp0 exp -> failure x
transTopDef :: TopDef -> Result
transTopDef x = case x of
DefCat catdefs -> failure x
DefFun fundefs -> failure x
DefDef defs -> failure x
DefData pardefs -> failure x
DefTrans flagdefs -> failure x
DefPar pardefs -> failure x
DefOper defs -> failure x
DefLincat printdefs -> failure x
DefLindef defs -> failure x
DefLin defs -> failure x
DefPrintCat printdefs -> failure x
DefPrintFun printdefs -> failure x
DefFlag flagdefs -> failure x
DefPrintOld printdefs -> failure x
DefLintype defs -> failure x
DefPattern defs -> failure x
transCatDef :: CatDef -> Result
transCatDef x = case x of
CatDef id ddecls -> failure x
transFunDef :: FunDef -> Result
transFunDef x = case x of
FunDef ids exp -> failure x
transParDef :: ParDef -> Result
transParDef x = case x of
ParDef id parconstrs -> failure x
ParDefIndir id0 id -> failure x
ParDefAbs id -> failure x
transParConstr :: ParConstr -> Result
transParConstr x = case x of
ParConstr id ddecls -> failure x
transPrintDef :: PrintDef -> Result
transPrintDef x = case x of
PrintDef ids exp -> failure x
transFlagDef :: FlagDef -> Result
transFlagDef x = case x of
FlagDef id0 id -> failure x
transLocDef :: LocDef -> Result
transLocDef x = case x of
LDDecl ids exp -> failure x
LDDef ids exp -> failure x
LDFull ids exp0 exp -> failure x
transExp :: Exp -> Result
transExp x = case x of
EIdent id -> failure x
EConstr id -> failure x
ECons id -> failure x
ESort sort -> failure x
EString str -> failure x
EInt n -> failure x
EMeta -> failure x
EEmpty -> failure x
EStrings str -> failure x
ERecord locdefs -> failure x
ETuple tuplecomps -> failure x
EIndir id -> failure x
ETyped exp0 exp -> failure x
EProj exp label -> failure x
EQConstr id0 id -> failure x
EQCons id0 id -> failure x
EApp exp0 exp -> failure x
ETable cases -> failure x
ETTable exp cases -> failure x
ECase exp cases -> failure x
EVariants exps -> failure x
EPre exp alterns -> failure x
EStrs exps -> failure x
EConAt id exp -> failure x
ESelect exp0 exp -> failure x
ETupTyp exp0 exp -> failure x
EExtend exp0 exp -> failure x
EAbstr binds exp -> failure x
ECTable binds exp -> failure x
EProd decl exp -> failure x
ETType exp0 exp -> failure x
EConcat exp0 exp -> failure x
EGlue exp0 exp -> failure x
ELet locdefs exp -> failure x
EEqs equations -> failure x
ELString lstring -> failure x
ELin id -> failure x
transPatt :: Patt -> Result
transPatt x = case x of
PW -> failure x
PV id -> failure x
PCon id -> failure x
PQ id0 id -> failure x
PInt n -> failure x
PStr str -> failure x
PR pattasss -> failure x
PTup patttuplecomps -> failure x
PC id patts -> failure x
PQC id0 id patts -> failure x
transPattAss :: PattAss -> Result
transPattAss x = case x of
PA ids patt -> failure x
transLabel :: Label -> Result
transLabel x = case x of
LIdent id -> failure x
LVar n -> failure x
transSort :: Sort -> Result
transSort x = case x of
Sort_Type -> failure x
Sort_PType -> failure x
Sort_Tok -> failure x
Sort_Str -> failure x
Sort_Strs -> failure x
transPattAlt :: PattAlt -> Result
transPattAlt x = case x of
AltP patt -> failure x
transBind :: Bind -> Result
transBind x = case x of
BIdent id -> failure x
BWild -> failure x
transDecl :: Decl -> Result
transDecl x = case x of
DDec binds exp -> failure x
DExp exp -> failure x
transTupleComp :: TupleComp -> Result
transTupleComp x = case x of
TComp exp -> failure x
transPattTupleComp :: PattTupleComp -> Result
transPattTupleComp x = case x of
PTComp patt -> failure x
transCase :: Case -> Result
transCase x = case x of
Case pattalts exp -> failure x
transEquation :: Equation -> Result
transEquation x = case x of
Equ patts exp -> failure x
transAltern :: Altern -> Result
transAltern x = case x of
Alt exp0 exp -> failure x
transDDecl :: DDecl -> Result
transDDecl x = case x of
DDDec binds exp -> failure x
DDExp exp -> failure x
transOldGrammar :: OldGrammar -> Result
transOldGrammar x = case x of
OldGr include topdefs -> failure x
transInclude :: Include -> Result
transInclude x = case x of
NoIncl -> failure x
Incl filenames -> failure x
transFileName :: FileName -> Result
transFileName x = case x of
FString str -> failure x
FIdent id -> failure x
FSlash filename -> failure x
FDot filename -> failure x
FMinus filename -> failure x
FAddId id filename -> failure x

505
src/GF/Source/SourceToGrammar.hs Normal file
View File

@@ -0,0 +1,505 @@
module SourceToGrammar where
import qualified Grammar as G
import qualified PrGrammar as GP
import qualified Modules as GM
import qualified Macros as M
import qualified Update as U
import qualified Option as GO
import qualified ModDeps as GD
import Ident
import AbsGF
import PrintGF
import RemoveLiT --- for bw compat
import Operations
import Monad
import Char
-- based on the skeleton Haskell module generated by the BNF converter
type Result = Err String
failure :: Show a => a -> Err b
failure x = Bad $ "Undefined case: " ++ show x
transIdent :: Ident -> Err Ident
transIdent x = case x of
x -> return x
transGrammar :: Grammar -> Err G.SourceGrammar
transGrammar x = case x of
Gr moddefs -> do
moddefs' <- mapM transModDef moddefs
GD.mkSourceGrammar moddefs'
transModDef :: ModDef -> Err (Ident, G.SourceModInfo)
transModDef x = case x of
MMain id0 id concspecs -> do
id0' <- transIdent id0
id' <- transIdent id
concspecs' <- mapM transConcSpec concspecs
return $ (id0', GM.ModMainGrammar (GM.MainGrammar id' concspecs'))
MAbstract id extends opens defs -> do
id' <- transIdent id
extends' <- transExtend extends
opens' <- transOpens opens
defs0 <- mapM transAbsDef $ getTopDefs defs
defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds]
flags <- return [f | Right fs <- defs0, f <- fs]
return $ (id', GM.ModMod (GM.Module GM.MTAbstract flags extends' opens' defs'))
MResource id extends opens defs -> do
id' <- transIdent id
extends' <- transExtend extends
opens' <- transOpens opens
defs0 <- mapM transResDef $ getTopDefs defs
defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds]
flags <- return [f | Right fs <- defs0, f <- fs]
return $ (id', GM.ModMod (GM.Module GM.MTResource flags extends' opens' defs'))
MConcrete id open extends opens defs -> do
id' <- transIdent id
open' <- transIdent open
extends' <- transExtend extends
opens' <- transOpens opens
defs0 <- mapM transCncDef $ getTopDefs defs
defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds]
flags <- return [f | Right fs <- defs0, f <- fs]
return $ (id',
GM.ModMod (GM.Module (GM.MTConcrete open') flags extends' opens' defs'))
MTransfer id open0 open extends opens defs -> do
id' <- transIdent id
open0' <- transOpen open0
open' <- transOpen open
extends' <- transExtend extends
opens' <- transOpens opens
defs0 <- mapM transAbsDef $ getTopDefs defs
defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds]
flags <- return [f | Right fs <- defs0, f <- fs]
return $ (id',
GM.ModMod (GM.Module (GM.MTTransfer open0' open') flags extends' opens' defs'))
MReuseAbs id0 id -> failure x
MReuseCnc id0 id -> failure x
MReuseAll r e c -> do
r' <- transIdent r
e' <- transExtend e
c' <- transIdent c
return $ (r', GM.ModMod (GM.Module (GM.MTReuse c') [] e' [] NT))
getTopDefs :: [TopDef] -> [TopDef]
getTopDefs x = x
transConcSpec :: ConcSpec -> Err (GM.MainConcreteSpec Ident)
transConcSpec x = case x of
ConcSpec id concexp -> do
id' <- transIdent id
(m,mi,mo) <- transConcExp concexp
return $ GM.MainConcreteSpec id' m mi mo
transConcExp :: ConcExp ->
Err (Ident, Maybe (GM.OpenSpec Ident),Maybe (GM.OpenSpec Ident))
transConcExp x = case x of
ConcExp id transfers -> do
id' <- transIdent id
trs <- mapM transTransfer transfers
tin <- case [o | Left o <- trs] of
[o] -> return $ Just o
[] -> return $ Nothing
_ -> Bad "ambiguous transfer in"
tout <- case [o | Right o <- trs] of
[o] -> return $ Just o
[] -> return $ Nothing
_ -> Bad "ambiguous transfer out"
return (id',tin,tout)
transTransfer :: Transfer ->
Err (Either (GM.OpenSpec Ident)(GM.OpenSpec Ident))
transTransfer x = case x of
TransferIn open -> liftM Left $ transOpen open
TransferOut open -> liftM Right $ transOpen open
transExtend :: Extend -> Err (Maybe Ident)
transExtend x = case x of
Ext id -> transIdent id >>= return . Just
NoExt -> return Nothing
transOpens :: Opens -> Err [GM.OpenSpec Ident]
transOpens x = case x of
NoOpens -> return []
Opens opens -> mapM transOpen opens
transOpen :: Open -> Err (GM.OpenSpec Ident)
transOpen x = case x of
OName id -> liftM GM.OSimple $ transIdent id
OQual id m -> liftM2 GM.OQualif (transIdent id) (transIdent m)
transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option])
transAbsDef x = case x of
DefCat catdefs -> do
catdefs' <- mapM transCatDef catdefs
returnl [(cat, G.AbsCat (yes cont) nope) | (cat,cont) <- catdefs']
DefFun fundefs -> do
fundefs' <- mapM transFunDef fundefs
returnl [(fun, G.AbsFun (yes typ) nope) | (funs,typ) <- fundefs', fun <- funs]
DefDef defs -> do
defs' <- liftM concat $ mapM getDefsGen defs
returnl [(c, G.AbsFun nope pe) | (c,(_,pe)) <- defs']
DefData _ -> returnl [] ----
DefTrans defs -> do
let (ids,vals) = unzip [(i,v) | FlagDef i v <- defs]
defs' <- liftM2 zip (mapM transIdent ids) (mapM transIdent vals)
returnl [(c, G.AbsTrans f) | (c,f) <- defs']
DefFlag defs -> liftM Right $ mapM transFlagDef defs
_ -> Bad $ "illegal definition in abstract module:" ++++ printTree x
returnl :: a -> Err (Either a b)
returnl = return . Left
transFlagDef :: FlagDef -> Err GO.Option
transFlagDef x = case x of
FlagDef f x -> return $ GO.Opt (prIdent f,[prIdent x])
transCatDef :: CatDef -> Err (Ident, G.Context)
transCatDef x = case x of
CatDef id ddecls -> liftM2 (,) (transIdent id)
(mapM transDDecl ddecls >>= return . concat)
transFunDef :: FunDef -> Err ([Ident], G.Type)
transFunDef x = case x of
FunDef ids typ -> liftM2 (,) (mapM transIdent ids) (transExp typ)
transResDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option])
transResDef x = case x of
DefPar pardefs -> do
pardefs' <- mapM transParDef pardefs
returnl $ [(p, G.ResParam (if null pars
then nope -- abstract param type
else (yes pars))) | (p,pars) <- pardefs']
++ [(f, G.ResValue (yes (M.mkProdSimple co (G.Cn p)))) |
(p,pars) <- pardefs', (f,co) <- pars]
DefOper defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl [(f, G.ResOper pt pe) | (f,(pt,pe)) <- defs']
DefLintype defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl [(f, G.ResOper pt pe) | (f,(pt,pe)) <- defs']
DefFlag defs -> liftM Right $ mapM transFlagDef defs
_ -> Bad $ "illegal definition form in resource" +++ printTree x
transParDef :: ParDef -> Err (Ident, [G.Param])
transParDef x = case x of
ParDef id params -> liftM2 (,) (transIdent id) (mapM transParConstr params)
ParDefAbs id -> liftM2 (,) (transIdent id) (return [])
_ -> Bad $ "illegal definition in resource:" ++++ printTree x
transCncDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option])
transCncDef x = case x of
DefLincat defs -> do
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, G.CncCat (yes t) nope nope) | (f,t) <- defs']
DefLindef defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl [(f, G.CncCat pt pe nope) | (f,(pt,pe)) <- defs']
DefLin defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl [(f, G.CncFun Nothing pe nope) | (f,(_,pe)) <- defs']
DefPrintCat defs -> do
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, G.CncCat nope nope (yes e)) | (f,e) <- defs']
DefPrintFun defs -> do
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs']
DefPrintOld defs -> do -- a guess, for backward compatibility
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs']
DefFlag defs -> liftM Right $ mapM transFlagDef defs
DefPattern defs -> do
defs' <- liftM concat $ mapM getDefs defs
let defs2 = [(f, termInPattern t) | (f,(_,Yes t)) <- defs']
returnl [(f, G.CncFun Nothing (yes t) nope) | (f,t) <- defs2]
_ -> Bad $ "illegal definition in concrete syntax:" ++++ printTree x
transPrintDef :: PrintDef -> Err [(Ident,G.Term)]
transPrintDef x = case x of
PrintDef id exp -> do
(ids,e) <- liftM2 (,) (mapM transIdent id) (transExp exp)
return $ [(i,e) | i <- ids]
getDefsGen :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))]
getDefsGen d = case d of
DDecl ids t -> do
ids' <- mapM transIdent ids
t' <- transExp t
return [(i,(yes t', nope)) | i <- ids']
DDef ids e -> do
ids' <- mapM transIdent ids
e' <- transExp e
return [(i,(nope, yes e')) | i <- ids']
DFull ids t e -> do
ids' <- mapM transIdent ids
t' <- transExp t
e' <- transExp e
return [(i,(yes t', yes e')) | i <- ids']
DPatt id patts e -> do
id' <- transIdent id
ps' <- mapM transPatt patts
e' <- transExp e
return [(id',(nope, yes (G.Eqs [(ps',e')])))]
-- sometimes you need this special case, e.g. in linearization rules
getDefs :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))]
getDefs d = case d of
DPatt id patts e -> do
id' <- transIdent id
xs <- mapM tryMakeVar patts
e' <- transExp e
return [(id',(nope, yes (M.mkAbs xs e')))]
_ -> getDefsGen d
-- accepts a pattern that is either a variable or a wild card
tryMakeVar :: Patt -> Err Ident
tryMakeVar p = do
p' <- transPatt p
case p' of
G.PV i -> return i
G.PW -> return identW
_ -> Bad $ "not a legal pattern in lambda binding" +++ GP.prt p'
transExp :: Exp -> Err G.Term
transExp x = case x of
EIdent id -> liftM G.Vr $ transIdent id
EConstr id -> liftM G.Con $ transIdent id
ECons id -> liftM G.Cn $ transIdent id
EQConstr m c -> liftM2 G.QC (transIdent m) (transIdent c)
EQCons m c -> liftM2 G.Q (transIdent m) (transIdent c)
EString str -> return $ G.K str
ESort sort -> liftM G.Sort $ transSort sort
EInt n -> return $ G.EInt $ fromInteger n
EMeta -> return $ M.meta $ M.int2meta 0
EEmpty -> return G.Empty
EStrings [] -> return G.Empty
EStrings str -> return $ foldr1 G.C $ map G.K $ words str
ERecord defs -> erecord2term defs
ETupTyp _ _ -> do
let tups t = case t of
ETupTyp x y -> tups x ++ [y] -- right-associative parsing
_ -> [t]
es <- mapM transExp $ tups x
return $ G.RecType $ M.tuple2recordType es
ETuple tuplecomps -> do
es <- mapM transExp [e | TComp e <- tuplecomps]
return $ G.R $ M.tuple2record es
EProj exp id -> liftM2 G.P (transExp exp) (trLabel id)
EApp exp0 exp -> liftM2 G.App (transExp exp0) (transExp exp)
ETable cases -> liftM (G.T G.TRaw) (transCases cases)
ETTable exp cases ->
liftM2 (\t c -> G.T (G.TTyped t) c) (transExp exp) (transCases cases)
ECase exp cases -> do
exp' <- transExp exp
cases' <- transCases cases
return $ G.S (G.T G.TRaw cases') exp'
ECTable binds exp -> liftM2 M.mkCTable (mapM transBind binds) (transExp exp)
EVariants exps -> liftM G.FV $ mapM transExp exps
EPre exp alts -> liftM2 (curry G.Alts) (transExp exp) (mapM transAltern alts)
EStrs exps -> liftM G.Strs $ mapM transExp exps
ESelect exp0 exp -> liftM2 G.S (transExp exp0) (transExp exp)
EExtend exp0 exp -> liftM2 G.ExtR (transExp exp0) (transExp exp)
EAbstr binds exp -> liftM2 M.mkAbs (mapM transBind binds) (transExp exp)
ETyped exp0 exp -> liftM2 G.Typed (transExp exp0) (transExp exp)
EProd decl exp -> liftM2 M.mkProdSimple (transDecl decl) (transExp exp)
ETType exp0 exp -> liftM2 G.Table (transExp exp0) (transExp exp)
EConcat exp0 exp -> liftM2 G.C (transExp exp0) (transExp exp)
EGlue exp0 exp -> liftM2 G.Glue (transExp exp0) (transExp exp)
ELet defs exp -> do
exp' <- transExp exp
defs0 <- mapM locdef2fields defs
defs' <- mapM tryLoc $ concat defs0
return $ M.mkLet defs' exp'
where
tryLoc (c,(mty,Just e)) = return (c,(mty,e))
tryLoc (c,_) = Bad $ "local definition of" +++ GP.prt c +++ "without value"
ELString (LString str) -> return $ G.K str
ELin id -> liftM G.LiT $ transIdent id
_ -> Bad $ "translation not yet defined for" +++ printTree x ----
--- this is complicated: should we change Exp or G.Term ?
erecord2term :: [LocDef] -> Err G.Term
erecord2term ds = do
ds' <- mapM locdef2fields ds
mkR $ concat ds'
where
mkR fs = do
fs' <- transF fs
return $ case fs' of
Left ts -> G.RecType ts
Right ds -> G.R ds
transF [] = return $ Left [] --- empty record always interpreted as record type
transF fs@(f:_) = case f of
(lab,(Just ty,Nothing)) -> mapM tryRT fs >>= return . Left
_ -> mapM tryR fs >>= return . Right
tryRT f = case f of
(lab,(Just ty,Nothing)) -> return (M.ident2label lab,ty)
_ -> Bad $ "illegal record type field" +++ GP.prt (fst f) --- manifest fields ?!
tryR f = case f of
(lab,(mty, Just t)) -> return (M.ident2label lab,(mty,t))
_ -> Bad $ "illegal record field" +++ GP.prt (fst f)
locdef2fields d = case d of
LDDecl ids t -> do
labs <- mapM transIdent ids
t' <- transExp t
return [(lab,(Just t',Nothing)) | lab <- labs]
LDDef ids e -> do
labs <- mapM transIdent ids
e' <- transExp e
return [(lab,(Nothing, Just e')) | lab <- labs]
LDFull ids t e -> do
labs <- mapM transIdent ids
t' <- transExp t
e' <- transExp e
return [(lab,(Just t', Just e')) | lab <- labs]
trLabel :: Label -> Err G.Label
trLabel x = case x of
-- this case is for bward compatibiity and should be removed
LIdent (IC ('v':ds)) | all isDigit ds -> return $ G.LVar $ readIntArg ds
LIdent (IC s) -> return $ G.LIdent s
LVar x -> return $ G.LVar $ fromInteger x
transSort :: Sort -> Err String
transSort x = case x of
_ -> return $ printTree x
transPatt :: Patt -> Err G.Patt
transPatt x = case x of
PW -> return G.wildPatt
PV id -> liftM G.PV $ transIdent id
PC id patts -> liftM2 G.PC (transIdent id) (mapM transPatt patts)
PCon id -> liftM2 G.PC (transIdent id) (return [])
PInt n -> return $ G.PInt (fromInteger n)
PStr str -> return $ G.PString str
PR pattasss -> do
let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss]
ls = map LIdent $ concat lss
liftM G.PR $ liftM2 zip (mapM trLabel ls) (mapM transPatt ps)
PTup pcs ->
liftM (G.PR . M.tuple2recordPatt) (mapM transPatt [e | PTComp e <- pcs])
PQ id0 id -> liftM3 G.PP (transIdent id0) (transIdent id) (return [])
PQC id0 id patts ->
liftM3 G.PP (transIdent id0) (transIdent id) (mapM transPatt patts)
transBind :: Bind -> Err Ident
transBind x = case x of
BIdent id -> transIdent id
BWild -> return identW
transDecl :: Decl -> Err [G.Decl]
transDecl x = case x of
DDec binds exp -> do
xs <- mapM transBind binds
exp' <- transExp exp
return [(x,exp') | x <- xs]
DExp exp -> liftM (return . M.mkDecl) $ transExp exp
transCases :: [Case] -> Err [G.Case]
transCases = liftM concat . mapM transCase
transCase :: Case -> Err [G.Case]
transCase (Case pattalts exp) = do
patts <- mapM transPatt [p | AltP p <- pattalts]
exp' <- transExp exp
return [(p,exp') | p <- patts]
transAltern :: Altern -> Err (G.Term, G.Term)
transAltern x = case x of
Alt exp0 exp -> liftM2 (,) (transExp exp0) (transExp exp)
transParConstr :: ParConstr -> Err G.Param
transParConstr x = case x of
ParConstr id ddecls -> do
id' <- transIdent id
ddecls' <- mapM transDDecl ddecls
return (id',concat ddecls')
transDDecl :: DDecl -> Err [G.Decl]
transDDecl x = case x of
DDDec binds exp -> transDecl $ DDec binds exp
DDExp exp -> transDecl $ DExp exp
-- to deal with the old format, sort judgements in three modules, forming
-- their names from a given string, e.g. file name or overriding user-given string
transOldGrammar :: OldGrammar -> String -> Err G.SourceGrammar
transOldGrammar x name = case x of
OldGr includes topdefs -> do --- includes must be collected separately
let moddefs = sortTopDefs topdefs
g1 <- transGrammar $ Gr moddefs
removeLiT g1 --- needed for bw compatibility with an obsolete feature
where
sortTopDefs ds = [mkAbs a,mkRes r,mkCnc c]
where (a,r,c) = foldr srt ([],[],[]) ds
srt d (a,r,c) = case d of
DefCat catdefs -> (d:a,r,c)
DefFun fundefs -> (d:a,r,c)
DefDef defs -> (d:a,r,c)
DefData pardefs -> (d:a,r,c)
DefPar pardefs -> (a,d:r,c)
DefOper defs -> (a,d:r,c)
DefLintype defs -> (a,d:r,c)
DefLincat defs -> (a,r,d:c)
DefLindef defs -> (a,r,d:c)
DefLin defs -> (a,r,d:c)
DefPattern defs -> (a,r,d:c)
DefFlag defs -> (a,r,d:c) --- a guess
DefPrintCat printdefs -> (a,r,d:c)
DefPrintFun printdefs -> (a,r,d:c)
DefPrintOld printdefs -> (a,r,d:c)
mkAbs a = MAbstract absName NoExt (Opens []) $ topDefs a
mkRes r = MResource resName NoExt (Opens []) $ topDefs r
mkCnc r = MConcrete cncName absName NoExt (Opens [OName resName]) $ topDefs r
topDefs t = t
absName = identC topic
resName = identC ("Res" ++ lang)
cncName = identC lang
(beg,rest) = span (/='.') name
(topic,lang) = case rest of -- to avoid overwriting old files
".gf" -> ("Abs" ++ beg,"Cnc" ++ beg)
[] -> ("Abs" ++ beg,"Cnc" ++ beg)
_:s -> (beg, takeWhile (/='.') s)
transInclude :: Include -> Err [FilePath]
transInclude x = case x of
NoIncl -> return []
Incl filenames -> return $ map trans filenames
where
trans f = case f of
FString s -> s
FIdent (IC s) -> s
FSlash filename -> '/' : trans filename
FDot filename -> '.' : trans filename
FMinus filename -> '-' : trans filename
FAddId (IC s) filename -> s ++ trans filename
termInPattern :: G.Term -> G.Term
termInPattern t = M.mkAbs xx $ G.R [(s, (Nothing, toP body))] where
toP t = case t of
G.Vr x -> G.P t s
_ -> M.composSafeOp toP t
s = G.LIdent "s"
(xx,body) = abss [] t
abss xs t = case t of
G.Abs x b -> abss (x:xs) b
_ -> (reverse xs,t)

22
src/GF/Source/TestGF.hs Normal file
View File

@@ -0,0 +1,22 @@
-- automatically generated by BNF Converter
module TestGF where
import LexGF
import ParGF
import SkelGF
import PrintGF
import AbsGF
import ErrM
type ParseFun a = [Token] -> Err a
runFile :: (Print a, Show a) => ParseFun a -> FilePath -> IO()
runFile p f = readFile f >>= run p
run :: (Print a, Show a) => ParseFun a -> String -> IO()
run p s = case (p (myLexer s)) of
Bad s -> do putStrLn "\nParse Failed...\n"
putStrLn s
Ok tree -> do putStrLn "\nParse Successful!"
putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree
putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree