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

extended functor syntax

Browse Source
This commit is contained in:
aarne
2007-06-19 18:12:35 +00:00
parent 2ded5b6d28
commit 219c686633
9 changed files with 631 additions and 579 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
doc/tutorial/music/MusicEng.gf
View File

@@ -1,7 +1,11 @@
--# -path=.:present:api:prelude
concrete MusicEng of Music = MusicEng0 - [PropKind] **
open SyntaxEng in {
concrete MusicEng of Music =
MusicI - [PropKind]
with
(Syntax = SyntaxEng),
(MusicLex = MusicLexEng) **
open SyntaxEng in {
lin
PropKind k p = mkCN k (mkRS (mkRCl which_RP (mkVP p))) ;
}

3
doc/tutorial/music/MusicEng0.gf
View File

@@ -1,3 +0,0 @@
concrete MusicEng0 of Music = MusicI with
(Syntax = SyntaxEng),
(MusicLex = MusicLexEng) ;

20
src/GF/Compile/Rebuild.hs
View File

@@ -25,6 +25,8 @@ import GF.Infra.Ident
import GF.Infra.Modules
import GF.Data.Operations
import Data.List (nub)
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- AR 24/10/2003
rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule
@@ -58,7 +60,8 @@ rebuildModule ms mo@(i,mi) = do
_ -> return mi
-- add the instance opens to an incomplete module "with" instances
ModWith mt stat ext me ops -> do
-- ModWith mt stat ext me ops -> do
ModWith (Module mt stat fs_ me ops_ js_) (ext,incl) ops -> do
let insts = [(inf,inst) | OQualif _ inf inst <- ops]
let infs = map fst insts
let stat' = ifNull MSComplete (const MSIncomplete)
@@ -66,12 +69,17 @@ rebuildModule ms mo@(i,mi) = do
testErr (stat' == MSComplete || stat == MSIncomplete)
("module" +++ prt i +++ "remains incomplete")
Module mt0 _ fs me' ops0 js <- lookupModMod gr ext
let ops1 = ops ++ [o | o <- ops0, notElem (openedModule o) infs]
++ [oQualif i i | i <- map snd insts] ----
++ [oSimple i | i <- map snd insts] ----
---- ++ [oSimple ext] ---- to encode dependence
let ops1 = nub $
ops_ ++ -- N.B. js has been name-resolved already
ops ++ [o | o <- ops0, notElem (openedModule o) infs]
++ [oQualif i i | i <- map snd insts] ----
++ [oSimple i | i <- map snd insts] ----
--- check if me is incomplete
return $ ModMod $ Module mt0 stat' fs me ops1 js
let fs1 = fs_ ++ fs -- new flags have priority
let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
let js1 = buildTree (tree2list js_ ++ js0)
return $ ModMod $ Module mt0 stat' fs1 me ops1 js1
---- (mapTree (qualifInstanceInfo insts) js) -- not needed
_ -> return mi

5
src/GF/Infra/Modules.hs
View File

@@ -58,7 +58,7 @@ 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)
| ModWith (ModuleType i) ModuleStatus i [(i,MInclude i)] [OpenSpec i]
| ModWith (Module i f a) (i,MInclude i) [OpenSpec i]
deriving Show
data Module i f a = Module {
@@ -213,7 +213,8 @@ partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor]
mods = modules gr
modsFor = case m of
ModMod n -> (i:) $ map openedModule $ allDepsModule gr n
_ -> [i] ---- ModWith?
---- ModWith n i os -> i : map openedModule os ++ partOfGrammar (ModMod n) ----
_ -> [i]
-- | all modules that a module extends, directly or indirectly

9
src/GF/Source/AbsGF.hs
View File

@@ -38,9 +38,12 @@ data ModType =
deriving (Eq,Ord,Show)
data ModBody =
MBody Extend Opens [TopDef]
| MWith Ident [Open]
| MWithE [Included] Ident [Open]
MNoBody [Included]
| MWithBody Included [Open] Opens [TopDef]
| MWithEBody [Included] Included [Open] Opens [TopDef]
| MBody Extend Opens [TopDef]
| MWith Included [Open]
| MWithE [Included] Included [Open]
| MReuse Ident
| MUnion [Included]
deriving (Eq,Ord,Show)

11
src/GF/Source/GF.cf
View File

@@ -43,9 +43,14 @@ 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] ;
MWithE. ModBody ::= [Included] "**" Ident "with" [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" Ident ; --%
MUnion. ModBody ::= "union" [Included] ;--%

1104
src/GF/Source/ParGF.hs
View File

File diff suppressed because one or more lines are too long

8
src/GF/Source/PrintGF.hs
View File

@@ -144,13 +144,15 @@ instance Print ModType where
instance Print ModBody where
prt i e = case e of
MNoBody includeds -> prPrec i 0 (concatD [prt 0 includeds])
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 "}")])
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 "}")])
MBody extend opens topdefs -> prPrec i 0 (concatD [prt 0 extend , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")])
MWith id opens -> prPrec i 0 (concatD [prt 0 id , doc (showString "with") , prt 0 opens])
MWithE includeds id opens -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 id , doc (showString "with") , prt 0 opens])
MWith included opens -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens])
MWithE includeds included opens -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens])
MReuse id -> prPrec i 0 (concatD [doc (showString "reuse") , prt 0 id])
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 "**")])

42
src/GF/Source/SourceToGrammar.hs
View File

@@ -92,32 +92,40 @@ transModDef x = case x of
open' <- transIdent open
mkModRes id (GM.MTInstance open') body
case body of
MBody extends opens defs -> do
mkBody (mstat', trDef, mtyp', id') body
where
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
defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds]
flags' <- return [f | Right fs <- defs0, f <- fs]
return (id',GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs'))
MReuse _ -> do
MReuse _ -> do
return (id', GM.ModMod (GM.Module mtyp' mstat' [] [] [] emptyBinTree))
MUnion imps -> do
MUnion imps -> do
imps' <- mapM transIncluded imps
return (id',
GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' [] [] [] emptyBinTree))
MWith m opens -> do
m' <- transIdent m
opens' <- mapM transOpen opens
return (id', GM.ModWith mtyp' mstat' m' [] opens')
MWithE extends m opens -> do
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' <- transIdent m
opens' <- mapM transOpen opens
return (id', GM.ModWith mtyp' mstat' m' extends' opens')
where
mkModRes id mtyp body = do
m' <- transIncludedExt m
insts' <- mapM transOpen insts
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 (id',
GM.ModWith (GM.Module mtyp' mstat' flags' extends' opens' defs') m' insts')
mkModRes id mtyp body = do
id' <- transIdent id
case body of
MReuse c -> do
@@ -125,7 +133,7 @@ transModDef x = case x of
mtyp' <- trMReuseType mtyp c'
return (transResDef, GM.MTReuse mtyp', id')
_ -> return (transResDef, mtyp, id')
trMReuseType mtyp c = case mtyp of
trMReuseType mtyp c = case mtyp of
GM.MTInterface -> return $ GM.MRInterface c
GM.MTInstance op -> return $ GM.MRInstance c op
GM.MTResource -> return $ GM.MRResource c
@@ -715,4 +723,4 @@ mkConsId = prefixId "Cons"
mkBaseId = prefixId "Base"
prefixId :: String -> Ident -> Ident
prefixId pref id = IC (pref ++ prIdent id)
prefixId pref id = IC (pref ++ prIdent id)