diff options
| author | krasimir <krasimir@chalmers.se> | 2009-09-14 16:23:23 +0000 |
|---|---|---|
| committer | krasimir <krasimir@chalmers.se> | 2009-09-14 16:23:23 +0000 |
| commit | 14dfbcc624dadffcb54e58cbb26f3af24b77595a (patch) | |
| tree | 980f52c77f0f9bb55242aee874fcc7dc88979870 /src/GF/Source | |
| parent | 9f3534b3bb4e6bc45301b0ddb9468ca721b3dc17 (diff) | |
clean up the GF.Grammar API
Diffstat (limited to 'src/GF/Source')
| -rw-r--r-- | src/GF/Source/AbsGF.hs | 323 | ||||
| -rw-r--r-- | src/GF/Source/CF.hs | 128 | ||||
| -rw-r--r-- | src/GF/Source/GF.cf | 372 | ||||
| -rw-r--r-- | src/GF/Source/GrammarToSource.hs | 233 | ||||
| -rw-r--r-- | src/GF/Source/Makefile | 7 | ||||
| -rw-r--r-- | src/GF/Source/PrintGF.hs | 551 | ||||
| -rw-r--r-- | src/GF/Source/SourceToGrammar.hs | 733 |
7 files changed, 0 insertions, 2347 deletions
diff --git a/src/GF/Source/AbsGF.hs b/src/GF/Source/AbsGF.hs deleted file mode 100644 index 37c0e5c52..000000000 --- a/src/GF/Source/AbsGF.hs +++ /dev/null @@ -1,323 +0,0 @@ -module GF.Source.AbsGF where - --- Haskell module generated by the BNF converter - -import qualified Data.ByteString.Char8 as BS -newtype LString = LString BS.ByteString deriving (Eq,Ord,Show) -newtype PIdent = PIdent ((Int,Int),BS.ByteString) deriving (Eq,Ord,Show) -data Grammar = - Gr [ModDef] - deriving (Eq,Ord,Show) - -data ModDef = - MMain PIdent PIdent [ConcSpec] - | MModule ComplMod ModType ModBody - deriving (Eq,Ord,Show) - -data ConcSpec = - ConcSpec PIdent ConcExp - deriving (Eq,Ord,Show) - -data ConcExp = - ConcExp PIdent [Transfer] - deriving (Eq,Ord,Show) - -data Transfer = - TransferIn Open - | TransferOut Open - deriving (Eq,Ord,Show) - -data ModHeader = - MModule2 ComplMod ModType ModHeaderBody - deriving (Eq,Ord,Show) - -data ModHeaderBody = - MBody2 Extend Opens - | MNoBody2 [Included] - | MWith2 Included [Open] - | MWithBody2 Included [Open] Opens - | MWithE2 [Included] Included [Open] - | MWithEBody2 [Included] Included [Open] Opens - | MReuse2 PIdent - | MUnion2 [Included] - deriving (Eq,Ord,Show) - -data ModType = - MTAbstract PIdent - | MTResource PIdent - | MTInterface PIdent - | MTConcrete PIdent PIdent - | MTInstance PIdent PIdent - | MTTransfer PIdent Open Open - deriving (Eq,Ord,Show) - -data ModBody = - MBody Extend Opens [TopDef] - | MNoBody [Included] - | MWith Included [Open] - | MWithBody Included [Open] Opens [TopDef] - | MWithE [Included] Included [Open] - | MWithEBody [Included] Included [Open] Opens [TopDef] - | MReuse PIdent - | MUnion [Included] - deriving (Eq,Ord,Show) - -data Extend = - Ext [Included] - | NoExt - deriving (Eq,Ord,Show) - -data Opens = - NoOpens - | OpenIn [Open] - deriving (Eq,Ord,Show) - -data Open = - OName PIdent - | OQualQO QualOpen PIdent - | OQual QualOpen PIdent PIdent - deriving (Eq,Ord,Show) - -data ComplMod = - CMCompl - | CMIncompl - deriving (Eq,Ord,Show) - -data QualOpen = - QOCompl - | QOIncompl - | QOInterface - deriving (Eq,Ord,Show) - -data Included = - IAll PIdent - | ISome PIdent [PIdent] - | IMinus PIdent [PIdent] - deriving (Eq,Ord,Show) - -data Def = - DDecl [Name] Exp - | DDef [Name] Exp - | DPatt Name [Patt] Exp - | DFull [Name] Exp Exp - deriving (Eq,Ord,Show) - -data TopDef = - DefCat [CatDef] - | DefFun [FunDef] - | DefFunData [FunDef] - | DefDef [Def] - | DefData [DataDef] - | DefTrans [Def] - | DefPar [ParDef] - | DefOper [Def] - | DefLincat [PrintDef] - | DefLindef [Def] - | DefLin [Def] - | DefPrintCat [PrintDef] - | DefPrintFun [PrintDef] - | DefFlag [FlagDef] - | DefPrintOld [PrintDef] - | DefLintype [Def] - | DefPattern [Def] - | DefPackage PIdent [TopDef] - | DefVars [Def] - | DefTokenizer PIdent - deriving (Eq,Ord,Show) - -data CatDef = - SimpleCatDef PIdent [DDecl] - | ListCatDef PIdent [DDecl] - | ListSizeCatDef PIdent [DDecl] Integer - deriving (Eq,Ord,Show) - -data FunDef = - FunDef [PIdent] Exp - deriving (Eq,Ord,Show) - -data DataDef = - DataDef PIdent [DataConstr] - deriving (Eq,Ord,Show) - -data DataConstr = - DataId PIdent - | DataQId PIdent PIdent - deriving (Eq,Ord,Show) - -data ParDef = - ParDefDir PIdent [ParConstr] - | ParDefIndir PIdent PIdent - | ParDefAbs PIdent - deriving (Eq,Ord,Show) - -data ParConstr = - ParConstr PIdent [DDecl] - deriving (Eq,Ord,Show) - -data PrintDef = - PrintDef [Name] Exp - deriving (Eq,Ord,Show) - -data FlagDef = - FlagDef PIdent PIdent - deriving (Eq,Ord,Show) - -data Name = - IdentName PIdent - | ListName PIdent - deriving (Eq,Ord,Show) - -data LocDef = - LDDecl [PIdent] Exp - | LDDef [PIdent] Exp - | LDFull [PIdent] Exp Exp - deriving (Eq,Ord,Show) - -data Exp = - EIdent PIdent - | EConstr PIdent - | ECons PIdent - | ESort Sort - | EString String - | EInt Integer - | EFloat Double - | EMeta - | EEmpty - | EData - | EList PIdent Exps - | EStrings String - | ERecord [LocDef] - | ETuple [TupleComp] - | EIndir PIdent - | ETyped Exp Exp - | EProj Exp Label - | EQConstr PIdent PIdent - | EQCons PIdent PIdent - | EApp Exp Exp - | ETable [Case] - | ETTable Exp [Case] - | EVTable Exp [Exp] - | ECase Exp [Case] - | EVariants [Exp] - | EPre Exp [Altern] - | EStrs [Exp] - | EConAt PIdent Exp - | EPatt Patt - | EPattType Exp - | ESelect Exp Exp - | ETupTyp Exp Exp - | EExtend Exp Exp - | EGlue Exp Exp - | EConcat Exp Exp - | EVariant Exp Exp - | EAbstr [Bind] Exp - | ECTable [Bind] Exp - | EProd Decl Exp - | ETType Exp Exp - | ELet [LocDef] Exp - | ELetb [LocDef] Exp - | EWhere Exp [LocDef] - | EEqs [Equation] - | EExample Exp String - | ELString LString - | ELin PIdent - deriving (Eq,Ord,Show) - -data Exps = - NilExp - | ConsExp Exp Exps - deriving (Eq,Ord,Show) - -data Patt = - PChar - | PChars String - | PMacro PIdent - | PM PIdent PIdent - | PW - | PV PIdent - | PCon PIdent - | PQ PIdent PIdent - | PInt Integer - | PFloat Double - | PStr String - | PR [PattAss] - | PTup [PattTupleComp] - | PC PIdent [Patt] - | PQC PIdent PIdent [Patt] - | PDisj Patt Patt - | PSeq Patt Patt - | PRep Patt - | PAs PIdent Patt - | PNeg Patt - deriving (Eq,Ord,Show) - -data PattAss = - PA [PIdent] Patt - deriving (Eq,Ord,Show) - -data Label = - LIdent PIdent - | LVar Integer - deriving (Eq,Ord,Show) - -data Sort = - Sort_Type - | Sort_PType - | Sort_Tok - | Sort_Str - | Sort_Strs - deriving (Eq,Ord,Show) - -data Bind = - BIdent PIdent - | 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 Patt 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 PIdent - | FSlash FileName - | FDot FileName - | FMinus FileName - | FAddId PIdent FileName - deriving (Eq,Ord,Show) - diff --git a/src/GF/Source/CF.hs b/src/GF/Source/CF.hs deleted file mode 100644 index 7f0dcd5da..000000000 --- a/src/GF/Source/CF.hs +++ /dev/null @@ -1,128 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/15 17:56:13 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.13 $ --- --- parsing CF grammars and converting them to GF ------------------------------------------------------------------------------ - -module GF.Source.CF (getCF) where - -import GF.Grammar.Grammar -import GF.Grammar.Macros -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Infra.Option - -import GF.Data.Operations - -import Data.Char -import Data.List -import qualified Data.ByteString.Char8 as BS - -getCF :: String -> String -> Err SourceGrammar -getCF name = fmap (cf2gf name) . pCF - ---------------------- --- the parser ------- ---------------------- - -pCF :: String -> Err CF -pCF s = do - rules <- mapM getCFRule $ filter isRule $ lines s - return $ concat rules - where - isRule line = case dropWhile isSpace line of - '-':'-':_ -> False - _ -> not $ all isSpace line - --- rules have an amazingly easy parser, if we use the format --- fun. C -> item1 item2 ... where unquoted items are treated as cats --- Actually would be nice to add profiles to this. - -getCFRule :: String -> Err [CFRule] -getCFRule s = getcf (wrds s) where - getcf ws = case ws of - fun : cat : a : its | isArrow a -> - Ok [(init fun, (cat, map mkIt its))] - cat : a : its | isArrow a -> - Ok [(mkFun cat it, (cat, map mkIt it)) | it <- chunk its] - _ -> Bad (" invalid rule:" +++ s) - isArrow a = elem a ["->", "::="] - mkIt w = case w of - ('"':w@(_:_)) -> Right (init w) - _ -> Left w - chunk its = case its of - [] -> [[]] - _ -> chunks "|" its - mkFun cat its = case its of - [] -> cat ++ "_" - _ -> concat $ intersperse "_" (cat : map clean its) -- CLE style - clean = filter isAlphaNum -- to form valid identifiers - wrds = takeWhile (/= ";") . words -- to permit semicolon in the end - -type CF = [CFRule] - -type CFRule = (CFFun, (CFCat, [CFItem])) - -type CFItem = Either CFCat String - -type CFCat = String -type CFFun = String - --------------------------- --- the compiler ---------- --------------------------- - -cf2gf :: String -> CF -> SourceGrammar -cf2gf name cf = MGrammar [ - (aname, addFlag (modifyFlags (\fs -> fs{optStartCat = Just cat})) - (emptyModInfo{mtype = MTAbstract, jments = abs})), - (cname, emptyModInfo{mtype = MTConcrete aname, jments = cnc}) - ] - where - (abs,cnc,cat) = cf2grammar cf - aname = identS $ name ++ "Abs" - cname = identS name - - -cf2grammar :: CF -> (BinTree Ident Info, BinTree Ident Info, String) -cf2grammar rules = (buildTree abs, buildTree conc, cat) where - abs = cats ++ funs - conc = lincats ++ lins - cat = case rules of - (_,(c,_)):_ -> c -- the value category of the first rule - _ -> error "empty CF" - cats = [(cat, AbsCat (Just []) (Just [])) | - cat <- nub (concat (map cf2cat rules))] ----notPredef cat - lincats = [(cat, CncCat (Just defLinType) Nothing Nothing) | (cat,AbsCat _ _) <- cats] - (funs,lins) = unzip (map cf2rule rules) - -cf2cat :: CFRule -> [Ident] -cf2cat (_,(cat, items)) = map identS $ cat : [c | Left c <- items] - -cf2rule :: CFRule -> ((Ident,Info),(Ident,Info)) -cf2rule (fun, (cat, items)) = (def,ldef) where - f = identS fun - def = (f, AbsFun (Just (mkProd (args', Cn (identS cat), []))) Nothing Nothing) - args0 = zip (map (identS . ("x" ++) . show) [0..]) items - args = [(v, Cn (identS c)) | (v, Left c) <- args0] - args' = [(identS "_", Cn (identS c)) | (_, Left c) <- args0] - ldef = (f, CncFun - Nothing - (Just (mkAbs (map fst args) - (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)]))) - Nothing) - mkIt (v, Left _) = P (Vr v) theLinLabel - mkIt (_, Right a) = K a - foldconcat [] = K "" - foldconcat tt = foldr1 C tt - -identS = identC . BS.pack - diff --git a/src/GF/Source/GF.cf b/src/GF/Source/GF.cf deleted file mode 100644 index 2fe25e4d5..000000000 --- a/src/GF/Source/GF.cf +++ /dev/null @@ -1,372 +0,0 @@ --- AR 2/5/2003, 14-16 o'clock, Torino - --- 17/6/2007: marked with suffix --% those lines that are obsolete and --- should not be included in documentation - -entrypoints Grammar, ModDef, - OldGrammar, --% - ModHeader, - Exp ; -- let's see if more are needed - -comment "--" ; -comment "{-" "-}" ; - --- the top-level grammar - -Gr. Grammar ::= [ModDef] ; - --- semicolon after module is permitted but not obligatory - -terminator ModDef "" ; -_. ModDef ::= ModDef ";" ; - --- The $main$ multilingual grammar structure --% - -MMain. ModDef ::= "grammar" PIdent "=" "{" "abstract" "=" PIdent ";" [ConcSpec] "}" ;--% - -ConcSpec. ConcSpec ::= PIdent "=" ConcExp ;--% -separator ConcSpec ";" ;--% - -ConcExp. ConcExp ::= PIdent [Transfer] ;--% - -separator Transfer "" ;--% -TransferIn. Transfer ::= "(" "transfer" "in" Open ")" ; --% -TransferOut. Transfer ::= "(" "transfer" "out" Open ")" ; --% - --- the module header - -MModule2. ModHeader ::= ComplMod ModType "=" ModHeaderBody ; - -MBody2. ModHeaderBody ::= Extend Opens ; -MNoBody2. ModHeaderBody ::= [Included] ; -MWith2. ModHeaderBody ::= Included "with" [Open] ; -MWithBody2. ModHeaderBody ::= Included "with" [Open] "**" Opens ; -MWithE2. ModHeaderBody ::= [Included] "**" Included "with" [Open] ; -MWithEBody2. ModHeaderBody ::= [Included] "**" Included "with" [Open] "**" Opens ; - -MReuse2. ModHeaderBody ::= "reuse" PIdent ; --% -MUnion2. ModHeaderBody ::= "union" [Included] ;--% - --- the individual modules - -MModule. ModDef ::= ComplMod ModType "=" ModBody ; - -MTAbstract. ModType ::= "abstract" PIdent ; -MTResource. ModType ::= "resource" PIdent ; -MTInterface. ModType ::= "interface" PIdent ; -MTConcrete. ModType ::= "concrete" PIdent "of" PIdent ; -MTInstance. ModType ::= "instance" PIdent "of" PIdent ; -MTTransfer. ModType ::= "transfer" PIdent ":" Open "->" Open ; - - -MBody. ModBody ::= Extend Opens "{" [TopDef] "}" ; -MNoBody. ModBody ::= [Included] ; -MWith. ModBody ::= Included "with" [Open] ; -MWithBody. ModBody ::= Included "with" [Open] "**" Opens "{" [TopDef] "}" ; -MWithE. ModBody ::= [Included] "**" Included "with" [Open] ; -MWithEBody. ModBody ::= [Included] "**" Included "with" [Open] "**" Opens "{" [TopDef] "}" ; - -MReuse. ModBody ::= "reuse" PIdent ; --% -MUnion. ModBody ::= "union" [Included] ;--% - -separator TopDef "" ; - -Ext. Extend ::= [Included] "**" ; -NoExt. Extend ::= ; - -separator Open "," ; -NoOpens. Opens ::= ; -OpenIn. Opens ::= "open" [Open] "in" ; - -OName. Open ::= PIdent ; -OQualQO. Open ::= "(" QualOpen PIdent ")" ; -OQual. Open ::= "(" QualOpen PIdent "=" PIdent ")" ; - -CMCompl. ComplMod ::= ; -CMIncompl. ComplMod ::= "incomplete" ; - -QOCompl. QualOpen ::= ; -QOIncompl. QualOpen ::= "incomplete" ;--% -QOInterface. QualOpen ::= "interface" ;--% - -separator Included "," ; - -IAll. Included ::= PIdent ; -ISome. Included ::= PIdent "[" [PIdent] "]" ; -IMinus. Included ::= PIdent "-" "[" [PIdent] "]" ; - --- definitions after the $oper$ keywords - -DDecl. Def ::= [Name] ":" Exp ; -DDef. Def ::= [Name] "=" Exp ; -DPatt. Def ::= Name [Patt] "=" Exp ; -- non-empty pattern list -DFull. Def ::= [Name] ":" Exp "=" Exp ; - --- top-level definitions - -DefCat. TopDef ::= "cat" [CatDef] ; -DefFun. TopDef ::= "fun" [FunDef] ; -DefFunData.TopDef ::= "data" [FunDef] ; -DefDef. TopDef ::= "def" [Def] ; -DefData. TopDef ::= "data" [DataDef] ; - -DefTrans. TopDef ::= "transfer" [Def] ;--% - -DefPar. TopDef ::= "param" [ParDef] ; -DefOper. TopDef ::= "oper" [Def] ; - -DefLincat. TopDef ::= "lincat" [PrintDef] ; -DefLindef. TopDef ::= "lindef" [Def] ; -DefLin. TopDef ::= "lin" [Def] ; - -DefPrintCat. TopDef ::= "printname" "cat" [PrintDef] ; -DefPrintFun. TopDef ::= "printname" "fun" [PrintDef] ; -DefFlag. TopDef ::= "flags" [FlagDef] ; - -SimpleCatDef. CatDef ::= PIdent [DDecl] ; -ListCatDef. CatDef ::= "[" PIdent [DDecl] "]" ; -ListSizeCatDef. CatDef ::= "[" PIdent [DDecl] "]" "{" Integer "}" ; - -FunDef. FunDef ::= [PIdent] ":" Exp ; - -DataDef. DataDef ::= PIdent "=" [DataConstr] ; -DataId. DataConstr ::= PIdent ; -DataQId. DataConstr ::= PIdent "." PIdent ; -separator DataConstr "|" ; - - -ParDefDir. ParDef ::= PIdent "=" [ParConstr] ; -ParDefIndir. ParDef ::= PIdent "=" "(" "in" PIdent ")" ; -ParDefAbs. ParDef ::= PIdent ; - -ParConstr. ParConstr ::= PIdent [DDecl] ; - -PrintDef. PrintDef ::= [Name] "=" Exp ; - -FlagDef. FlagDef ::= PIdent "=" PIdent ; - -terminator nonempty Def ";" ; -terminator nonempty CatDef ";" ; -terminator nonempty FunDef ";" ; -terminator nonempty DataDef ";" ; -terminator nonempty ParDef ";" ; - -terminator nonempty PrintDef ";" ; -terminator nonempty FlagDef ";" ; - -separator ParConstr "|" ; - -separator nonempty PIdent "," ; - --- names of categories and functions in definition LHS - -IdentName. Name ::= PIdent ; -ListName. Name ::= "[" PIdent "]" ; - -separator nonempty Name "," ; - --- definitions in records and $let$ expressions - -LDDecl. LocDef ::= [PIdent] ":" Exp ; -LDDef. LocDef ::= [PIdent] "=" Exp ; -LDFull. LocDef ::= [PIdent] ":" Exp "=" Exp ; - -separator LocDef ";" ; - --- terms and types - -EIdent. Exp6 ::= PIdent ; -EConstr. Exp6 ::= "{" PIdent "}" ;--% -ECons. Exp6 ::= "%" PIdent "%" ;--% -ESort. Exp6 ::= Sort ; -EString. Exp6 ::= String ; -EInt. Exp6 ::= Integer ; -EFloat. Exp6 ::= Double ; -EMeta. Exp6 ::= "?" ; -EEmpty. Exp6 ::= "[" "]" ; -EData. Exp6 ::= "data" ; -EList. Exp6 ::= "[" PIdent Exps "]" ; -EStrings. Exp6 ::= "[" String "]" ; -ERecord. Exp6 ::= "{" [LocDef] "}" ; -- ! -ETuple. Exp6 ::= "<" [TupleComp] ">" ; --- needed for separator "," -EIndir. Exp6 ::= "(" "in" PIdent ")" ; -- indirection, used in judgements --% -ETyped. Exp6 ::= "<" Exp ":" Exp ">" ; -- typing, used for annotations - -EProj. Exp5 ::= Exp5 "." Label ; -EQConstr. Exp5 ::= "{" PIdent "." PIdent "}" ; -- qualified constructor --% -EQCons. Exp5 ::= "%" PIdent "." PIdent ; -- qualified constant --% - -EApp. Exp4 ::= Exp4 Exp5 ; -ETable. Exp4 ::= "table" "{" [Case] "}" ; -ETTable. Exp4 ::= "table" Exp6 "{" [Case] "}" ; -EVTable. Exp4 ::= "table" Exp6 "[" [Exp] "]" ; -ECase. Exp4 ::= "case" Exp "of" "{" [Case] "}" ; -EVariants. Exp4 ::= "variants" "{" [Exp] "}" ; ---- EPreCase. Exp4 ::= "pre" "{" [Case] "}" ; -EPre. Exp4 ::= "pre" "{" Exp ";" [Altern] "}" ; -EStrs. Exp4 ::= "strs" "{" [Exp] "}" ; -EConAt. Exp4 ::= PIdent "@" Exp6 ; --% - -EPatt. Exp4 ::= "#" Patt2 ; -EPattType. Exp4 ::= "pattern" Exp5 ; - -ESelect. Exp3 ::= Exp3 "!" Exp4 ; -ETupTyp. Exp3 ::= Exp3 "*" Exp4 ; -EExtend. Exp3 ::= Exp3 "**" Exp4 ; - -EGlue. Exp2 ::= Exp3 "+" Exp2 ; - -EConcat. Exp1 ::= Exp2 "++" Exp1 ; - -EVariant. Exp ::= Exp1 "|" Exp ; -EAbstr. Exp ::= "\\" [Bind] "->" Exp ; -ECTable. Exp ::= "\\""\\" [Bind] "=>" Exp ; -EProd. Exp ::= Decl "->" Exp ; -ETType. Exp ::= Exp3 "=>" Exp ; -- these are thus right associative -ELet. Exp ::= "let" "{" [LocDef] "}" "in" Exp ; -ELetb. Exp ::= "let" [LocDef] "in" Exp ; -EWhere. Exp ::= Exp3 "where" "{" [LocDef] "}" ; -EEqs. Exp ::= "fn" "{" [Equation] "}" ; --% - -EExample. Exp ::= "in" Exp5 String ; - -coercions Exp 6 ; - -separator Exp ";" ; -- in variants - --- list of arguments to category -NilExp. Exps ::= ; -ConsExp. Exps ::= Exp6 Exps ; -- Exp6 to force parantheses - --- patterns - -PChar. Patt2 ::= "?" ; -PChars. Patt2 ::= "[" String "]" ; -PMacro. Patt2 ::= "#" PIdent ; -PM. Patt2 ::= "#" PIdent "." PIdent ; -PW. Patt2 ::= "_" ; -PV. Patt2 ::= PIdent ; -PCon. Patt2 ::= "{" PIdent "}" ; --% -PQ. Patt2 ::= PIdent "." PIdent ; -PInt. Patt2 ::= Integer ; -PFloat. Patt2 ::= Double ; -PStr. Patt2 ::= String ; -PR. Patt2 ::= "{" [PattAss] "}" ; -PTup. Patt2 ::= "<" [PattTupleComp] ">" ; -PC. Patt1 ::= PIdent [Patt] ; -PQC. Patt1 ::= PIdent "." PIdent [Patt] ; -PDisj. Patt ::= Patt "|" Patt1 ; -PSeq. Patt ::= Patt "+" Patt1 ; -PRep. Patt1 ::= Patt2 "*" ; -PAs. Patt1 ::= PIdent "@" Patt2 ; -PNeg. Patt1 ::= "-" Patt2 ; - -coercions Patt 2 ; - -PA. PattAss ::= [PIdent] "=" Patt ; - --- labels - -LIdent. Label ::= PIdent ; -LVar. Label ::= "$" Integer ; - --- basic types - -rules Sort ::= - "Type" - | "PType" - | "Tok" --% - | "Str" - | "Strs" ; - -separator PattAss ";" ; - --- this is explicit to force higher precedence level on rhs -(:[]). [Patt] ::= Patt2 ; -(:). [Patt] ::= Patt2 [Patt] ; - - --- binds in lambdas and lin rules - -BIdent. Bind ::= PIdent ; -BWild. Bind ::= "_" ; - -separator Bind "," ; - - --- declarations in function types - -DDec. Decl ::= "(" [Bind] ":" Exp ")" ; -DExp. Decl ::= Exp4 ; -- can thus be an application - --- tuple component (term or pattern) - -TComp. TupleComp ::= Exp ; -PTComp. PattTupleComp ::= Patt ; - -separator TupleComp "," ; -separator PattTupleComp "," ; - --- case branches - -Case. Case ::= Patt "=>" Exp ; - -separator nonempty Case ";" ; - --- cases in abstract syntax --% - -Equ. Equation ::= [Patt] "->" Exp ; --% - -separator Equation ";" ; --% - --- prefix alternatives - -Alt. Altern ::= Exp "/" Exp ; - -separator Altern ";" ; - --- in a context, higher precedence is required than in function types - -DDDec. DDecl ::= "(" [Bind] ":" Exp ")" ; -DDExp. DDecl ::= Exp6 ; -- can thus *not* be an application - -separator DDecl "" ; - - --------------------------------------- --% - --- for backward compatibility --% - -OldGr. OldGrammar ::= Include [TopDef] ; --% - -NoIncl. Include ::= ; --% -Incl. Include ::= "include" [FileName] ; --% - -FString. FileName ::= String ; --% - -terminator nonempty FileName ";" ; --% - -FIdent. FileName ::= PIdent ; --% -FSlash. FileName ::= "/" FileName ; --% -FDot. FileName ::= "." FileName ; --% -FMinus. FileName ::= "-" FileName ; --% -FAddId. FileName ::= PIdent FileName ; --% - -token LString '\'' (char - '\'')* '\'' ; --% -ELString. Exp6 ::= LString ; --% -ELin. Exp4 ::= "Lin" PIdent ; --% - -DefPrintOld. TopDef ::= "printname" [PrintDef] ; --% -DefLintype. TopDef ::= "lintype" [Def] ; --% -DefPattern. TopDef ::= "pattern" [Def] ; --% - --- deprecated packages are attempted to be interpreted --% -DefPackage. TopDef ::= "package" PIdent "=" "{" [TopDef] "}" ";" ; --% - --- these two are just ignored after parsing --% -DefVars. TopDef ::= "var" [Def] ; --% -DefTokenizer. TopDef ::= "tokenizer" PIdent ";" ; --% - --- identifiers - -position token PIdent ('_' | letter) (letter | digit | '_' | '\'')* ; diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs deleted file mode 100644 index a3754336e..000000000 --- a/src/GF/Source/GrammarToSource.hs +++ /dev/null @@ -1,233 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GrammarToSource --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/04 11:05:07 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.23 $ --- --- From internal source syntax to BNFC-generated (used for printing). ------------------------------------------------------------------------------ - -module GF.Source.GrammarToSource ( trGrammar, - trModule, - trAnyDef, - trLabel, - trt, tri, trp - ) where - -import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Grammar.Predef -import GF.Infra.Modules -import GF.Infra.Option -import qualified GF.Source.AbsGF as P -import GF.Infra.Ident -import qualified Data.ByteString.Char8 as BS - --- | 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,m) = P.MModule compl typ body - where - compl = case mstatus m of - MSIncomplete -> P.CMIncompl - _ -> P.CMCompl - i' = tri i - typ = case mtype m of - MTResource -> P.MTResource i' - MTAbstract -> P.MTAbstract i' - MTConcrete a -> P.MTConcrete i' (tri a) - MTTransfer a b -> P.MTTransfer i' (trOpen a) (trOpen b) - MTInstance a -> P.MTInstance i' (tri a) - MTInterface -> P.MTInterface i' - body = P.MBody - (trExtends (extend m)) - (mkOpens (map trOpen (opens m))) - (mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++ trFlags (flags m))) - -trExtends :: [(Ident,MInclude Ident)] -> P.Extend -trExtends [] = P.NoExt -trExtends es = (P.Ext $ map tre es) where - tre (i,c) = case c of - MIAll -> P.IAll (tri i) - MIOnly is -> P.ISome (tri i) (map tri is) - MIExcept is -> P.IMinus (tri i) (map tri is) - ----- 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 P.QOCompl (tri i) (tri j) - -mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds -mkTopDefs ds = ds - -trAnyDef :: (Ident,Info) -> [P.TopDef] -trAnyDef (i,info) = let i' = tri i in case info of - AbsCat (Just co) pd -> [P.DefCat [P.SimpleCatDef i' (map trDecl co)]] - AbsFun (Just ty) _ Nothing -> [P.DefFunData [P.FunDef [i'] (trt ty)]] - AbsFun (Just ty) _ (Just eqs) -> [P.DefFun [P.FunDef [i'] (trt ty)]] ++ - [P.DefDef [P.DPatt (mkName i') (map trp patts) (trt res)] | (patts,res) <- eqs] - - ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]] - ResParam pp -> [P.DefPar [case pp of - Just (ps,_) -> P.ParDefDir i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps] - Nothing -> P.ParDefAbs i']] - - ResOverload os tysts -> - [P.DefOper [P.DDef [mkName i'] ( - foldl P.EApp - (P.EIdent $ tri $ cOverload) - (map (P.EIdent . tri) os ++ - [P.ERecord [P.LDFull [i'] (trt ty) (trt fu) | (ty,fu) <- tysts]]))]] - - CncCat (Just ty) Nothing _ -> - [P.DefLincat [P.PrintDef [mkName i'] (trt ty)]] - CncCat pty ptr ppr -> - [P.DefLindef [trDef i' pty ptr]] ++ - [P.DefPrintCat [P.PrintDef [mkName i'] (trt pr)] | Just pr <- [ppr]] - CncFun _ ptr ppr -> - [P.DefLin [trDef i' Nothing ptr]] ++ - [P.DefPrintFun [P.PrintDef [mkName i'] (trt pr)] | Just pr <- [ppr]] - _ -> [] - - -trDef :: P.PIdent -> Maybe Type -> Maybe Term -> P.Def -trDef i pty ptr = case (pty,ptr) of - (Nothing, Nothing) -> P.DDef [mkName i] (P.EMeta) --- - (_, Nothing) -> P.DDecl [mkName i] (maybe P.EMeta trt pty) - (Nothing, _ ) -> P.DDef [mkName i] (maybe P.EMeta trt ptr) - (_, _ ) -> P.DFull [mkName i] (maybe P.EMeta trt pty) (maybe P.EMeta trt ptr) - -trFlags :: Options -> [P.TopDef] -trFlags = map trFlag . optionsGFO - -trFlag :: (String,String) -> P.TopDef -trFlag (f,x) = P.DefFlag [P.FlagDef (tri $ identC (BS.pack f)) (tri $ identC (BS.pack x))] - -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 - Sort s -> P.ESort $! if s == cType then P.Sort_Type else - if s == cPType then P.Sort_PType else - if s == cTok then P.Sort_Tok else - if s == cStr then P.Sort_Str else - if s == cStrs then P.Sort_Strs else - error $ "not yet sort " +++ show trm - App c a -> P.EApp (trt c) (trt a) - Abs x b -> P.EAbstr [trb x] (trt b) - 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) - - Example t s -> P.EExample (trt t) s - R [] -> P.ETuple [] --- to get correct parsing when read back - 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) - PI 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) - TSh (TComp ty) cc -> P.ETTable (trt ty) (map trCases cc) - TSh (TTyped ty) cc -> P.ETTable (trt ty) (map trCases cc) - TSh (TWild ty) cc -> P.ETTable (trt ty) (map trCases cc) - 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) - V ty cc -> P.EVTable (trt ty) (map trt 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 i - EFloat i -> P.EFloat i - - EPatt p -> P.EPatt (trp p) - EPattType t -> P.EPattType (trt t) - - 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 - Val te _ _ -> trt te ---- - _ -> error $ "not yet" +++ show trm ---- - -trp :: Patt -> P.Patt -trp p = case p of - PW -> 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 [tri $ label2ident l] (trp p) | (l,p) <- r] - PString s -> P.PStr s - PInt i -> P.PInt i - PFloat i -> P.PFloat i - PT t p -> trp p ---- prParenth (prt p +++ ":" +++ prt t) - - PAs x p -> P.PAs (tri x) (trp p) - - PAlt p q -> P.PDisj (trp p) (trp q) - PSeq p q -> P.PSeq (trp p) (trp q) - PRep p -> P.PRep (trp p) - PNeg p -> P.PNeg (trp p) - PChar -> P.PChar - PChars s -> P.PChars s - PM m c -> P.PM (tri m) (tri c) - - PVal p _ _ -> trp p ---- - -trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty - where - t' = trt t - x = [tri $ label2ident lab] - -trLabelling (lab,ty) = P.LDDecl [tri $ label2ident lab] (trt ty) - -trCase (patt, trm) = P.Case (trp patt) (trt trm) -trCases (patts,trm) = P.Case (foldl1 P.PDisj (map trp patts)) (trt trm) - -trDecl (x,ty) = P.DDDec [trb x] (trt ty) - -tri :: Ident -> P.PIdent -tri = ppIdent . ident2bs - -ppIdent i = P.PIdent ((0,0),i) - -trb i = if isWildIdent i then P.BWild else P.BIdent (tri i) - -trLabel :: Label -> P.Label -trLabel i = case i of - LIdent s -> P.LIdent $ ppIdent s - LVar i -> P.LVar $ toInteger i - -mkName :: P.PIdent -> P.Name -mkName = P.IdentName diff --git a/src/GF/Source/Makefile b/src/GF/Source/Makefile deleted file mode 100644 index 082efa5ef..000000000 --- a/src/GF/Source/Makefile +++ /dev/null @@ -1,7 +0,0 @@ -all: - cd ../.. && bnfc -p GF.Source -bytestrings GF/Source/GF.cf - rm ErrM.hs - perl -i -pe 's/%name pModHeader ModHeader/%partial pModHeader ModHeader/' ParGF.y - perl -i -pe 's/GF.Source.ErrM/GF.Data.ErrM/' *.hs *.x *.y - happy -gca ParGF.y - alex -g LexGF.x diff --git a/src/GF/Source/PrintGF.hs b/src/GF/Source/PrintGF.hs deleted file mode 100644 index 3a04d89ba..000000000 --- a/src/GF/Source/PrintGF.hs +++ /dev/null @@ -1,551 +0,0 @@ -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module GF.Source.PrintGF where - --- pretty-printer generated by the BNF converter - -import GF.Source.AbsGF -import Data.Char -import qualified Data.ByteString.Char8 as BS - --- the top-level printing method -printTree :: Print a => a -> String -printTree = render . prt 0 - -type Doc = [ShowS] -> [ShowS] - -doc :: ShowS -> Doc -doc = (:) - -render :: Doc -> String -render d = rend 0 (map ($ "") $ d []) "" where - rend i ss = case ss of - "[" :ts -> showChar '[' . rend i ts - "(" :ts -> showChar '(' . rend i ts - "{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts - "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts - "}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts - ";" :ts -> showChar ';' . new i . rend i ts - t : "," :ts -> showString t . space "," . rend i ts - t : ")" :ts -> showString t . showChar ')' . rend i ts - t : "]" :ts -> showString t . showChar ']' . rend i ts - t :ts -> space t . rend i ts - _ -> id - new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace - space t = showString t . (\s -> if null s then "" else (' ':s)) - -parenth :: Doc -> Doc -parenth ss = doc (showChar '(') . ss . doc (showChar ')') - -concatS :: [ShowS] -> ShowS -concatS = foldr (.) id - -concatD :: [Doc] -> Doc -concatD = foldr (.) id - -replicateS :: Int -> ShowS -> ShowS -replicateS n f = concatS (replicate n f) - --- the printer class does the job -class Print a where - prt :: Int -> a -> Doc - prtList :: [a] -> Doc - prtList = concatD . map (prt 0) - -instance Print a => Print [a] where - prt _ = prtList - -instance Print Char where - prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'') - prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') - -mkEsc :: Char -> Char -> ShowS -mkEsc q s = case s of - _ | s == q -> showChar '\\' . showChar s - '\\'-> showString "\\\\" - '\n' -> showString "\\n" - '\t' -> showString "\\t" - _ -> showChar s - -prPrec :: Int -> Int -> Doc -> Doc -prPrec i j = if j<i then parenth else id - - -instance Print Integer where - prt _ x = doc (shows x) - - -instance Print Double where - prt _ x = doc (shows x) - - - -instance Print LString where - prt _ (LString i) = doc (showString (BS.unpack i)) - - -instance Print PIdent where - prt _ (PIdent (_,i)) = doc (showString (BS.unpack i)) - prtList es = case es of - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - - - -instance Print Grammar where - prt i e = case e of - Gr moddefs -> prPrec i 0 (concatD [prt 0 moddefs]) - - -instance Print ModDef where - prt i e = case e of - MMain pident0 pident concspecs -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 pident0 , doc (showString "=") , doc (showString "{") , doc (showString "abstract") , doc (showString "=") , prt 0 pident , doc (showString ";") , prt 0 concspecs , doc (showString "}")]) - MModule complmod modtype modbody -> prPrec i 0 (concatD [prt 0 complmod , prt 0 modtype , doc (showString "=") , prt 0 modbody]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print ConcSpec where - prt i e = case e of - ConcSpec pident concexp -> prPrec i 0 (concatD [prt 0 pident , doc (showString "=") , prt 0 concexp]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print ConcExp where - prt i e = case e of - ConcExp pident transfers -> prPrec i 0 (concatD [prt 0 pident , prt 0 transfers]) - - -instance Print Transfer where - prt i e = case e of - TransferIn open -> prPrec i 0 (concatD [doc (showString "(") , doc (showString "transfer") , doc (showString "in") , prt 0 open , doc (showString ")")]) - TransferOut open -> prPrec i 0 (concatD [doc (showString "(") , doc (showString "transfer") , doc (showString "out") , prt 0 open , doc (showString ")")]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print ModHeader where - prt i e = case e of - MModule2 complmod modtype modheaderbody -> prPrec i 0 (concatD [prt 0 complmod , prt 0 modtype , doc (showString "=") , prt 0 modheaderbody]) - - -instance Print ModHeaderBody where - prt i e = case e of - MBody2 extend opens -> prPrec i 0 (concatD [prt 0 extend , prt 0 opens]) - MNoBody2 includeds -> prPrec i 0 (concatD [prt 0 includeds]) - MWith2 included opens -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens]) - MWithBody2 included opens0 opens -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens]) - MWithE2 includeds included opens -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens]) - MWithEBody2 includeds included opens0 opens -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens]) - MReuse2 pident -> prPrec i 0 (concatD [doc (showString "reuse") , prt 0 pident]) - MUnion2 includeds -> prPrec i 0 (concatD [doc (showString "union") , prt 0 includeds]) - - -instance Print ModType where - prt i e = case e of - MTAbstract pident -> prPrec i 0 (concatD [doc (showString "abstract") , prt 0 pident]) - MTResource pident -> prPrec i 0 (concatD [doc (showString "resource") , prt 0 pident]) - MTInterface pident -> prPrec i 0 (concatD [doc (showString "interface") , prt 0 pident]) - MTConcrete pident0 pident -> prPrec i 0 (concatD [doc (showString "concrete") , prt 0 pident0 , doc (showString "of") , prt 0 pident]) - MTInstance pident0 pident -> prPrec i 0 (concatD [doc (showString "instance") , prt 0 pident0 , doc (showString "of") , prt 0 pident]) - MTTransfer pident open0 open -> prPrec i 0 (concatD [doc (showString "transfer") , prt 0 pident , doc (showString ":") , prt 0 open0 , doc (showString "->") , prt 0 open]) - - -instance Print ModBody where - prt i e = case e of - MBody extend opens topdefs -> prPrec i 0 (concatD [prt 0 extend , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")]) - MNoBody includeds -> prPrec i 0 (concatD [prt 0 includeds]) - MWith included opens -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens]) - MWithBody included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")]) - MWithE includeds included opens -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens]) - MWithEBody includeds included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")]) - MReuse pident -> prPrec i 0 (concatD [doc (showString "reuse") , prt 0 pident]) - MUnion includeds -> prPrec i 0 (concatD [doc (showString "union") , prt 0 includeds]) - - -instance Print Extend where - prt i e = case e of - Ext includeds -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**")]) - NoExt -> prPrec i 0 (concatD []) - - -instance Print Opens where - prt i e = case e of - NoOpens -> prPrec i 0 (concatD []) - OpenIn opens -> prPrec i 0 (concatD [doc (showString "open") , prt 0 opens , doc (showString "in")]) - - -instance Print Open where - prt i e = case e of - OName pident -> prPrec i 0 (concatD [prt 0 pident]) - OQualQO qualopen pident -> prPrec i 0 (concatD [doc (showString "(") , prt 0 qualopen , prt 0 pident , doc (showString ")")]) - OQual qualopen pident0 pident -> prPrec i 0 (concatD [doc (showString "(") , prt 0 qualopen , prt 0 pident0 , doc (showString "=") , prt 0 pident , doc (showString ")")]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print ComplMod where - prt i e = case e of - CMCompl -> prPrec i 0 (concatD []) - CMIncompl -> prPrec i 0 (concatD [doc (showString "incomplete")]) - - -instance Print QualOpen where - prt i e = case e of - QOCompl -> prPrec i 0 (concatD []) - QOIncompl -> prPrec i 0 (concatD [doc (showString "incomplete")]) - QOInterface -> prPrec i 0 (concatD [doc (showString "interface")]) - - -instance Print Included where - prt i e = case e of - IAll pident -> prPrec i 0 (concatD [prt 0 pident]) - ISome pident pidents -> prPrec i 0 (concatD [prt 0 pident , doc (showString "[") , prt 0 pidents , doc (showString "]")]) - IMinus pident pidents -> prPrec i 0 (concatD [prt 0 pident , doc (showString "-") , doc (showString "[") , prt 0 pidents , doc (showString "]")]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print Def where - prt i e = case e of - DDecl names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp]) - DDef names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString "=") , prt 0 exp]) - DPatt name patts exp -> prPrec i 0 (concatD [prt 0 name , prt 0 patts , doc (showString "=") , prt 0 exp]) - DFull names exp0 exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print TopDef where - prt i e = case e of - DefCat catdefs -> prPrec i 0 (concatD [doc (showString "cat") , prt 0 catdefs]) - DefFun fundefs -> prPrec i 0 (concatD [doc (showString "fun") , prt 0 fundefs]) - DefFunData fundefs -> prPrec i 0 (concatD [doc (showString "data") , prt 0 fundefs]) - DefDef defs -> prPrec i 0 (concatD [doc (showString "def") , prt 0 defs]) - DefData datadefs -> prPrec i 0 (concatD [doc (showString "data") , prt 0 datadefs]) - DefTrans defs -> prPrec i 0 (concatD [doc (showString "transfer") , prt 0 defs]) - DefPar pardefs -> prPrec i 0 (concatD [doc (showString "param") , prt 0 pardefs]) - DefOper defs -> prPrec i 0 (concatD [doc (showString "oper") , prt 0 defs]) - DefLincat printdefs -> prPrec i 0 (concatD [doc (showString "lincat") , prt 0 printdefs]) - DefLindef defs -> prPrec i 0 (concatD [doc (showString "lindef") , prt 0 defs]) - DefLin defs -> prPrec i 0 (concatD [doc (showString "lin") , prt 0 defs]) - DefPrintCat printdefs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "cat") , prt 0 printdefs]) - DefPrintFun printdefs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "fun") , prt 0 printdefs]) - DefFlag flagdefs -> prPrec i 0 (concatD [doc (showString "flags") , prt 0 flagdefs]) - DefPrintOld printdefs -> prPrec i 0 (concatD [doc (showString "printname") , prt 0 printdefs]) - DefLintype defs -> prPrec i 0 (concatD [doc (showString "lintype") , prt 0 defs]) - DefPattern defs -> prPrec i 0 (concatD [doc (showString "pattern") , prt 0 defs]) - DefPackage pident topdefs -> prPrec i 0 (concatD [doc (showString "package") , prt 0 pident , doc (showString "=") , doc (showString "{") , prt 0 topdefs , doc (showString "}") , doc (showString ";")]) - DefVars defs -> prPrec i 0 (concatD [doc (showString "var") , prt 0 defs]) - DefTokenizer pident -> prPrec i 0 (concatD [doc (showString "tokenizer") , prt 0 pident , doc (showString ";")]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print CatDef where - prt i e = case e of - SimpleCatDef pident ddecls -> prPrec i 0 (concatD [prt 0 pident , prt 0 ddecls]) - ListCatDef pident ddecls -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , prt 0 ddecls , doc (showString "]")]) - ListSizeCatDef pident ddecls n -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , prt 0 ddecls , doc (showString "]") , doc (showString "{") , prt 0 n , doc (showString "}")]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print FunDef where - prt i e = case e of - FunDef pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print DataDef where - prt i e = case e of - DataDef pident dataconstrs -> prPrec i 0 (concatD [prt 0 pident , doc (showString "=") , prt 0 dataconstrs]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print DataConstr where - prt i e = case e of - DataId pident -> prPrec i 0 (concatD [prt 0 pident]) - DataQId pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs]) - -instance Print ParDef where - prt i e = case e of - ParDefDir pident parconstrs -> prPrec i 0 (concatD [prt 0 pident , doc (showString "=") , prt 0 parconstrs]) - ParDefIndir pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString "=") , doc (showString "(") , doc (showString "in") , prt 0 pident , doc (showString ")")]) - ParDefAbs pident -> prPrec i 0 (concatD [prt 0 pident]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print ParConstr where - prt i e = case e of - ParConstr pident ddecls -> prPrec i 0 (concatD [prt 0 pident , prt 0 ddecls]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs]) - -instance Print PrintDef where - prt i e = case e of - PrintDef names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString "=") , prt 0 exp]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print FlagDef where - prt i e = case e of - FlagDef pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString "=") , prt 0 pident]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Name where - prt i e = case e of - IdentName pident -> prPrec i 0 (concatD [prt 0 pident]) - ListName pident -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , doc (showString "]")]) - - prtList es = case es of - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print LocDef where - prt i e = case e of - LDDecl pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp]) - LDDef pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString "=") , prt 0 exp]) - LDFull pidents exp0 exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Exp where - prt i e = case e of - EIdent pident -> prPrec i 6 (concatD [prt 0 pident]) - EConstr pident -> prPrec i 6 (concatD [doc (showString "{") , prt 0 pident , doc (showString "}")]) - ECons pident -> prPrec i 6 (concatD [doc (showString "%") , prt 0 pident , doc (showString "%")]) - ESort sort -> prPrec i 6 (concatD [prt 0 sort]) - EString str -> prPrec i 6 (concatD [prt 0 str]) - EInt n -> prPrec i 6 (concatD [prt 0 n]) - EFloat d -> prPrec i 6 (concatD [prt 0 d]) - EMeta -> prPrec i 6 (concatD [doc (showString "?")]) - EEmpty -> prPrec i 6 (concatD [doc (showString "[") , doc (showString "]")]) - EData -> prPrec i 6 (concatD [doc (showString "data")]) - EList pident exps -> prPrec i 6 (concatD [doc (showString "[") , prt 0 pident , prt 0 exps , doc (showString "]")]) - EStrings str -> prPrec i 6 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")]) - ERecord locdefs -> prPrec i 6 (concatD [doc (showString "{") , prt 0 locdefs , doc (showString "}")]) - ETuple tuplecomps -> prPrec i 6 (concatD [doc (showString "<") , prt 0 tuplecomps , doc (showString ">")]) - EIndir pident -> prPrec i 6 (concatD [doc (showString "(") , doc (showString "in") , prt 0 pident , doc (showString ")")]) - ETyped exp0 exp -> prPrec i 6 (concatD [doc (showString "<") , prt 0 exp0 , doc (showString ":") , prt 0 exp , doc (showString ">")]) - EProj exp label -> prPrec i 5 (concatD [prt 5 exp , doc (showString ".") , prt 0 label]) - EQConstr pident0 pident -> prPrec i 5 (concatD [doc (showString "{") , prt 0 pident0 , doc (showString ".") , prt 0 pident , doc (showString "}")]) - EQCons pident0 pident -> prPrec i 5 (concatD [doc (showString "%") , prt 0 pident0 , doc (showString ".") , prt 0 pident]) - EApp exp0 exp -> prPrec i 4 (concatD [prt 4 exp0 , prt 5 exp]) - ETable cases -> prPrec i 4 (concatD [doc (showString "table") , doc (showString "{") , prt 0 cases , doc (showString "}")]) - ETTable exp cases -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "{") , prt 0 cases , doc (showString "}")]) - EVTable exp exps -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "[") , prt 0 exps , doc (showString "]")]) - ECase exp cases -> prPrec i 4 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")]) - EVariants exps -> prPrec i 4 (concatD [doc (showString "variants") , doc (showString "{") , prt 0 exps , doc (showString "}")]) - EPre exp alterns -> prPrec i 4 (concatD [doc (showString "pre") , doc (showString "{") , prt 0 exp , doc (showString ";") , prt 0 alterns , doc (showString "}")]) - EStrs exps -> prPrec i 4 (concatD [doc (showString "strs") , doc (showString "{") , prt 0 exps , doc (showString "}")]) - EConAt pident exp -> prPrec i 4 (concatD [prt 0 pident , doc (showString "@") , prt 6 exp]) - EPatt patt -> prPrec i 4 (concatD [doc (showString "#") , prt 2 patt]) - EPattType exp -> prPrec i 4 (concatD [doc (showString "pattern") , prt 5 exp]) - ESelect exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "!") , prt 4 exp]) - ETupTyp exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "*") , prt 4 exp]) - EExtend exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "**") , prt 4 exp]) - EGlue exp0 exp -> prPrec i 2 (concatD [prt 3 exp0 , doc (showString "+") , prt 2 exp]) - EConcat exp0 exp -> prPrec i 1 (concatD [prt 2 exp0 , doc (showString "++") , prt 1 exp]) - EVariant exp0 exp -> prPrec i 0 (concatD [prt 1 exp0 , doc (showString "|") , prt 0 exp]) - EAbstr binds exp -> prPrec i 0 (concatD [doc (showString "\\") , prt 0 binds , doc (showString "->") , prt 0 exp]) - ECTable binds exp -> prPrec i 0 (concatD [doc (showString "\\") , doc (showString "\\") , prt 0 binds , doc (showString "=>") , prt 0 exp]) - EProd decl exp -> prPrec i 0 (concatD [prt 0 decl , doc (showString "->") , prt 0 exp]) - ETType exp0 exp -> prPrec i 0 (concatD [prt 3 exp0 , doc (showString "=>") , prt 0 exp]) - ELet locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , doc (showString "{") , prt 0 locdefs , doc (showString "}") , doc (showString "in") , prt 0 exp]) - ELetb locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , prt 0 locdefs , doc (showString "in") , prt 0 exp]) - EWhere exp locdefs -> prPrec i 0 (concatD [prt 3 exp , doc (showString "where") , doc (showString "{") , prt 0 locdefs , doc (showString "}")]) - EEqs equations -> prPrec i 0 (concatD [doc (showString "fn") , doc (showString "{") , prt 0 equations , doc (showString "}")]) - EExample exp str -> prPrec i 0 (concatD [doc (showString "in") , prt 5 exp , prt 0 str]) - ELString lstring -> prPrec i 6 (concatD [prt 0 lstring]) - ELin pident -> prPrec i 4 (concatD [doc (showString "Lin") , prt 0 pident]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Exps where - prt i e = case e of - NilExp -> prPrec i 0 (concatD []) - ConsExp exp exps -> prPrec i 0 (concatD [prt 6 exp , prt 0 exps]) - - -instance Print Patt where - prt i e = case e of - PChar -> prPrec i 2 (concatD [doc (showString "?")]) - PChars str -> prPrec i 2 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")]) - PMacro pident -> prPrec i 2 (concatD [doc (showString "#") , prt 0 pident]) - PM pident0 pident -> prPrec i 2 (concatD [doc (showString "#") , prt 0 pident0 , doc (showString ".") , prt 0 pident]) - PW -> prPrec i 2 (concatD [doc (showString "_")]) - PV pident -> prPrec i 2 (concatD [prt 0 pident]) - PCon pident -> prPrec i 2 (concatD [doc (showString "{") , prt 0 pident , doc (showString "}")]) - PQ pident0 pident -> prPrec i 2 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident]) - PInt n -> prPrec i 2 (concatD [prt 0 n]) - PFloat d -> prPrec i 2 (concatD [prt 0 d]) - PStr str -> prPrec i 2 (concatD [prt 0 str]) - PR pattasss -> prPrec i 2 (concatD [doc (showString "{") , prt 0 pattasss , doc (showString "}")]) - PTup patttuplecomps -> prPrec i 2 (concatD [doc (showString "<") , prt 0 patttuplecomps , doc (showString ">")]) - PC pident patts -> prPrec i 1 (concatD [prt 0 pident , prt 0 patts]) - PQC pident0 pident patts -> prPrec i 1 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident , prt 0 patts]) - PDisj patt0 patt -> prPrec i 0 (concatD [prt 0 patt0 , doc (showString "|") , prt 1 patt]) - PSeq patt0 patt -> prPrec i 0 (concatD [prt 0 patt0 , doc (showString "+") , prt 1 patt]) - PRep patt -> prPrec i 1 (concatD [prt 2 patt , doc (showString "*")]) - PAs pident patt -> prPrec i 1 (concatD [prt 0 pident , doc (showString "@") , prt 2 patt]) - PNeg patt -> prPrec i 1 (concatD [doc (showString "-") , prt 2 patt]) - - prtList es = case es of - [x] -> (concatD [prt 2 x]) - x:xs -> (concatD [prt 2 x , prt 0 xs]) - -instance Print PattAss where - prt i e = case e of - PA pidents patt -> prPrec i 0 (concatD [prt 0 pidents , doc (showString "=") , prt 0 patt]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Label where - prt i e = case e of - LIdent pident -> prPrec i 0 (concatD [prt 0 pident]) - LVar n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n]) - - -instance Print Sort where - prt i e = case e of - Sort_Type -> prPrec i 0 (concatD [doc (showString "Type")]) - Sort_PType -> prPrec i 0 (concatD [doc (showString "PType")]) - Sort_Tok -> prPrec i 0 (concatD [doc (showString "Tok")]) - Sort_Str -> prPrec i 0 (concatD [doc (showString "Str")]) - Sort_Strs -> prPrec i 0 (concatD [doc (showString "Strs")]) - - -instance Print Bind where - prt i e = case e of - BIdent pident -> prPrec i 0 (concatD [prt 0 pident]) - BWild -> prPrec i 0 (concatD [doc (showString "_")]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print Decl where - prt i e = case e of - DDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")]) - DExp exp -> prPrec i 0 (concatD [prt 4 exp]) - - -instance Print TupleComp where - prt i e = case e of - TComp exp -> prPrec i 0 (concatD [prt 0 exp]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print PattTupleComp where - prt i e = case e of - PTComp patt -> prPrec i 0 (concatD [prt 0 patt]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print Case where - prt i e = case e of - Case patt exp -> prPrec i 0 (concatD [prt 0 patt , doc (showString "=>") , prt 0 exp]) - - prtList es = case es of - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Equation where - prt i e = case e of - Equ patts exp -> prPrec i 0 (concatD [prt 0 patts , doc (showString "->") , prt 0 exp]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Altern where - prt i e = case e of - Alt exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString "/") , prt 0 exp]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print DDecl where - prt i e = case e of - DDDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")]) - DDExp exp -> prPrec i 0 (concatD [prt 6 exp]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print OldGrammar where - prt i e = case e of - OldGr include topdefs -> prPrec i 0 (concatD [prt 0 include , prt 0 topdefs]) - - -instance Print Include where - prt i e = case e of - NoIncl -> prPrec i 0 (concatD []) - Incl filenames -> prPrec i 0 (concatD [doc (showString "include") , prt 0 filenames]) - - -instance Print FileName where - prt i e = case e of - FString str -> prPrec i 0 (concatD [prt 0 str]) - FIdent pident -> prPrec i 0 (concatD [prt 0 pident]) - FSlash filename -> prPrec i 0 (concatD [doc (showString "/") , prt 0 filename]) - FDot filename -> prPrec i 0 (concatD [doc (showString ".") , prt 0 filename]) - FMinus filename -> prPrec i 0 (concatD [doc (showString "-") , prt 0 filename]) - FAddId pident filename -> prPrec i 0 (concatD [prt 0 pident , prt 0 filename]) - - prtList es = case es of - [x] -> (concatD [prt 0 x , doc (showString ";")]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - - diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs deleted file mode 100644 index 21d670768..000000000 --- a/src/GF/Source/SourceToGrammar.hs +++ /dev/null @@ -1,733 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : SourceToGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/04 11:05:07 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.28 $ --- --- based on the skeleton Haskell module generated by the BNF converter ------------------------------------------------------------------------------ - -module GF.Source.SourceToGrammar ( transGrammar, - transInclude, - transModDef, - transOldGrammar, - transExp, - newReservedWords - ) where - -import qualified GF.Grammar.Grammar as G -import qualified GF.Grammar.PrGrammar as GP -import qualified GF.Infra.Modules as GM -import qualified GF.Grammar.Macros as M -import qualified GF.Compile.Update as U -import qualified GF.Infra.Option as GO -import qualified GF.Compile.ModDeps as GD -import GF.Grammar.Predef -import GF.Infra.Ident -import GF.Source.AbsGF -import GF.Source.PrintGF -import GF.Data.Operations -import GF.Infra.Option - -import Control.Monad -import Data.Char -import Data.List (genericReplicate) -import qualified Data.ByteString.Char8 as BS - --- 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 - -getIdentPos :: PIdent -> Err (Ident,Int) -getIdentPos x = case x of - PIdent ((line,_),c) -> return (IC c,line) - -transIdent :: PIdent -> Err Ident -transIdent = liftM fst . getIdentPos - -transName :: Name -> Err Ident -transName n = case n of - IdentName i -> transIdent i - ListName i -> liftM mkListId (transIdent i) - -transNamePos :: Name -> Err (Ident,Int) -transNamePos n = case n of - IdentName i -> getIdentPos i - ListName i -> liftM (\ (c,p) -> (mkListId c,p)) (getIdentPos i) - -transGrammar :: Grammar -> Err G.SourceGrammar -transGrammar x = case x of - Gr moddefs -> do - moddefs' <- mapM transModDef moddefs - GD.mkSourceGrammar moddefs' - -transModDef :: ModDef -> Err G.SourceModule -transModDef x = case x of - - MModule compl mtyp body -> do - - let mstat' = transComplMod compl - - (trDef, mtyp', id') <- case mtyp of - MTAbstract id -> do - id' <- transIdent id - return (transAbsDef, GM.MTAbstract, id') - MTResource id -> mkModRes id GM.MTResource body - MTConcrete id open -> do - id' <- transIdent id - open' <- transIdent open - return (transCncDef, GM.MTConcrete open', id') - MTTransfer id a b -> do - id' <- transIdent id - a' <- transOpen a - b' <- transOpen a - return (transAbsDef, GM.MTTransfer a' b', id') - MTInterface id -> mkModRes id GM.MTInterface body - MTInstance id open -> do - open' <- transIdent open - mkModRes id (GM.MTInstance open') body - - mkBody (mstat', trDef, mtyp', id') body - where - poss = emptyBinTree ---- - - mkBody xx@(mstat', trDef, mtyp', id') bod = case bod of - MNoBody incls -> do - mkBody xx $ MBody (Ext incls) NoOpens [] - MBody extends opens defs -> do - extends' <- transExtend extends - opens' <- transOpens opens - defs0 <- mapM trDef $ getTopDefs defs - poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds] - defs' <- U.buildAnyTree id' [(i,d) | Left ds <- defs0, (i,_,d) <- ds] - flags' <- return $ concatOptions [o | Right o <- defs0] - let poss1 = buildPosTree id' poss0 - return (id', GM.ModInfo mtyp' mstat' flags' extends' Nothing opens' [] defs' poss1) - - MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens [] - MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs - MWithE extends m insts -> mkBody xx $ MWithEBody extends m insts NoOpens [] - MWithEBody extends m insts opens defs -> do - extends' <- mapM transIncludedExt extends - m' <- transIncludedExt m - insts' <- mapM transInst insts - opens' <- transOpens opens - defs0 <- mapM trDef $ getTopDefs defs - poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds] - defs' <- U.buildAnyTree id' [(i,d) | Left ds <- defs0, (i,_,d) <- ds] - flags' <- return $ concatOptions [o | Right o <- defs0] - let poss1 = buildPosTree id' poss0 - return (id', GM.ModInfo mtyp' mstat' flags' extends' (Just (fst m',snd m',insts')) opens' [] defs' poss1) - - mkModRes id mtyp body = do - id' <- transIdent id - return (transResDef, mtyp, id') - - -transComplMod :: ComplMod -> GM.ModuleStatus -transComplMod x = case x of - CMCompl -> GM.MSComplete - CMIncompl -> GM.MSIncomplete - -getTopDefs :: [TopDef] -> [TopDef] -getTopDefs x = x - -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 [(Ident,GM.MInclude Ident)] -transExtend x = case x of - Ext ids -> mapM transIncludedExt ids - NoExt -> return [] - -transOpens :: Opens -> Err [GM.OpenSpec Ident] -transOpens x = case x of - NoOpens -> return [] - OpenIn opens -> mapM transOpen opens - -transOpen :: Open -> Err (GM.OpenSpec Ident) -transOpen x = case x of - OName id -> liftM GM.OSimple (transIdent id) - OQualQO q id -> liftM GM.OSimple (transIdent id) - OQual q id m -> liftM2 GM.OQualif (transIdent id) (transIdent m) - -transInst :: Open -> Err (Ident,Ident) -transInst x = case x of - OQual q id m -> liftM2 (,) (transIdent id) (transIdent m) - _ -> Bad "qualified open expected" - -transIncluded :: Included -> Err (Ident,[Ident]) -transIncluded x = case x of - IAll i -> liftM (flip (curry id) []) $ transIdent i - ISome i ids -> liftM2 (curry id) (transIdent i) (mapM transIdent ids) - IMinus i ids -> liftM2 (curry id) (transIdent i) (mapM transIdent ids) ---- - -transIncludedExt :: Included -> Err (Ident, GM.MInclude Ident) -transIncludedExt x = case x of - IAll i -> liftM2 (,) (transIdent i) (return GM.MIAll) - ISome i ids -> liftM2 (,) (transIdent i) (liftM GM.MIOnly $ mapM transIdent ids) - IMinus i ids -> liftM2 (,) (transIdent i) (liftM GM.MIExcept $ mapM transIdent ids) - ---- where no position is saved -nopos :: Int -nopos = -1 - -buildPosTree :: Ident -> [(Ident,Int)] -> BinTree Ident (String,(Int,Int)) -buildPosTree m = buildTree . mkPoss . filter ((>0) . snd) where - mkPoss cs = case cs of - (i,p):rest@((_,q):_) -> (i,(name,(p,max p (q-1)))) : mkPoss rest - (i,p):[] -> (i,(name,(p,p+100))) : [] --- don't know last line - _ -> [] - name = showIdent m ++ ".gf" ---- - -transAbsDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.Options) -transAbsDef x = case x of - DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs - DefFun fundefs -> do - fundefs' <- mapM transFunDef fundefs - returnl [(fun, nopos, G.AbsFun (Just typ) Nothing) | (funs,typ) <- fundefs', fun <- funs] - DefFunData fundefs -> do - fundefs' <- mapM transFunDef fundefs - returnl $ - [(cat, nopos, G.AbsCat Nothing (Just [G.Cn fun])) | (funs,typ) <- fundefs', - fun <- funs, - Ok (_,cat) <- [M.valCat typ] - ] ++ - [(fun, nopos, G.AbsFun (Just typ) (Just G.EData)) | (funs,typ) <- fundefs', fun <- funs] - DefDef defs -> do - defs' <- liftM concat $ mapM getDefsGen defs - returnl [(c, nopos, G.AbsFun Nothing pe) | ((c,p),(_,pe)) <- defs'] - DefData ds -> do - ds' <- mapM transDataDef ds - returnl $ - [(c, nopos, G.AbsCat Nothing (Just ps)) | (c,ps) <- ds'] ++ - [(f, nopos, G.AbsFun Nothing (Just G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf] - DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs - _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x - where - -- to get data constructors as terms - funs t = case t of - G.Cn f -> [f] - G.Q _ f -> [f] - G.QC _ f -> [f] - _ -> [] - -returnl :: a -> Err (Either a b) -returnl = return . Left - -transFlagDef :: FlagDef -> Err GO.Options -transFlagDef x = case x of - FlagDef f x -> parseModuleOptions ["--" ++ prPIdent f ++ "=" ++ prPIdent x] - where - prPIdent (PIdent (_,c)) = BS.unpack c - - --- | Cat definitions can also return some fun defs --- if it is a list category definition -transCatDef :: CatDef -> Err [(Ident, Int, G.Info)] -transCatDef x = case x of - SimpleCatDef id ddecls -> do - (id',pos) <- getIdentPos id - liftM (:[]) $ cat id' pos ddecls - ListCatDef id ddecls -> listCat id ddecls 0 - ListSizeCatDef id ddecls size -> listCat id ddecls size - where - cat i pos ddecls = do - -- i <- transIdent id - cont <- liftM concat $ mapM transDDecl ddecls - return (i, pos, G.AbsCat (Just cont) Nothing) - listCat id ddecls size = do - (id',pos) <- getIdentPos id - let - li = mkListId id' - baseId = mkBaseId id' - consId = mkConsId id' - catd0@(c,p,G.AbsCat (Just cont0) _) <- cat li pos ddecls - let - catd = (c,pos,G.AbsCat (Just cont0) (Just [G.Cn baseId,G.Cn consId])) - cont = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont0] - xs = map (G.Vr . fst) cont - cd = M.mkDecl (M.mkApp (G.Vr id') xs) - lc = M.mkApp (G.Vr li) xs - niltyp = M.mkProdSimple (cont ++ genericReplicate size cd) lc - nilfund = (baseId, nopos, G.AbsFun (Just niltyp) (Just G.EData)) - constyp = M.mkProdSimple (cont ++ [cd, M.mkDecl lc]) lc - consfund = (consId, nopos, G.AbsFun (Just constyp) (Just G.EData)) - return [catd,nilfund,consfund] - mkId x i = if isWildIdent x then (varX i) else x - -transFunDef :: FunDef -> Err ([Ident], G.Type) -transFunDef x = case x of - FunDef ids typ -> liftM2 (,) (mapM transIdent ids) (transExp typ) - -transDataDef :: DataDef -> Err (Ident,[G.Term]) -transDataDef x = case x of - DataDef id ds -> liftM2 (,) (transIdent id) (mapM transData ds) - where - transData d = case d of - DataId id -> liftM G.Cn $ transIdent id - DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id) - -transResDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.Options) -transResDef x = case x of - DefPar pardefs -> do - pardefs' <- mapM transParDef pardefs - returnl $ [(p, nopos, G.ResParam (if null pars - then Nothing -- abstract param type - else (Just (pars,Nothing)))) - | (p,pars) <- pardefs'] - ++ [(f, nopos, G.ResValue (Just (M.mkProdSimple co (G.Cn p),Nothing))) | - (p,pars) <- pardefs', (f,co) <- pars] - - DefOper defs -> do - defs' <- liftM concat $ mapM getDefs defs - returnl $ - concatMap mkOverload [(f, p, G.ResOper pt pe) | ((f,p),(pt,pe)) <- defs'] - - DefLintype defs -> do - defs' <- liftM concat $ mapM getDefs defs - returnl [(f, p, G.ResOper pt pe) | ((f,p),(pt,pe)) <- defs'] - - DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs - _ -> Bad $ "illegal definition form in resource" +++ printTree x - where - mkOverload op@(c,p,j) = case j of - G.ResOper _ (Just df) -> case M.appForm df of - (keyw, ts@(_:_)) | isOverloading keyw -> case last ts of - G.R fs -> - [(c,p,G.ResOverload [m | G.Vr m <- ts] [(ty,fu) | (_,(Just ty,fu)) <- fs])] - _ -> [op] - _ -> [op] - - -- to enable separare type signature --- not type-checked - G.ResOper (Just df) _ -> case M.appForm df of - (keyw, ts@(_:_)) | isOverloading keyw -> case last ts of - G.RecType _ -> [] - _ -> [op] - _ -> [op] - _ -> [(c,p,j)] - isOverloading keyw = - GP.prt keyw == "overload" -- overload is a "soft keyword" - isRec t = case t of - G.R _ -> True - _ -> False - -transParDef :: ParDef -> Err (Ident, [G.Param]) -transParDef x = case x of - ParDefDir 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, Int, G.Info)] GO.Options) -transCncDef x = case x of - DefLincat defs -> do - defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, nopos, G.CncCat (Just t) Nothing Nothing) | (f,t) <- defs'] - DefLindef defs -> do - defs' <- liftM concat $ mapM getDefs defs - returnl [(f, p, G.CncCat pt pe Nothing) | ((f,p),(pt,pe)) <- defs'] - DefLin defs -> do - defs' <- liftM concat $ mapM getDefs defs - returnl [(f, p, G.CncFun Nothing pe Nothing) | ((f,p),(_,pe)) <- defs'] - DefPrintCat defs -> do - defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, nopos, G.CncCat Nothing Nothing (Just e)) | (f,e) <- defs'] - DefPrintFun defs -> do - defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, nopos, G.CncFun Nothing Nothing (Just e)) | (f,e) <- defs'] - DefPrintOld defs -> do --- a guess, for backward compatibility - defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, nopos, G.CncFun Nothing Nothing (Just e)) | (f,e) <- defs'] - DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs - DefPattern defs -> do - defs' <- liftM concat $ mapM getDefs defs - let defs2 = [(f, termInPattern t) | (f,(_,Just t)) <- defs'] - returnl [(f, p, G.CncFun Nothing (Just t) Nothing) | ((f,p),t) <- defs2] - - _ -> errIn ("illegal definition in concrete syntax:") $ transResDef x - -transPrintDef :: PrintDef -> Err [(Ident,G.Term)] -transPrintDef x = case x of - PrintDef ids exp -> do - (ids,e) <- liftM2 (,) (mapM transName ids) (transExp exp) - return $ [(i,e) | i <- ids] - -getDefsGen :: Def -> Err [((Ident, Int),(Maybe G.Type, Maybe G.Term))] -getDefsGen d = case d of - DDecl ids t -> do - ids' <- mapM transNamePos ids - t' <- transExp t - return [(i,(Just t', Nothing)) | i <- ids'] - DDef ids e -> do - ids' <- mapM transNamePos ids - e' <- transExp e - return [(i,(Nothing, Just e')) | i <- ids'] - DFull ids t e -> do - ids' <- mapM transNamePos ids - t' <- transExp t - e' <- transExp e - return [(i,(Just t', Just e')) | i <- ids'] - DPatt id patts e -> do - id' <- transNamePos id - ps' <- mapM transPatt patts - e' <- transExp e - return [(id',(Nothing, Just (G.Eqs [(ps',e')])))] - --- | sometimes you need this special case, e.g. in linearization rules -getDefs :: Def -> Err [((Ident,Int), (Maybe G.Type, Maybe G.Term))] -getDefs d = case d of - DPatt id patts e -> do - id' <- transNamePos id - xs <- mapM tryMakeVar patts - e' <- transExp e - return [(id',(Nothing, Just (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 -> return $ G.Sort $ transSort sort - EInt n -> return $ G.EInt n - EFloat n -> return $ G.EFloat n - EMeta -> return $ G.Meta $ M.int2meta 0 - EEmpty -> return G.Empty - -- [ C x_1 ... x_n ] becomes (ListC x_1 ... x_n) - EList i es -> do - i' <- transIdent i - es' <- mapM transExp (exps2list es) - return $ foldl G.App (G.Vr (mkListId i')) es' - 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) - EVTable exp cases -> - liftM2 (\t c -> G.V t c) (transExp exp) (mapM transExp cases) - ECase exp cases -> do - exp' <- transExp exp - cases' <- transCases cases - let annot = case exp' of - G.Typed _ t -> G.TTyped t - _ -> G.TRaw - return $ G.S (G.T annot cases') exp' - ECTable binds exp -> liftM2 M.mkCTable (mapM transBind binds) (transExp exp) - - EVariants exps -> liftM G.FV $ mapM transExp exps - EVariant exp0 exp -> do let fvList (G.FV xs) = xs - fvList t = [t] - exp0' <- transExp exp0 - exp' <- transExp exp - return $ G.FV $ fvList exp0' ++ fvList exp' - 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) - EExample exp str -> liftM2 G.Example (transExp exp) (return str) - - 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" - ELetb defs exp -> transExp $ ELet defs exp - EWhere exp defs -> transExp $ ELet defs exp - - EPattType typ -> liftM G.EPattType (transExp typ) - EPatt patt -> liftM G.EPatt (transPatt patt) - - ELString (LString str) -> return $ G.K (BS.unpack str) -- use the grammar encoding here - - EEqs eqs -> liftM G.Eqs $ mapM transEquation eqs - - _ -> Bad $ "translation not yet defined for" +++ printTree x ---- - -exps2list :: Exps -> [Exp] -exps2list NilExp = [] -exps2list (ConsExp e es) = e : exps2list es - ---- 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 (G.ident2label lab,ty) - _ -> Bad $ "illegal record type field" +++ GP.prt (fst f) --- manifest fields ?! - tryR f = case f of - (lab,(mty, Just t)) -> return (G.ident2label lab,(mty,t)) - _ -> Bad $ "illegal record field" +++ GP.prt (fst f) - - -locdef2fields :: LocDef -> Err [(Ident, (Maybe G.Type, Maybe G.Type))] -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 - LIdent (PIdent (_, s)) -> return $ G.LIdent s - LVar x -> return $ G.LVar $ fromInteger x - -transSort :: Sort -> Ident -transSort Sort_Type = cType -transSort Sort_PType = cPType -transSort Sort_Tok = cTok -transSort Sort_Str = cStr -transSort Sort_Strs = cStrs - - -{- ---- no more used 7/1/2006 AR -transPatts :: Patt -> Err [G.Patt] -transPatts p = case p of - PDisj p1 p2 -> liftM2 (++) (transPatts p1) (transPatts p2) - PC id patts -> liftM (map (G.PC id) . combinations) $ mapM transPatts patts - PQC q id patts -> liftM (map (G.PP q id) . combinations) (mapM transPatts patts) - - PR pattasss -> do - let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss] - ls = map LIdent $ concat lss - ps0 <- mapM transPatts ps - let ps' = combinations ps0 - lss' <- mapM trLabel ls - let rss = map (zip lss') ps' - return $ map G.PR rss - PTup pcs -> do - ps0 <- mapM transPatts [e | PTComp e <- pcs] - let ps' = combinations ps0 - return $ map (G.PR . M.tuple2recordPatt) ps' - _ -> liftM singleton $ transPatt p --} - -transPatt :: Patt -> Err G.Patt -transPatt x = case x of - PW -> return G.PW - 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 n - PFloat n -> return $ G.PFloat 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) - PDisj p1 p2 -> liftM2 G.PAlt (transPatt p1) (transPatt p2) - PSeq p1 p2 -> liftM2 G.PSeq (transPatt p1) (transPatt p2) - PRep p -> liftM G.PRep (transPatt p) - PNeg p -> liftM G.PNeg (transPatt p) - PAs x p -> liftM2 G.PAs (transIdent x) (transPatt p) - PChar -> return G.PChar - PChars s -> return $ G.PChars s - PMacro c -> liftM G.PMacro $ transIdent c - PM m c -> liftM2 G.PM (transIdent m) (transIdent c) - -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 = mapM transCase - -transCase :: Case -> Err G.Case -transCase (Case p exp) = do - patt <- transPatt p - exp' <- transExp exp - return (patt,exp') - -transEquation :: Equation -> Err G.Equation -transEquation x = case x of - Equ apatts exp -> liftM2 (,) (mapM transPatt apatts) (transExp exp) - -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 two modules, forming --- their names from a given string, e.g. file name or overriding user-given string -transOldGrammar :: Options -> FilePath -> OldGrammar -> Err G.SourceGrammar -transOldGrammar opts name0 x = case x of - OldGr includes topdefs -> do --- includes must be collected separately - let moddefs = sortTopDefs topdefs - transGrammar $ Gr moddefs - where - sortTopDefs ds = [mkAbs a, mkCnc ops (c ++ r)] - where - ops = map fst ps - (a,r,c,ps) = foldr srt ([],[],[],[]) ds - srt d (a,r,c,ps) = case d of - DefCat catdefs -> (d:a,r,c,ps) - DefFun fundefs -> (d:a,r,c,ps) - DefFunData fundefs -> (d:a,r,c,ps) - DefDef defs -> (d:a,r,c,ps) - DefData pardefs -> (d:a,r,c,ps) - DefPar pardefs -> (a,d:r,c,ps) - DefOper defs -> (a,d:r,c,ps) - DefLintype defs -> (a,d:r,c,ps) - DefLincat defs -> (a,r,d:c,ps) - DefLindef defs -> (a,r,d:c,ps) - DefLin defs -> (a,r,d:c,ps) - DefPattern defs -> (a,r,d:c,ps) - DefFlag defs -> (a,r,d:c,ps) --- a guess - DefPrintCat printdefs -> (a,r,d:c,ps) - DefPrintFun printdefs -> (a,r,d:c,ps) - DefPrintOld printdefs -> (a,r,d:c,ps) - -- DefPackage m ds -> (a,r,c,(m,ds):ps) -- OBSOLETE - _ -> (a,r,c,ps) - mkAbs a = MModule q (MTAbstract absName) (MBody ne (OpenIn []) (topDefs a)) - mkCnc ps r = MModule q (MTConcrete cncName absName) (MBody ne (OpenIn []) (topDefs r)) - topDefs t = t - ne = NoExt - q = CMCompl - - name = maybe name0 (++ ".gf") $ flag optName opts - absName = identPI $ maybe topic id $ flag optAbsName opts - resName = identPI $ maybe ("Res" ++ lang) id $ flag optResName opts - cncName = identPI $ maybe lang id $ flag optCncName opts - - identPI s = PIdent ((0,0),BS.pack s) - - (beg,rest) = span (/='.') name - (topic,lang) = case rest of -- to avoid overwriting old files - ".gf" -> ("Abs" ++ beg,"Cnc" ++ beg) - ".cf" -> ("Abs" ++ beg,"Cnc" ++ beg) - ".ebnf" -> ("Abs" ++ beg,"Cnc" ++ beg) - [] -> ("Abs" ++ beg,"Cnc" ++ beg) - _:s -> (beg, takeWhile (/='.') s) - -transInclude :: Include -> Err [FilePath] -transInclude x = Bad "Old GF with includes no more supported in GF 3.0" - -newReservedWords :: [String] -newReservedWords = - words $ "abstract concrete interface incomplete " ++ - "instance out open resource reuse transfer union with where" - -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 (BS.pack "s") - (xx,body) = abss [] t - abss xs t = case t of - G.Abs x b -> abss (x:xs) b - _ -> (reverse xs,t) - -mkListId,mkConsId,mkBaseId :: Ident -> Ident -mkListId = prefixId (BS.pack "List") -mkConsId = prefixId (BS.pack "Cons") -mkBaseId = prefixId (BS.pack "Base") - -prefixId :: BS.ByteString -> Ident -> Ident -prefixId pref id = identC (BS.append pref (ident2bs id)) |