diff --git a/src/GF/Canon/CanonToGrammar.hs b/src/GF/Canon/CanonToGrammar.hs index 1a677e1a9..93dac97f6 100644 --- a/src/GF/Canon/CanonToGrammar.hs +++ b/src/GF/Canon/CanonToGrammar.hs @@ -31,7 +31,7 @@ canon2sourceModule (i,mi) = do M.MTResource -> return (i',M.MTResource) --- c' not needed M.MTTransfer x y -> return (i',M.MTTransfer x y) --- c' not needed defs <- mapMTree redInfo $ M.jments m - return $ M.ModMod $ M.Module mt flags e os defs + return $ M.ModMod $ M.Module mt (M.mstatus m) flags e os defs _ -> Bad $ "cannot decompile module type" return (i',info') where @@ -39,7 +39,7 @@ canon2sourceModule (i,mi) = do e' <- case M.extends m of Just e -> liftM Just $ redIdent e _ -> return Nothing - os' <- mapM (\ (M.OSimple i) -> liftM (\i -> M.OQualif i i) (redIdent i)) $ + os' <- mapM (\ (M.OSimple q i) -> liftM (\i -> M.OQualif q i i) (redIdent i)) $ M.opens m return (e',os') diff --git a/src/GF/Canon/GFC.cf b/src/GF/Canon/GFC.cf new file mode 100644 index 000000000..1816a77ad --- /dev/null +++ b/src/GF/Canon/GFC.cf @@ -0,0 +1,151 @@ +-- top-level grammar + +-- Canonical GF. AR 27/4/2003 + +entrypoints Canon ; + +Gr. Canon ::= [Module] ; + +Mod. Module ::= ModType "=" Extend Open "{" [Flag] [Def] "}" ; + +MTAbs. ModType ::= "abstract" Ident ; +MTCnc. ModType ::= "concrete" Ident "of" Ident ; +MTRes. ModType ::= "resource" Ident ; +MTTrans. ModType ::= "transfer" Ident ":" Ident "->" Ident ; + +separator Module "" ; + +Ext. Extend ::= Ident "**" ; +NoExt. Extend ::= ; + +NoOpens. Open ::= ; +Opens. Open ::= "open" [Ident] "in" ; + + +-- judgements + +Flg. Flag ::= "flags" Ident "=" Ident ; --- to have the same res word as in GF + +AbsDCat. Def ::= "cat" Ident "[" [Decl] "]" "=" [CIdent] ; +AbsDFun. Def ::= "fun" Ident ":" Exp "=" Exp ; +AbsDTrans. Def ::= "transfer" Ident "=" Exp ; + +ResDPar. Def ::= "param" Ident "=" [ParDef] ; +ResDOper. Def ::= "oper" Ident ":" CType "=" Term ; + +CncDCat. Def ::= "lincat" Ident "=" CType "=" Term ";" Term ; +CncDFun. Def ::= "lin" Ident ":" CIdent "=" "\\" [ArgVar] "->" Term ";" Term ; + +AnyDInd. Def ::= Ident Status "in" Ident ; + +ParD. ParDef ::= Ident [CType] ; + +-- the canonicity of an indirected constant + +Canon. Status ::= "data" ; +NonCan. Status ::= ; + +-- names originating from resource modules: prefixed by the module name + +CIQ. CIdent ::= Ident "." Ident ; + +-- types and terms in abstract syntax; no longer type-annotated + +EApp. Exp1 ::= Exp1 Exp2 ; +EProd. Exp ::= "(" Ident ":" Exp ")" "->" Exp ; +EAbs. Exp ::= "\\" Ident "->" Exp ; +EAtom. Exp2 ::= Atom ; +EData. Exp2 ::= "data" ; + +EEq. Exp ::= "{" [Equation] "}" ; -- list of pattern eqs; primitive notion: [] + +coercions Exp 2 ; + +SType. Sort ::= "Type" ; + +Equ. Equation ::= [APatt] "->" Exp ; + +APC. APatt ::= "(" CIdent [APatt] ")" ; +APV. APatt ::= Ident ; +APS. APatt ::= String ; +API. APatt ::= Integer ; +APW. APatt ::= "_" ; + +separator Decl ";" ; +terminator APatt "" ; +terminator Equation ";" ; + +AC. Atom ::= CIdent ; +AD. Atom ::= "<" CIdent ">" ; +AV. Atom ::= "$" Ident ; +AM. Atom ::= "?" Integer ; +AS. Atom ::= String ; +AI. Atom ::= Integer ; +AT. Atom ::= Sort ; + +Decl. Decl ::= Ident ":" Exp ; + + +-- types, terms, and patterns in concrete syntax + +RecType. CType ::= "{" [Labelling] "}" ; +Table. CType ::= "(" CType "=>" CType ")" ; +Cn. CType ::= CIdent ; +TStr. CType ::= "Str" ; + +Lbg. Labelling ::= Label ":" CType ; + +Arg. Term2 ::= ArgVar ; +I. Term2 ::= CIdent ; -- from resources +Con. Term2 ::= "<" CIdent [Term2] ">" ; +LI. Term2 ::= "$" Ident ; -- from pattern variables + +R. Term2 ::= "{" [Assign] "}" ; +P. Term1 ::= Term2 "." Label ; +T. Term1 ::= "table" CType "{" [Case] "}" ; +S. Term1 ::= Term1 "!" Term2 ; +C. Term ::= Term "++" Term1 ; +FV. Term1 ::= "variants" "{" [Term2] "}" ; --- no separator! + +K. Term2 ::= Tokn ; +E. Term2 ::= "[" "]" ; + +KS. Tokn ::= String ; +KP. Tokn ::= "[" "pre" [String] "{" [Variant] "}" "]" ; + +Ass. Assign ::= Label "=" Term ; +Cas. Case ::= [Patt] "=>" Term ; +Var. Variant ::= [String] "/" [String] ; + +coercions Term 2 ; + +L. Label ::= Ident ; +LV. Label ::= "$" Integer ; +A. ArgVar ::= Ident "@" Integer ; -- no bindings +AB. ArgVar ::= Ident "+" Integer "@" Integer ; -- with a number of bindings + +PC. Patt ::= "(" CIdent [Patt] ")" ; +PV. Patt ::= Ident ; +PW. Patt ::= "_" ; +PR. Patt ::= "{" [PattAssign] "}" ; + +PAss. PattAssign ::= Label "=" Patt ; + +--- here we use the new pragmas to generate list rules + +terminator Flag ";" ; +terminator Def ";" ; +separator ParDef "|" ; +separator CType "" ; +separator CIdent "" ; +separator Assign ";" ; +separator ArgVar "," ; +separator Labelling ";" ; +separator Case ";" ; +separator Term2 "" ; +separator String "" ; +separator Variant ";" ; +separator PattAssign ";" ; +separator Patt "" ; +separator Ident "," ; + diff --git a/src/GF/Canon/MkGFC.hs b/src/GF/Canon/MkGFC.hs index d747634d2..7547280a9 100644 --- a/src/GF/Canon/MkGFC.hs +++ b/src/GF/Canon/MkGFC.hs @@ -21,29 +21,29 @@ canon2grammar (Gr modules) = M.MGrammar $ map mod2info modules where MTAbs a -> (a,M.MTAbstract) MTRes a -> (a,M.MTResource) MTCnc a x -> (a,M.MTConcrete x) - MTTrans a x y -> (a,M.MTTransfer (M.OSimple x) (M.OSimple y)) - in (a,M.ModMod (M.Module mt' flags (ee e) (oo os) defs')) + MTTrans a x y -> (a,M.MTTransfer (M.oSimple x) (M.oSimple y)) + in (a,M.ModMod (M.Module mt' M.MSComplete flags (ee e) (oo os) defs')) ee (Ext m) = Just m ee _ = Nothing - oo (Opens ms) = map M.OSimple ms + oo (Opens ms) = map M.oSimple ms oo _ = [] grammar2canon :: CanonGrammar -> Canon grammar2canon (M.MGrammar modules) = Gr $ map info2mod modules info2mod m = case m of - (a, M.ModMod (M.Module mt flags me os defs)) -> + (a, M.ModMod (M.Module mt _ flags me os defs)) -> let defs' = map info2def $ tree2list defs mt' = case mt of M.MTAbstract -> MTAbs a M.MTResource -> MTRes a M.MTConcrete x -> MTCnc a x - M.MTTransfer (M.OSimple x) (M.OSimple y) -> MTTrans a x y + M.MTTransfer (M.OSimple _ x) (M.OSimple _ y) -> MTTrans a x y in Mod mt' (gfcE me) (gfcO os) flags defs' where gfcE = maybe NoExt Ext - gfcO os = if null os then NoOpens else Opens [m | M.OSimple m <- os] + gfcO os = if null os then NoOpens else Opens [m | M.OSimple _ m <- os] -- these translations are meant to be trivial diff --git a/src/GF/Canon/Share.hs b/src/GF/Canon/Share.hs index fc4d82b06..63e12436a 100644 --- a/src/GF/Canon/Share.hs +++ b/src/GF/Canon/Share.hs @@ -18,8 +18,8 @@ fullOpt = [2] shareModule :: OptSpec -> (Ident, CanonModInfo) -> (Ident, CanonModInfo) shareModule opt (i,m) = case m of - M.ModMod (M.Module mt fs me ops js) -> - (i,M.ModMod (M.Module mt fs me ops (mapTree (shareInfo opt) js))) + M.ModMod (M.Module mt st fs me ops js) -> + (i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js))) _ -> (i,m) shareInfo opt (c, CncCat ty t m) = (c, CncCat ty (shareOpt opt t) m) diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index 8fe4cf988..7bfd2924e 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/src/GF/Compile/CheckGrammar.hs @@ -37,24 +37,28 @@ showCheckModule mos m = do checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule] checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of - ModMod mo@(Module mt fs me ops js) -> case mt of - MTAbstract -> do - js' <- mapMTree (checkAbsInfo gr name) js - return $ (name, ModMod (Module mt fs me ops js')) : ms + ModMod mo@(Module mt st fs me ops js) -> do + js' <- case mt of + MTAbstract -> mapMTree (checkAbsInfo gr name) js - MTTransfer a b -> do - js' <- mapMTree (checkAbsInfo gr name) js - return $ (name, ModMod (Module mt fs me ops js')) : ms + MTTransfer a b -> mapMTree (checkAbsInfo gr name) js - MTResource -> do - js' <- mapMTree (checkResInfo gr) js - return $ (name, ModMod (Module mt fs me ops js')) : ms + MTResource -> mapMTree (checkResInfo gr) js + + MTConcrete a -> do + ModMod abs <- checkErr $ lookupModule gr a + checkCompleteGrammar abs mo + mapMTree (checkCncInfo gr name (a,abs)) js + + MTInterface -> mapMTree (checkResInfo gr) js + + MTInstance a -> do + ModMod abs <- checkErr $ lookupModule gr a + checkCompleteInstance abs mo + mapMTree (checkResInfo gr) js + + return $ (name, ModMod (Module mt st fs me ops js')) : ms - MTConcrete a -> do - ModMod abs <- checkErr $ lookupModule gr a - checkCompleteGrammar abs mo - js' <- mapMTree (checkCncInfo gr name (a,abs)) js - return $ (name, ModMod (Module mt fs me ops js')) : ms _ -> return $ (name,mod) : ms where gr = MGrammar $ (name,mod):ms @@ -87,6 +91,18 @@ checkCompleteGrammar abs cnc = mapM_ checkWarn $ then id else (("Warning: no linearization of" +++ prt f):) +checkCompleteInstance :: SourceRes -> SourceRes -> Check () +checkCompleteInstance abs cnc = mapM_ checkWarn $ + checkComplete [f | (f, ResOper (Yes _) _) <- abs'] cnc' + where + abs' = tree2list $ jments abs + cnc' = mapTree fst $ jments cnc + checkComplete sought given = foldr ckOne [] sought + where + ckOne f = if isInBinTree f given + then id + else (("Warning: no definition given to" +++ prt f):) + -- General Principle: only Yes-values are checked. -- A May-value has always been checked in its origin module. diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs index 1e49946a6..2a119878d 100644 --- a/src/GF/Compile/Compile.hs +++ b/src/GF/Compile/Compile.hs @@ -144,8 +144,7 @@ makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of where putp = putPointE opts -compileSourceModule :: Options -> CompileEnv -> SourceModule -> - IOE (Int,SourceModule) +compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule) compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do let putp = putPointE opts @@ -158,7 +157,7 @@ compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do (k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3 - mo4:_ <- putp " optimizing" $ ioeErr $ evalModule mos mo3r + mo4:_ <- putp " optimizing " $ ioeErr $ evalModule mos mo3r return (k',mo4) @@ -172,16 +171,16 @@ generateModuleCode opts path minfo@(name,info) = do -- for resource, also emit gfr case info of - ModMod m | mtype m == MTResource && emit && nomulti -> do + ModMod m | isResourceModule info && isCompilableModule info && emit && nomulti -> do let (file,out) = (gfrFile pname, prGrammar (MGrammar [minfo])) ioeIO $ writeFile file out >> putStr (" wrote file" +++ file) _ -> return () (file,out) <- do code <- return $ MkGFC.prCanonModInfo minfo' return (gfcFile pname, code) - if emit && nomulti + if isCompilableModule info && emit && nomulti then ioeIO $ writeFile file out >> putStr (" wrote file" +++ file) - else return () + else ioeIO $ putStrFlush "no need to save for this module " return minfo' where nomulti = not $ oElem makeMulti opts diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs index 348cdf71d..5bb38a891 100644 --- a/src/GF/Compile/Extend.hs +++ b/src/GF/Compile/Extend.hs @@ -17,10 +17,10 @@ import Monad extendModInfo :: Ident -> SourceModInfo -> SourceModInfo -> Err SourceModInfo extendModInfo name old new = case (old,new) of - (ModMod m0, ModMod (Module mt fs _ ops js)) -> do + (ModMod m0, ModMod (Module mt st fs _ ops js)) -> do testErr (mtype m0 == mt) ("illegal extension type at module" +++ show name) js' <- extendMod name (jments m0) js - return $ ModMod (Module mt fs Nothing ops js) + return $ ModMod (Module mt st fs Nothing ops js) -- this is what happens when extending a module: new information is inserted, -- and the process is interrupted if unification fails diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs index 07708dd3c..ab493f761 100644 --- a/src/GF/Compile/GrammarToCanon.hs +++ b/src/GF/Compile/GrammarToCanon.hs @@ -28,7 +28,10 @@ showGFC = err id id . liftM (P.printTree . grammar2canon) . redGrammar -- abstract syntax without dependent types redGrammar :: SourceGrammar -> Err C.CanonGrammar -redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo gr +redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo $ filter active gr where + active (_,m) = case typeOfModule m of + MTInterface -> False + _ -> True redModInfo :: (Ident, SourceModInfo) -> Err (Ident, C.CanonModInfo) redModInfo (c,info) = do @@ -43,19 +46,25 @@ redModInfo (c,info) = do return (a', MTConcrete a') MTAbstract -> return (c',MTAbstract) --- c' not needed MTResource -> return (c',MTResource) --- c' not needed + MTInterface -> return (c',MTResource) ---- not needed + MTInstance _ -> return (c',MTResource) --- c' not needed MTTransfer x y -> return (c',MTTransfer (om x) (om y)) --- c' not needed - defss <- mapM (redInfo a) $ tree2list $ jments m + + ---- this generates empty GFC. Better: none + let js = if mstatus m == MSIncomplete then NT else jments m + + defss <- mapM (redInfo a) $ tree2list $ js defs <- return $ sorted2tree $ concat defss -- sorted, but reduced - return $ ModMod $ Module mt flags e os defs + return $ ModMod $ Module mt MSComplete flags e os defs return (c',info') where redExtOpen m = do e' <- case extends m of Just e -> liftM Just $ redIdent e _ -> return Nothing - os' <- mapM (\ (OQualif _ i) -> liftM OSimple (redIdent i)) $ opens m + os' <- mapM (\ (OQualif q _ i) -> liftM (OSimple q) (redIdent i)) $ opens m return (e',os') - om = OSimple . openedModule --- normalizing away qualif + om = oSimple . openedModule --- normalizing away qualif redInfo :: Ident -> (Ident,Info) -> Err [(Ident,C.Info)] redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do diff --git a/src/GF/Compile/MkResource.hs b/src/GF/Compile/MkResource.hs index 8b3a01793..90239cbf5 100644 --- a/src/GF/Compile/MkResource.hs +++ b/src/GF/Compile/MkResource.hs @@ -30,7 +30,7 @@ makeReuse gr r me c = do _ -> prtBad "expected concrete to be the type of" c _ -> prtBad "expected concrete to be the type of" c - return $ Module MTResource flags me ops jms + return $ Module MTResource MSComplete flags me ops jms mkResDefs :: Ident -> Ident -> Maybe Ident -> Maybe Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) -> diff --git a/src/GF/Compile/ModDeps.hs b/src/GF/Compile/ModDeps.hs index 2aa042a95..c940fdd7c 100644 --- a/src/GF/Compile/ModDeps.hs +++ b/src/GF/Compile/ModDeps.hs @@ -39,7 +39,7 @@ checkUniqueErr ms = do checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err () checkUniqueImportNames ns mo = case mo of - ModMod m -> test [n | OQualif n v <- opens m, n /= v] + ModMod m -> test [n | OQualif _ n v <- opens m, n /= v] where @@ -80,7 +80,7 @@ moduleDeps ms = mapM deps ms where -- check for superficial compatibility, not submodule relation etc compatMType mt0 mt = case (mt0,mt) of (MTConcrete _, MTConcrete _) -> True - (MTResourceImpl _, MTResourceImpl _) -> True + (MTInstance _, MTInstance _) -> True (MTReuse _, MTReuse _) -> True ---- some more _ -> mt0 == mt diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs index 07149bebf..fe9b6b1af 100644 --- a/src/GF/Compile/Optimize.hs +++ b/src/GF/Compile/Optimize.hs @@ -29,7 +29,7 @@ evalModule :: [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) -> Err [(Ident,SourceModInfo)] evalModule ms mo@(name,mod) = case mod of - ModMod (Module mt fs me ops js) -> case mt of + ModMod (Module mt st fs me ops js) | st == MSComplete -> case mt of MTResource -> do let deps = allOperDependencies name js ids <- topoSortOpers deps @@ -37,9 +37,10 @@ evalModule ms mo@(name,mod) = case mod of return $ mod' : ms MTConcrete a -> do js' <- mapMTree (evalCncInfo gr0 name a) js - return $ (name, ModMod (Module mt fs me ops js')) : ms + return $ (name, ModMod (Module mt st fs me ops js')) : ms _ -> return $ (name,mod):ms + _ -> return $ (name,mod):ms where gr0 = MGrammar $ ms gr = MGrammar $ (name,mod) : ms diff --git a/src/GF/Compile/RemoveLiT.hs b/src/GF/Compile/RemoveLiT.hs index 0e45be8c0..8dfaf412b 100644 --- a/src/GF/Compile/RemoveLiT.hs +++ b/src/GF/Compile/RemoveLiT.hs @@ -21,9 +21,9 @@ removeLiT gr = liftM MGrammar $ mapM (remlModule gr) (modules gr) remlModule :: SourceGrammar -> (Ident,SourceModInfo) -> Err (Ident,SourceModInfo) remlModule gr mi@(name,mod) = case mod of - ModMod (Module mt fs me ops js) -> do + ModMod (Module mt st fs me ops js) -> do js1 <- mapMTree (remlResInfo gr) js - let mod2 = ModMod $ Module mt fs me ops js1 + let mod2 = ModMod $ Module mt st fs me ops js1 return $ (name,mod2) _ -> return mi diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs index 6f652820a..393f48a9c 100644 --- a/src/GF/Compile/Rename.hs +++ b/src/GF/Compile/Rename.hs @@ -32,17 +32,17 @@ renameSourceTerm g m t = do renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule] renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of - ModMod (Module mt fs me ops js) -> do + ModMod (Module mt st fs me ops js) -> do (_,mod1@(ModMod m)) <- extendModule ms (name,mod) let js1 = jments m status <- buildStatus (MGrammar ms) name mod1 js2 <- mapMTree (renameInfo status) js1 - let mod2 = ModMod $ Module mt fs me (map forceQualif ops) js2 + let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2 return $ (name,mod2) : ms extendModule :: [SourceModule] -> SourceModule -> Err SourceModule extendModule ms (name,mod) = case mod of - ModMod (Module mt fs me ops js0) -> do + ModMod (Module mt st fs me ops js0) -> do js <- case mt of {- --- building the {s : Str} lincat MTConcrete a -> do @@ -62,7 +62,7 @@ extendModule ms (name,mod) = case mod of _ -> Bad $ "cannot find extended module" +++ prt n extendMod n (jments m0) js _ -> return js - return $ (name,ModMod (Module mt fs me ops js1)) + return $ (name,ModMod (Module mt st fs me ops js1)) type Status = (StatusTree, [(OpenSpec Ident, StatusTree)]) @@ -91,9 +91,9 @@ renameIdentTerm env@(act,imps) t = return $ f c _ -> return t where - opens = act : [st | (OSimple _,st) <- imps] - qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ - [(m, st) | (OSimple m, st) <- imps] -- qualifying is always possible + opens = act : [st | (OSimple _ _,st) <- imps] + qualifs = [(m, st) | (OQualif _ m _, st) <- imps] ++ + [(m, st) | (OSimple _ m, st) <- imps] -- qualifying is always possible --- would it make sense to optimize this by inlining? renameIdentPatt :: Status -> Patt -> Err Patt @@ -114,14 +114,14 @@ info2status mq (c,i) = (c, case i of tree2status :: OpenSpec Ident -> BinTree (Ident,Info) -> BinTree (Ident,StatusInfo) tree2status o = case o of - OSimple i -> mapTree (info2status (Just i)) - OQualif i j -> mapTree (info2status (Just j)) + OSimple _ i -> mapTree (info2status (Just i)) + OQualif _ i j -> mapTree (info2status (Just j)) buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status buildStatus gr c mo = let mo' = self2status c mo in case mo of ModMod m -> do let gr1 = MGrammar $ (c,mo) : modules gr - ops = [OSimple e | e <- allExtends gr1 c] ++ allOpens m + ops = [OSimple OQNormal e | e <- allExtends gr1 c] ++ allOpens m mods <- mapM (lookupModule gr1 . openedModule) ops let sts = map modInfo2status $ zip ops mods return $ if isModCnc m @@ -144,8 +144,8 @@ self2status c i = mapTree (info2status (Just c)) js where -- qualify internal _ -> True forceQualif o = case o of - OSimple i -> OQualif i i - OQualif _ i -> OQualif i i + OSimple q i -> OQualif q i i + OQualif q _ i -> OQualif q i i renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info) renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $ diff --git a/src/GF/Grammar/Refresh.hs b/src/GF/Grammar/Refresh.hs index 8b33444d0..ff4c9b8af 100644 --- a/src/GF/Grammar/Refresh.hs +++ b/src/GF/Grammar/Refresh.hs @@ -86,9 +86,9 @@ refreshGrammar = liftM (MGrammar . snd) . foldM refreshModule (0,[]) . modules refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule]) refreshModule (k,ms) mi@(i,m) = case m of - ModMod mo@(Module mt fs me ops js) | (isModCnc mo || mt == MTResource) -> do + ModMod mo@(Module mt fs st me ops js) | (isModCnc mo || mt == MTResource) -> do (k',js') <- foldM refreshRes (k,[]) $ tree2list js - return (k', (i, ModMod(Module mt fs me ops (buildTree js'))) : ms) + return (k', (i, ModMod(Module mt fs st me ops (buildTree js'))) : ms) _ -> return (k, mi:ms) where refreshRes (k,cs) ci@(c,info) = case info of diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs index bae22219f..d0c5dc516 100644 --- a/src/GF/Infra/Modules.hs +++ b/src/GF/Infra/Modules.hs @@ -18,11 +18,13 @@ data MGrammar i f a = MGrammar {modules :: [(i,ModInfo i f a)]} data ModInfo i f a = ModMainGrammar (MainGrammar i) - | ModMod (Module i f a) + | ModMod (Module i f a) + | ModWith (ModuleType i) ModuleStatus i [OpenSpec i] deriving Show data Module i f a = Module { mtype :: ModuleType i , + mstatus :: ModuleStatus , flags :: [f] , extends :: Maybe i , opens :: [OpenSpec i] , @@ -30,6 +32,20 @@ data Module i f a = Module { } deriving Show +-- encoding the type of the module +data ModuleType i = + MTAbstract + | MTTransfer (OpenSpec i) (OpenSpec i) + | MTResource + | MTConcrete i + + -- up to this, also used in GFC. Below, source only. + + | MTInterface + | MTInstance i + | MTReuse i + deriving (Eq,Show) + -- destructive update --- dep order preserved since old cannot depend on new @@ -41,8 +57,8 @@ updateMGrammar old new = MGrammar $ ns = modules new updateModule :: Ord i => Module i f t -> i -> t -> Module i f t -updateModule (Module mt fs me ops js) i t = - Module mt fs me ops (updateTree (i,t) js) +updateModule (Module mt ms fs me ops js) i t = + Module mt ms fs me ops (updateTree (i,t) js) data MainGrammar i = MainGrammar { mainAbstract :: i , @@ -58,13 +74,29 @@ data MainConcreteSpec i = MainConcreteSpec { } deriving Show -data OpenSpec i = OSimple i | OQualif i i +data OpenSpec i = + OSimple OpenQualif i + | OQualif OpenQualif i i + deriving (Eq,Show) + +data OpenQualif = + OQNormal + | OQInterface + | OQIncomplete + deriving (Eq,Show) + +oSimple = OSimple OQNormal +oQualif = OQualif OQNormal + +data ModuleStatus = + MSComplete + | MSIncomplete deriving (Eq,Show) openedModule :: OpenSpec i -> i openedModule o = case o of - OSimple m -> m - OQualif _ m -> m + OSimple _ m -> m + OQualif _ _ m -> m allOpens m = case mtype m of MTTransfer a b -> a : b : opens m @@ -75,9 +107,9 @@ depPathModule :: Ord i => Module i f a -> [OpenSpec i] depPathModule m = fors m ++ exts m ++ opens m where fors m = case mtype m of MTTransfer i j -> [i,j] - MTConcrete i -> [OSimple i] + MTConcrete i -> [oSimple i] _ -> [] - exts m = map OSimple $ maybe [] return $ extends m + exts m = map oSimple $ maybe [] return $ extends m -- all modules that a module extends, directly or indirectly allExtends :: (Show i,Ord i) => MGrammar i f a -> i -> [i] @@ -89,7 +121,7 @@ allExtends gr i = case lookupModule gr i of -- initial search path: the nonqualified dependencies searchPathModule :: Ord i => Module i f a -> [i] -searchPathModule m = [i | OSimple i <- depPathModule m] +searchPathModule m = [i | OSimple _ i <- depPathModule m] -- a new module can safely be added to the end, since nothing old can depend on it addModule :: Ord i => @@ -108,27 +140,14 @@ data IdentM i = IdentM { } deriving (Eq,Show) --- encoding the type of the module -data ModuleType i = - MTAbstract - | MTTransfer (OpenSpec i) (OpenSpec i) - | MTResource - | MTResourceInt - | MTResourceImpl i - | MTConcrete i - | MTConcreteInt i i - | MTConcreteImpl i i i - | MTReuse i - deriving (Eq,Show) - typeOfModule mi = case mi of ModMod m -> mtype m isResourceModule mi = case typeOfModule mi of MTResource -> True MTReuse _ -> True - MTResourceInt -> True - MTResourceImpl _ -> True +--- MTInterface -> True + MTInstance _ -> True _ -> False abstractOfConcrete :: (Show i, Eq i) => MGrammar i f a -> i -> Err i @@ -187,3 +206,11 @@ isModTrans m = case mtype m of sameMType m n = case (m,n) of (MTConcrete _, MTConcrete _) -> True _ -> m == n + +-- don't generate code for interfaces and for incomplete modules +isCompilableModule m = case m of + ModMod m -> case mtype m of + MTInterface -> False + _ -> mstatus m == MSComplete + _ -> False --- + diff --git a/src/GF/Infra/ReadFiles.hs b/src/GF/Infra/ReadFiles.hs index 5e4d2b165..bc2706b49 100644 --- a/src/GF/Infra/ReadFiles.hs +++ b/src/GF/Infra/ReadFiles.hs @@ -91,15 +91,17 @@ gfFile = suffixFile "gf" importsOfFile :: String -> [FilePath] importsOfFile = + drop 1 . -- ignore module name itself filter (not . spec) . -- ignore keywords and special symbols unqual . -- take away qualifiers takeWhile (not . term) . -- read until curly or semic - drop 2 . -- ignore keyword and module name lexs . -- analyse into lexical tokens unComm -- ignore comments before the headed line where term = flip elem ["{",";"] - spec = flip elem ["of", "open","in", ":", "->", "reuse", "=", "(", ")",",","**"] + spec = flip elem ["of", "open","in", ":", "->", "reuse", "=", "(", ")",",","**","with", + "abstract","concrete","resource","transfer","interface","incomplete", + "instance"] unqual ws = case ws of "(":q:ws' -> unqual ws' w:ws' -> w:unqual ws' 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) diff --git a/src/Today.hs b/src/Today.hs index 4c0ebb181..b74abc457 100644 --- a/src/Today.hs +++ b/src/Today.hs @@ -1 +1 @@ -module Today where today = "Tue Oct 21 17:20:02 CEST 2003" +module Today where today = "Thu Oct 23 17:57:21 CEST 2003"