msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Working with interfaces and incomplete modules.

Browse Source
This commit is contained in:
aarne
2003-10-23 15:09:07 +00:00
parent 31e0deb017
commit e620ffbd94
25 changed files with 764 additions and 327 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
src/GF/Canon/CanonToGrammar.hs
View File

@@ -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')

151
src/GF/Canon/GFC.cf Normal file
View File

@@ -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 "," ;

12
src/GF/Canon/MkGFC.hs
View File

@@ -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

4
src/GF/Canon/Share.hs
View File

@@ -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)

46
src/GF/Compile/CheckGrammar.hs
View File

@@ -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.

11
src/GF/Compile/Compile.hs
View File

@@ -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

4
src/GF/Compile/Extend.hs
View File

@@ -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

19
src/GF/Compile/GrammarToCanon.hs
View File

@@ -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

2
src/GF/Compile/MkResource.hs
View File

@@ -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) ->

4
src/GF/Compile/ModDeps.hs
View File

@@ -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

5
src/GF/Compile/Optimize.hs
View File

@@ -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

4
src/GF/Compile/RemoveLiT.hs
View File

@@ -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

24
src/GF/Compile/Rename.hs
View File

@@ -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) $

4
src/GF/Grammar/Refresh.hs
View File

@@ -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

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

@@ -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 ---

6
src/GF/Infra/ReadFiles.hs
View File

@@ -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'

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

@@ -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 =

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

@@ -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

286
src/GF/Source/GF.cf Normal file
View File

@@ -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] ;

35
src/GF/Source/GrammarToSource.hs
View File

@@ -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

4
src/GF/Source/LexGF.hs
View File

@@ -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)]))

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

@@ -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])

45
src/GF/Source/SkelGF.hs
View File

@@ -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

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

@@ -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)

2
src/Today.hs
View File

@@ -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"