From e620ffbd9432fc9ab4f3174ecf9c117db27af772 Mon Sep 17 00:00:00 2001 From: aarne Date: Thu, 23 Oct 2003 15:09:07 +0000 Subject: Working with interfaces and incomplete modules. --- src/GF/Source/AbsGF.hs | 42 ++++-- src/GF/Source/CompileM.hs | 141 ------------------- src/GF/Source/GF.cf | 286 +++++++++++++++++++++++++++++++++++++++ src/GF/Source/GrammarToSource.hs | 35 +++-- src/GF/Source/LexGF.hs | 4 +- src/GF/Source/PrintGF.hs | 46 +++++-- src/GF/Source/SkelGF.hs | 45 ++++-- src/GF/Source/SourceToGrammar.hs | 117 +++++++++------- 8 files changed, 474 insertions(+), 242 deletions(-) delete mode 100644 src/GF/Source/CompileM.hs create mode 100644 src/GF/Source/GF.cf (limited to 'src/GF/Source') diff --git a/src/GF/Source/AbsGF.hs b/src/GF/Source/AbsGF.hs index 0dd825891..8acf35349 100644 --- a/src/GF/Source/AbsGF.hs +++ b/src/GF/Source/AbsGF.hs @@ -5,7 +5,6 @@ import Ident --H -- Haskell module generated by the BNF converter, except --H -- newtype Ident = Ident String deriving (Eq,Ord,Show) --H - newtype LString = LString String deriving (Eq,Ord,Show) data Grammar = Gr [ModDef] @@ -13,17 +12,7 @@ data Grammar = 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 + | MModule ComplMod ModType ModBody deriving (Eq,Ord,Show) data ConcSpec = @@ -39,6 +28,21 @@ data Transfer = | TransferOut Open deriving (Eq,Ord,Show) +data ModType = + MTAbstract Ident + | MTResource Ident + | MTInterface Ident + | MTConcrete Ident Ident + | MTInstance Ident Ident + | MTTransfer Ident Open Open + deriving (Eq,Ord,Show) + +data ModBody = + MBody Extend Opens [TopDef] + | MWith Ident [Open] + | MReuse Ident + deriving (Eq,Ord,Show) + data Extend = Ext Ident | NoExt @@ -51,7 +55,19 @@ data Opens = data Open = OName Ident - | OQual Ident Ident + | OQualQO QualOpen Ident + | OQual QualOpen Ident Ident + deriving (Eq,Ord,Show) + +data ComplMod = + CMCompl + | CMIncompl + deriving (Eq,Ord,Show) + +data QualOpen = + QOCompl + | QOIncompl + | QOInterface deriving (Eq,Ord,Show) data Def = diff --git a/src/GF/Source/CompileM.hs b/src/GF/Source/CompileM.hs deleted file mode 100644 index 3d97a029e..000000000 --- a/src/GF/Source/CompileM.hs +++ /dev/null @@ -1,141 +0,0 @@ -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 diff --git a/src/GF/Source/GF.cf b/src/GF/Source/GF.cf new file mode 100644 index 000000000..bb1d200cd --- /dev/null +++ b/src/GF/Source/GF.cf @@ -0,0 +1,286 @@ +-- AR 2/5/2003, 14-16 o'clock, Torino + +entrypoints Grammar, ModDef, OldGrammar, 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" Ident "=" "{" "abstract" "=" Ident ";" [ConcSpec] "}" ; + +ConcSpec. ConcSpec ::= Ident "=" ConcExp ; +separator ConcSpec ";" ; + +ConcExp. ConcExp ::= Ident [Transfer] ; + +separator Transfer "" ; +TransferIn. Transfer ::= "(" "transfer" "in" Open ")" ; +TransferOut. Transfer ::= "(" "transfer" "out" Open ")" ; + +-- the individual modules + +MModule. ModDef ::= ComplMod ModType "=" ModBody ; + +MTAbstract. ModType ::= "abstract" Ident ; +MTResource. ModType ::= "resource" Ident ; +MTInterface. ModType ::= "interface" Ident ; +MTConcrete. ModType ::= "concrete" Ident "of" Ident ; +MTInstance. ModType ::= "instance" Ident "of" Ident ; +MTTransfer. ModType ::= "transfer" Ident ":" Open "->" Open ; + +MBody. ModBody ::= Extend Opens "{" [TopDef] "}" ; +MWith. ModBody ::= Ident "with" [Open] ; +MReuse. ModBody ::= "reuse" Ident ; + +separator TopDef "" ; + +Ext. Extend ::= Ident "**" ; +NoExt. Extend ::= ; + +separator Open "," ; +NoOpens. Opens ::= ; +Opens. Opens ::= "open" [Open] "in" ; + +OName. Open ::= Ident ; +OQualQO. Open ::= "(" QualOpen Ident ")" ; +OQual. Open ::= "(" QualOpen Ident "=" Ident ")" ; + +CMCompl. ComplMod ::= ; +CMIncompl. ComplMod ::= "incomplete" ; + +QOCompl. QualOpen ::= ; +QOIncompl. QualOpen ::= "incomplete" ; +QOInterface. QualOpen ::= "interface" ; + +-- definitions after the $oper$ keywords + +DDecl. Def ::= [Ident] ":" Exp ; +DDef. Def ::= [Ident] "=" Exp ; +DPatt. Def ::= Ident [Patt] "=" Exp ; -- non-empty pattern list +DFull. Def ::= [Ident] ":" Exp "=" Exp ; + +-- top-level definitions + +DefCat. TopDef ::= "cat" [CatDef] ; +DefFun. TopDef ::= "fun" [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] ; + +CatDef. CatDef ::= Ident [DDecl] ; +FunDef. FunDef ::= [Ident] ":" Exp ; + +DataDef. DataDef ::= Ident "=" [DataConstr] ; +DataId. DataConstr ::= Ident ; +DataQId. DataConstr ::= Ident "." Ident ; +separator DataConstr "|" ; + + +ParDef. ParDef ::= Ident "=" [ParConstr] ; +ParDefIndir. ParDef ::= Ident "=" "(" "in" Ident ")" ; +ParDefAbs. ParDef ::= Ident ; + +ParConstr. ParConstr ::= Ident [DDecl] ; + +PrintDef. PrintDef ::= [Ident] "=" Exp ; + +FlagDef. FlagDef ::= Ident "=" Ident ; + +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 Ident "," ; + +-- definitions in records and $let$ expressions + +LDDecl. LocDef ::= [Ident] ":" Exp ; +LDDef. LocDef ::= [Ident] "=" Exp ; +LDFull. LocDef ::= [Ident] ":" Exp "=" Exp ; + +separator LocDef ";" ; + +-- terms and types + +EIdent. Exp4 ::= Ident ; +EConstr. Exp4 ::= "{" Ident "}" ; +ECons. Exp4 ::= "[" Ident "]" ; +ESort. Exp4 ::= Sort ; +EString. Exp4 ::= String ; +EInt. Exp4 ::= Integer ; +EMeta. Exp4 ::= "?" ; +EEmpty. Exp4 ::= "[" "]" ; +EStrings. Exp4 ::= "[" String "]" ; +ERecord. Exp4 ::= "{" [LocDef] "}" ; -- ! +ETuple. Exp4 ::= "<" [TupleComp] ">" ; --- needed for separator "," +EIndir. Exp4 ::= "(" "in" Ident ")" ; -- indirection, used in judgements +ETyped. Exp4 ::= "<" Exp ":" Exp ">" ; -- typing, used for annotations + +EProj. Exp3 ::= Exp3 "." Label ; +EQConstr. Exp3 ::= "{" Ident "." Ident "}" ; -- qualified constructor +EQCons. Exp3 ::= "[" Ident "." Ident "]" ; -- qualified constant + +EApp. Exp2 ::= Exp2 Exp3 ; +ETable. Exp2 ::= "table" "{" [Case] "}" ; +ETTable. Exp2 ::= "table" Exp4 "{" [Case] "}" ; +ECase. Exp2 ::= "case" Exp "of" "{" [Case] "}" ; +EVariants. Exp2 ::= "variants" "{" [Exp] "}" ; +EPre. Exp2 ::= "pre" "{" Exp ";" [Altern] "}" ; +EStrs. Exp2 ::= "strs" "{" [Exp] "}" ; +EConAt. Exp2 ::= Ident "@" Exp4 ; + +ESelect. Exp1 ::= Exp1 "!" Exp2 ; +ETupTyp. Exp1 ::= Exp1 "*" Exp2 ; +EExtend. Exp1 ::= Exp1 "**" Exp2 ; + +EAbstr. Exp ::= "\\" [Bind] "->" Exp ; +ECTable. Exp ::= "\\""\\" [Bind] "=>" Exp ; +EProd. Exp ::= Decl "->" Exp ; +ETType. Exp ::= Exp1 "=>" Exp ; -- these are thus right associative +EConcat. Exp ::= Exp1 "++" Exp ; +EGlue. Exp ::= Exp1 "+" Exp ; +ELet. Exp ::= "let" "{" [LocDef] "}" "in" Exp ; +EEqs. Exp ::= "fn" "{" [Equation] "}" ; + +coercions Exp 4 ; + +separator Exp ";" ; -- in variants + +-- patterns + +PW. Patt1 ::= "_" ; +PV. Patt1 ::= Ident ; +PCon. Patt1 ::= "{" Ident "}" ; +PQ. Patt1 ::= Ident "." Ident ; +PInt. Patt1 ::= Integer ; +PStr. Patt1 ::= String ; +PR. Patt1 ::= "{" [PattAss] "}" ; +PTup. Patt1 ::= "<" [PattTupleComp] ">" ; +PC. Patt ::= Ident [Patt] ; +PQC. Patt ::= Ident "." Ident [Patt] ; + +coercions Patt 1 ; + +PA. PattAss ::= [Ident] "=" Patt ; + +-- labels + +LIdent. Label ::= Ident ; +LVar. Label ::= "$" Integer ; + +-- basic types + +rules Sort ::= "Type" | "PType" | "Tok" | "Str" | "Strs" ; + +separator PattAss ";" ; + +AltP. PattAlt ::= Patt ; + +-- this is explicit to force higher precedence level on rhs +(:[]). [Patt] ::= Patt1 ; +(:). [Patt] ::= Patt1 [Patt] ; + +separator nonempty PattAlt "|" ; + +-- binds in lambdas and lin rules + +BIdent. Bind ::= Ident ; +BWild. Bind ::= "_" ; + +separator Bind "," ; + + +-- declarations in function types + +DDec. Decl ::= "(" [Bind] ":" Exp ")" ; +DExp. Decl ::= Exp2 ; -- can thus be an application + +-- tuple component (term or pattern) + +TComp. TupleComp ::= Exp ; +PTComp. PattTupleComp ::= Patt ; + +separator TupleComp "," ; +separator PattTupleComp "," ; + +-- case branches + +Case. Case ::= [PattAlt] "=>" 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 ::= Exp4 ; -- 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 ::= Ident ; +FSlash. FileName ::= "/" FileName ; +FDot. FileName ::= "." FileName ; +FMinus. FileName ::= "-" FileName ; +FAddId. FileName ::= Ident FileName ; + +token LString '\'' (char - '\'')* '\'' ; +ELString. Exp4 ::= LString ; +ELin. Exp2 ::= "Lin" Ident ; + +DefPrintOld. TopDef ::= "printname" [PrintDef] ; +DefLintype. TopDef ::= "lintype" [Def] ; +DefPattern. TopDef ::= "pattern" [Def] ; diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs index 73f65c85c..1b4185796 100644 --- a/src/GF/Source/GrammarToSource.hs +++ b/src/GF/Source/GrammarToSource.hs @@ -15,16 +15,20 @@ 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 m = case typeOfModule mo of - MTResource -> P.MResource m - MTAbstract -> P.MAbstract m - MTConcrete a -> P.MConcrete m (tri a) - MTTransfer a b -> P.MTransfer m (trOpen a) (trOpen b) + ModMod m -> P.MModule compl typ body where + compl = P.CMCompl -- always complete module + i' = tri i + typ = case typeOfModule mo 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 + (trExtend (extends m)) + (mkOpens (map trOpen (opens m))) + (mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++ map trFlag (flags m))) trExtend :: Maybe Ident -> P.Extend trExtend i = maybe P.NoExt (P.Ext . tri) i @@ -34,8 +38,15 @@ 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) + OSimple OQNormal i -> P.OQualQO P.QOCompl (tri i) + OSimple q i -> P.OQualQO (trQualOpen q) (tri i) + OQualif q i j -> P.OQual (trQualOpen q) (tri i) (tri j) + +trQualOpen q = case q of + OQNormal -> P.QOCompl + OQIncomplete -> P.QOIncompl + OQInterface -> P.QOInterface + mkOpens ds = if null ds then P.NoOpens else P.Opens ds mkTopDefs ds = ds diff --git a/src/GF/Source/LexGF.hs b/src/GF/Source/LexGF.hs index d7ab78725..e27e5b861 100644 --- a/src/GF/Source/LexGF.hs +++ b/src/GF/Source/LexGF.hs @@ -55,7 +55,7 @@ tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx 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)))) + B "interface" (B "data" (B "Type" (B "Str" (B "PType" (B "Lin" N N) N) (B "Tok" (B "Strs" N N) N)) (B "cat" (B "case" (B "abstract" N N) N) (B "concrete" N N))) (B "grammar" (B "fn" (B "flags" (B "def" N N) N) (B "fun" N N)) (B "incomplete" (B "include" (B "in" N N) N) (B "instance" N N)))) (B "pattern" (B "of" (B "lincat" (B "lin" (B "let" N N) N) (B "lintype" (B "lindef" N 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 "variants" (B "transfer" (B "table" N N) N) (B "with" N N)))) data BTree = N | B String BTree BTree deriving (Show) @@ -114,7 +114,7 @@ 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__16_0 = (True,[(4,"mk_LString",[],Nothing,Nothing)],-1,(('0','0'),[])) 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)])) diff --git a/src/GF/Source/PrintGF.hs b/src/GF/Source/PrintGF.hs index 3024d49db..b406f1935 100644 --- a/src/GF/Source/PrintGF.hs +++ b/src/GF/Source/PrintGF.hs @@ -7,6 +7,7 @@ import Ident --H import Char -- the top-level printing method + printTree :: Print a => a -> String printTree = render . prt 0 @@ -88,17 +89,7 @@ instance Print Grammar where 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]) + MModule complmod modtype modbody -> prPrec i 0 (concat [prt 0 complmod , prt 0 modtype , ["="] , prt 0 modbody]) prtList es = case es of [] -> (concat []) @@ -127,6 +118,23 @@ instance Print Transfer where [] -> (concat []) x:xs -> (concat [prt 0 x , prt 0 xs]) +instance Print ModType where + prt i e = case e of + MTAbstract id -> prPrec i 0 (concat [["abstract"] , prt 0 id]) + MTResource id -> prPrec i 0 (concat [["resource"] , prt 0 id]) + MTInterface id -> prPrec i 0 (concat [["interface"] , prt 0 id]) + MTConcrete id0 id -> prPrec i 0 (concat [["concrete"] , prt 0 id0 , ["of"] , prt 0 id]) + MTInstance id0 id -> prPrec i 0 (concat [["instance"] , prt 0 id0 , ["of"] , prt 0 id]) + MTTransfer id open0 open -> prPrec i 0 (concat [["transfer"] , prt 0 id , [":"] , prt 0 open0 , ["->"] , prt 0 open]) + + +instance Print ModBody where + prt i e = case e of + MBody extend opens topdefs -> prPrec i 0 (concat [prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]]) + MWith id opens -> prPrec i 0 (concat [prt 0 id , ["with"] , prt 0 opens]) + MReuse id -> prPrec i 0 (concat [["reuse"] , prt 0 id]) + + instance Print Extend where prt i e = case e of Ext id -> prPrec i 0 (concat [prt 0 id , ["**"]]) @@ -142,13 +150,27 @@ instance Print Opens where 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 , [")"]]) + OQualQO qualopen id -> prPrec i 0 (concat [["("] , prt 0 qualopen , prt 0 id , [")"]]) + OQual qualopen id0 id -> prPrec i 0 (concat [["("] , prt 0 qualopen , 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 ComplMod where + prt i e = case e of + CMCompl -> prPrec i 0 (concat []) + CMIncompl -> prPrec i 0 (concat [["incomplete"]]) + + +instance Print QualOpen where + prt i e = case e of + QOCompl -> prPrec i 0 (concat []) + QOIncompl -> prPrec i 0 (concat [["incomplete"]]) + QOInterface -> prPrec i 0 (concat [["interface"]]) + + instance Print Def where prt i e = case e of DDecl ids exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp]) diff --git a/src/GF/Source/SkelGF.hs b/src/GF/Source/SkelGF.hs index 5f5c16227..11e5d10a6 100644 --- a/src/GF/Source/SkelGF.hs +++ b/src/GF/Source/SkelGF.hs @@ -27,17 +27,7 @@ transGrammar x = case x of 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 + MModule complmod modtype modbody -> failure x transConcSpec :: ConcSpec -> Result @@ -56,6 +46,23 @@ transTransfer x = case x of TransferOut open -> failure x +transModType :: ModType -> Result +transModType x = case x of + MTAbstract id -> failure x + MTResource id -> failure x + MTInterface id -> failure x + MTConcrete id0 id -> failure x + MTInstance id0 id -> failure x + MTTransfer id open0 open -> failure x + + +transModBody :: ModBody -> Result +transModBody x = case x of + MBody extend opens topdefs -> failure x + MWith id opens -> failure x + MReuse id -> failure x + + transExtend :: Extend -> Result transExtend x = case x of Ext id -> failure x @@ -71,7 +78,21 @@ transOpens x = case x of transOpen :: Open -> Result transOpen x = case x of OName id -> failure x - OQual id0 id -> failure x + OQualQO qualopen id -> failure x + OQual qualopen id0 id -> failure x + + +transComplMod :: ComplMod -> Result +transComplMod x = case x of + CMCompl -> failure x + CMIncompl -> failure x + + +transQualOpen :: QualOpen -> Result +transQualOpen x = case x of + QOCompl -> failure x + QOIncompl -> failure x + QOInterface -> failure x transDef :: Def -> Result diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs index 9e016d711..d01f50fa3 100644 --- a/src/GF/Source/SourceToGrammar.hs +++ b/src/GF/Source/SourceToGrammar.hs @@ -35,56 +35,63 @@ transGrammar x = case x of 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)) + + 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 -> case body of + MReuse c -> do + id' <- transIdent id + c' <- transIdent c + return (transResDef, GM.MTReuse c', id') + _ -> do + id' <- transIdent id + return (transResDef, GM.MTResource, id') + 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 -> do + id' <- transIdent id + return (transResDef, GM.MTInterface, id') + MTInstance id open -> do + id' <- transIdent id + open' <- transIdent open + return (transResDef, GM.MTInstance open', id') + + (extends', opens', defs',flags') <- case body of + MBody extends opens defs -> do + extends' <- transExtend extends + opens' <- transOpens opens + defs0 <- mapM trDef $ getTopDefs defs + defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] + flags' <- return [f | Right fs <- defs0, f <- fs] + return $ (extends', opens', defs',flags') + MReuse _ -> + return (Nothing,[],NT,[]) + + return $ (id', GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs')) + +transComplMod :: ComplMod -> GM.ModuleStatus +transComplMod x = case x of + CMCompl -> GM.MSComplete + CMIncompl -> GM.MSIncomplete getTopDefs :: [TopDef] -> [TopDef] getTopDefs x = x @@ -130,8 +137,15 @@ transOpens x = case x of 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) + OName id -> liftM (GM.OSimple GM.OQNormal) $ transIdent id + OQualQO q id -> liftM2 GM.OSimple (transQualOpen q) (transIdent id) + OQual q id m -> liftM3 GM.OQualif (transQualOpen q) (transIdent id) (transIdent m) + +transQualOpen :: QualOpen -> Err GM.OpenQualif +transQualOpen x = case x of + QOCompl -> return GM.OQNormal + QOInterface -> return GM.OQInterface + QOIncompl -> return GM.OQIncomplete transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option]) transAbsDef x = case x of @@ -489,10 +503,13 @@ transOldGrammar x name = case x of 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 + mkAbs a = MModule q (MTAbstract absName) (MBody ne (Opens []) (topDefs a)) + mkRes r = MModule q (MTResource resName) (MBody ne (Opens []) (topDefs r)) + mkCnc r = MModule q (MTConcrete cncName absName) + (MBody ne (Opens [OName resName]) (topDefs r)) topDefs t = t + ne = NoExt + q = CMCompl absName = identC topic resName = identC ("Res" ++ lang) -- cgit v1.2.3