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

resources and new instantiation syntax

Browse Source
This commit is contained in:
aarne
2005-02-04 19:17:57 +00:00
parent b8b5139a8a
commit bc05653e82
14 changed files with 584 additions and 535 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -165,12 +165,13 @@ extendCompileEnvCanon ((k,s,c),fts) cgr ft =
type TimedCompileEnv = (CompileEnv,[(FilePath,ModTime)])
compileOne :: Options -> TimedCompileEnv -> FullPath -> IOE TimedCompileEnv
compileOne opts env file = do
compileOne opts env@((_,srcgr,_),_) file = do
let putp = putPointE opts
let gf = fileSuffix file
let path = justInitPath file
let name = fileBody file
let mos = modules srcgr
case gf of
-- for multilingual canonical gf, just read the file and update environment
@@ -188,12 +189,13 @@ compileOne opts env file = do
-- for compiled resource, parse and organize, then update environment
"gfr" -> do
sm0 <- putp ("| parsing" +++ file) $ getSourceModule file
let mos = case env of ((_,gr,_),_) -> modules gr
sm0 <- putp ("| parsing" +++ file) $ getSourceModule file
sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm0
---- experiment with not optimizing gfr
---- sm:_ <- putp " optimizing " $ ioeErr $ evalModule mos sm1
let gfc = gfcFile name
cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc
ft <- getReadTimes file
cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc
ft <- getReadTimes file
extendCompileEnv env (sm,cm) ft
-- for gf source, do full compilation
@@ -202,7 +204,12 @@ compileOne opts env file = do
(k',sm) <- makeSourceModule opts (fst env) sm0
cm <- putp " generating code... " $ generateModuleCode opts path sm
ft <- getReadTimes file
extendCompileEnvInt env (k',sm,cm) ft
sm':_ <- case snd sm of
---- ModMod n | isModRes n -> putp " optimizing " $ ioeErr $ evalModule mos sm
_ -> return [sm]
extendCompileEnvInt env (k',sm',cm) ft
-- dispatch reused resource at early stage
@@ -255,8 +262,11 @@ 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:_ <-
---- case snd mo1b of
---- ModMod n | isModCnc n ->
putp " optimizing " $ ioeErr $ evalModule mos mo3r
---- _ -> return [mo3r]
return (k',mo4)
where
---- prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug

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

@@ -31,6 +31,12 @@ import Monad
extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
extendModule ms (name,mod) = case mod of
---- Just to allow inheritance in incomplete concrete (which are not
---- compiled anyway), extensions are not built for them.
---- Should be replaced by real control. AR 4/2/2005
ModMod m | mstatus m == MSIncomplete && isModCnc m -> return (name,mod)
ModMod m -> do
mod' <- foldM extOne m (extends m)
return (name,ModMod mod')
@@ -42,10 +48,11 @@ extendModule ms (name,mod) = case mod of
-- test that the module types match, and find out if the old is complete
testErr (sameMType (mtype m) mt)
("illegal extension type to module" +++ prt name)
return (m,isCompleteModule m)
return (m, isCompleteModule m)
---- return (m, if (isCompleteModule m) then True else not (isCompleteModule mod))
-- build extension in a way depending on whether the old module is complete
js1 <- extendMod isCompl n (jments m0) js
js1 <- extendMod isCompl n name (jments m0) js
-- if incomplete, throw away extension information
let me' = if isCompl then es else (filter (/=n) es)
@@ -55,11 +62,11 @@ extendModule ms (name,mod) = case mod of
-- and the process is interrupted if unification fails.
-- If the extended module is incomplete, its judgements are just copied.
extendMod :: Bool -> Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) ->
extendMod :: Bool -> Ident -> Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) ->
Err (BinTree (Ident,Info))
extendMod isCompl name old new = foldM try new $ tree2list old where
extendMod isCompl name base old new = foldM try new $ tree2list old where
try t i@(c,_) = errIn ("constant" +++ prt c) $
tryInsert (extendAnyInfo isCompl name) indirIf t i
tryInsert (extendAnyInfo isCompl name base) indirIf t i
indirIf = if isCompl then indirInfo name else id
indirInfo :: Ident -> Info -> Info
@@ -76,8 +83,9 @@ perhIndir n p = case p of
Yes _ -> May n
_ -> p
extendAnyInfo :: Bool -> Ident -> Info -> Info -> Err Info
extendAnyInfo isc n i j = errIn ("building extension for" +++ prt n) $ case (i,j) of
extendAnyInfo :: Bool -> Ident -> Ident -> Info -> Info -> Err Info
extendAnyInfo isc n o i j =
errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $ case (i,j) of
(AbsCat mc1 mf1, AbsCat mc2 mf2) ->
liftM2 AbsCat (updn isc n mc1 mc2) (updn isc n mf1 mf2) --- add cstrs
(AbsFun mt1 md1, AbsFun mt2 md2) ->
@@ -107,7 +115,8 @@ extendAnyInfo isc n i j = errIn ("building extension for" +++ prt n) $ case (i,j
--- where
updn isc n = if isc then (updatePerhaps n) else (updatePerhapsHard n)
updn isc n = if isc then (updatePerhaps n) else (updatePerhapsHard n)
updc isc n = if True then (updatePerhaps n) else (updatePerhapsHard n)

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

@@ -9,7 +9,7 @@
-- > CVS $Author $
-- > CVS $Revision $
--
-- (Description of the module)
-- Rebuild a source module from incomplete and its with-instance.
-----------------------------------------------------------------------------
module Rebuild where
@@ -45,7 +45,7 @@ rebuildModule ms mo@(i,mi) = do
m1 <- lookupModMod gr i0
testErr (isModRes m1) ("interface expected instead of" +++ prt i0)
m' <- do
js' <- extendMod False i0 (jments m1) (jments m)
js' <- extendMod False i0 i (jments m1) (jments m)
--- to avoid double inclusions, in instance I of I0 = J0 ** ...
case extends m of
[] -> return $ replaceJudgements m js'
@@ -60,14 +60,14 @@ rebuildModule ms mo@(i,mi) = do
_ -> return mi
-- add the instance opens to an incomplete module "with" instances
ModWith mt stat ext ops -> do
ModWith mt stat ext me ops -> do
let insts = [(inf,inst) | OQualif _ inf inst <- ops]
let infs = map fst insts
let stat' = ifNull MSComplete (const MSIncomplete)
[i | i <- is, notElem i infs]
testErr (stat' == MSComplete || stat == MSIncomplete)
("module" +++ prt i +++ "remains incomplete")
Module mt0 _ fs me ops0 js <- lookupModMod gr ext
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] ----

11
src/GF/Data/Operations.hs
View File

@@ -192,14 +192,17 @@ mapP f p = case p of
Nope -> Nope
-- this is what happens when matching two values in the same module
unifPerhaps :: (Eq a, Eq b) => Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
unifPerhaps :: (Eq a, Eq b, Show a, Show b) =>
Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
unifPerhaps p1 p2 = case (p1,p2) of
(Nope, _) -> return p2
(_, Nope) -> return p1
_ -> if p1==p2 then return p1 else Bad "update conflict"
_ -> if p1==p2 then return p1
else Bad ("update conflict between" ++++ show p1 ++++ show p2)
-- this is what happens when updating a module extension
updatePerhaps :: (Eq a,Eq b) => b -> Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
updatePerhaps :: (Eq a,Eq b, Show a, Show b) =>
b -> Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
updatePerhaps old p1 p2 = case (p1,p2) of
(Yes a, Nope) -> return $ may old
(May older,Nope) -> return $ may older
@@ -207,7 +210,7 @@ updatePerhaps old p1 p2 = case (p1,p2) of
_ -> unifPerhaps p1 p2
-- here the value is copied instead of referred to; used for oper types
updatePerhapsHard :: (Eq a, Eq b) => b ->
updatePerhapsHard :: (Eq a, Eq b, Show a, Show b) => b ->
Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
updatePerhapsHard old p1 p2 = case (p1,p2) of
(Yes a, Nope) -> return $ yes a

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

@@ -33,7 +33,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 [OpenSpec i]
| ModWith (ModuleType i) ModuleStatus i [i] [OpenSpec i]
deriving Show
data Module i f a = Module {

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

@@ -254,10 +254,18 @@ getModuleHeader ws = case ws of
((MTyResource,name),(m,MUInstance):(n,MUComplete):[(n,MUOther) | n <- ms])
ms -> ((MTyResource,name),(m,MUInstance):[(n,MUOther) | n <- ms])
"concrete":name:a:ws2 -> case span (/= "with") ws2 of
(es,_:ms) -> ((MTyOther,name),
[(m,MUOther) | m <- es] ++
[(n,MUComplete) | n <- ms])
--- m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms])
(ms,[]) -> ((MTyOther,name),[(n,MUOther) | n <- a:ms])
_:name:ws2 -> case ws2 of
"reuse":m:_ -> ((MTyOther,name),[(m,MUReuse)])
m:n:"with":ms ->
((MTyOther,name),(m,MUInstance):(n,MUOther):[(n,MUComplete) | n <- ms])
---- m:n:"with":ms ->
---- ((MTyOther,name),(m,MUInstance):(n,MUOther):[(n,MUComplete) | n <- ms])
m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms])
ms -> ((MTyOther,name),[(n,MUOther) | n <- ms])

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

@@ -54,6 +54,7 @@ data ModType =
data ModBody =
MBody Extend Opens [TopDef]
| MWith Ident [Open]
| MWithE [Ident] Ident [Open]
| MReuse Ident
| MUnion [Included]
deriving (Eq,Ord,Show)
@@ -65,7 +66,7 @@ data Extend =
data Opens =
NoOpens
| Opens [Open]
| OpenIn [Open]
deriving (Eq,Ord,Show)
data Open =
@@ -138,7 +139,7 @@ data DataConstr =
deriving (Eq,Ord,Show)
data ParDef =
ParDef Ident [ParConstr]
ParDefDir Ident [ParConstr]
| ParDefIndir Ident Ident
| ParDefAbs Ident
deriving (Eq,Ord,Show)

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

@@ -39,7 +39,8 @@ MTInstance. ModType ::= "instance" Ident "of" Ident ;
MTTransfer. ModType ::= "transfer" Ident ":" Open "->" Open ;
MBody. ModBody ::= Extend Opens "{" [TopDef] "}" ;
MWith. ModBody ::= Ident "with" [Open] ;
MWith. ModBody ::= Ident "with" [Open] ;
MWithE. ModBody ::= [Ident] "**" Ident "with" [Open] ;
MReuse. ModBody ::= "reuse" Ident ;
MUnion. ModBody ::= "union" [Included] ;
@@ -50,7 +51,7 @@ NoExt. Extend ::= ;
separator Open "," ;
NoOpens. Opens ::= ;
Opens. Opens ::= "open" [Open] "in" ;
OpenIn. Opens ::= "open" [Open] "in" ;
OName. Open ::= Ident ;
OQualQO. Open ::= "(" QualOpen Ident ")" ;
@@ -105,7 +106,7 @@ DataQId. DataConstr ::= Ident "." Ident ;
separator DataConstr "|" ;
ParDef. ParDef ::= Ident "=" [ParConstr] ;
ParDefDir. ParDef ::= Ident "=" [ParConstr] ;
ParDefIndir. ParDef ::= Ident "=" "(" "in" Ident ")" ;
ParDefAbs. ParDef ::= Ident ;

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

@@ -62,7 +62,7 @@ trQualOpen q = case q of
OQInterface -> P.QOInterface
mkOpens ds = if null ds then P.NoOpens else P.Opens ds
mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds
mkTopDefs ds = ds
trAnyDef :: (Ident,Info) -> [P.TopDef]
@@ -80,7 +80,7 @@ trAnyDef (i,info) = let i' = tri i in case info of
ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]]
ResParam pp -> [P.DefPar [case pp of
Yes ps -> P.ParDef i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps]
Yes ps -> P.ParDefDir i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps]
May b -> P.ParDefIndir i' $ tri b
_ -> P.ParDefAbs i']]

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

@@ -62,20 +62,18 @@ prToken t = case t of
_ -> show t
data BTree = N | B String Tok BTree BTree deriving (Show)
eitherResIdent :: (String -> Tok) -> String -> Tok
eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where
isResWord s = isInTree s $
B "lincat" (B "def" (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 "data" (B "concrete" N N) N))) (B "include" (B "fun" (B "fn" (B "flags" N N) N) (B "in" (B "grammar" N N) N)) (B "interface" (B "instance" (B "incomplete" N N) N) (B "lin" (B "let" N N) N)))) (B "resource" (B "out" (B "of" (B "lintype" (B "lindef" N N) N) (B "oper" (B "open" N N) N)) (B "pattern" (B "param" (B "package" N N) N) (B "printname" (B "pre" N N) N))) (B "union" (B "table" (B "strs" (B "reuse" N N) N) (B "transfer" (B "tokenizer" N N) N)) (B "where" (B "variants" (B "var" N N) N) (B "with" N N))))
eitherResIdent tv s = treeFind resWords
where
treeFind N = tv s
treeFind (B a t left right) | s < a = treeFind left
| s > a = treeFind right
| s == a = t
data BTree = N | B String BTree BTree deriving (Show)
isInTree :: String -> BTree -> Bool
isInTree x tree = case tree of
N -> False
B a left right
| x < a -> isInTree x left
| x > a -> isInTree x right
| x == a -> True
resWords = b "lincat" (b "def" (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 "data" (b "concrete" N N) N))) (b "include" (b "fun" (b "fn" (b "flags" N N) N) (b "in" (b "grammar" N N) N)) (b "interface" (b "instance" (b "incomplete" N N) N) (b "lin" (b "let" N N) N)))) (b "resource" (b "out" (b "of" (b "lintype" (b "lindef" N N) N) (b "oper" (b "open" N N) N)) (b "pattern" (b "param" (b "package" N N) N) (b "printname" (b "pre" N N) N))) (b "union" (b "table" (b "strs" (b "reuse" N N) N) (b "transfer" (b "tokenizer" N N) N)) (b "where" (b "variants" (b "var" N N) N) (b "with" N N))))
where b s = B s (TS s)
unescapeInitTail :: String -> String
unescapeInitTail = unesc . tail where

22
src/GF/Source/LexGF.x
View File

@@ -68,20 +68,18 @@ prToken t = case t of
_ -> show t
data BTree = N | B String Tok BTree BTree deriving (Show)
eitherResIdent :: (String -> Tok) -> String -> Tok
eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where
isResWord s = isInTree s $
B "lincat" (B "def" (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 "data" (B "concrete" N N) N))) (B "include" (B "fun" (B "fn" (B "flags" N N) N) (B "in" (B "grammar" N N) N)) (B "interface" (B "instance" (B "incomplete" N N) N) (B "lin" (B "let" N N) N)))) (B "resource" (B "out" (B "of" (B "lintype" (B "lindef" N N) N) (B "oper" (B "open" N N) N)) (B "pattern" (B "param" (B "package" N N) N) (B "printname" (B "pre" N N) N))) (B "union" (B "table" (B "strs" (B "reuse" N N) N) (B "transfer" (B "tokenizer" N N) N)) (B "where" (B "variants" (B "var" N N) N) (B "with" N N))))
eitherResIdent tv s = treeFind resWords
where
treeFind N = tv s
treeFind (B a t left right) | s < a = treeFind left
| s > a = treeFind right
| s == a = t
data BTree = N | B String BTree BTree deriving (Show)
isInTree :: String -> BTree -> Bool
isInTree x tree = case tree of
N -> False
B a left right
| x < a -> isInTree x left
| x > a -> isInTree x right
| x == a -> True
resWords = b "lincat" (b "def" (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 "data" (b "concrete" N N) N))) (b "include" (b "fun" (b "fn" (b "flags" N N) N) (b "in" (b "grammar" N N) N)) (b "interface" (b "instance" (b "incomplete" N N) N) (b "lin" (b "let" N N) N)))) (b "resource" (b "out" (b "of" (b "lintype" (b "lindef" N N) N) (b "oper" (b "open" N N) N)) (b "pattern" (b "param" (b "package" N N) N) (b "printname" (b "pre" N N) N))) (b "union" (b "table" (b "strs" (b "reuse" N N) N) (b "transfer" (b "tokenizer" N N) N)) (b "where" (b "variants" (b "var" N N) N) (b "with" N N))))
where b s = B s (TS s)
unescapeInitTail :: String -> String
unescapeInitTail = unesc . tail where

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

File diff suppressed because one or more lines are too long

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

@@ -158,6 +158,7 @@ instance Print ModBody where
prt i e = case e of
MBody extend opens topdefs -> prPrec i 0 (concatD [prt 0 extend , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")])
MWith id opens -> prPrec i 0 (concatD [prt 0 id , doc (showString "with") , prt 0 opens])
MWithE ids id opens -> prPrec i 0 (concatD [prt 0 ids , doc (showString "**") , prt 0 id , 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])
@@ -171,7 +172,7 @@ instance Print Extend where
instance Print Opens where
prt i e = case e of
NoOpens -> prPrec i 0 (concatD [])
Opens opens -> prPrec i 0 (concatD [doc (showString "open") , prt 0 opens , doc (showString "in")])
OpenIn opens -> prPrec i 0 (concatD [doc (showString "open") , prt 0 opens , doc (showString "in")])
instance Print Open where
@@ -282,7 +283,7 @@ instance Print DataConstr where
instance Print ParDef where
prt i e = case e of
ParDef id parconstrs -> prPrec i 0 (concatD [prt 0 id , doc (showString "=") , prt 0 parconstrs])
ParDefDir id parconstrs -> prPrec i 0 (concatD [prt 0 id , doc (showString "=") , prt 0 parconstrs])
ParDefIndir id0 id -> prPrec i 0 (concatD [prt 0 id0 , doc (showString "=") , doc (showString "(") , doc (showString "in") , prt 0 id , doc (showString ")")])
ParDefAbs id -> prPrec i 0 (concatD [prt 0 id])

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

@@ -96,9 +96,14 @@ transModDef x = case x of
GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' [] [] [] NT))
MWith m opens -> do
m' <- transIdent m
opens' <- mapM transOpen opens
return (id', GM.ModWith mtyp' mstat' m' opens')
m' <- transIdent m
opens' <- mapM transOpen opens
return (id', GM.ModWith mtyp' mstat' m' [] opens')
MWithE extends m opens -> do
extends' <- mapM transIdent extends
m' <- transIdent m
opens' <- mapM transOpen opens
return (id', GM.ModWith mtyp' mstat' m' extends' opens')
where
mkModRes id mtyp body = do
id' <- transIdent id
@@ -159,7 +164,7 @@ transExtend x = case x of
transOpens :: Opens -> Err [GM.OpenSpec Ident]
transOpens x = case x of
NoOpens -> return []
Opens opens -> mapM transOpen opens
OpenIn opens -> mapM transOpen opens
transOpen :: Open -> Err (GM.OpenSpec Ident)
transOpen x = case x of
@@ -257,7 +262,7 @@ transResDef x = case x of
transParDef :: ParDef -> Err (Ident, [G.Param])
transParDef x = case x of
ParDef id params -> liftM2 (,) (transIdent id) (mapM transParConstr params)
ParDefDir id params -> liftM2 (,) (transIdent id) (mapM transParConstr params)
ParDefAbs id -> liftM2 (,) (transIdent id) (return [])
_ -> Bad $ "illegal definition in resource:" ++++ printTree x
@@ -549,12 +554,12 @@ transOldGrammar opts name0 x = case x of
DefPrintOld printdefs -> (a,r,d:c,ps)
DefPackage m ds -> (a,r,c,(m,ds):ps)
_ -> (a,r,c,ps)
mkAbs a = MModule q (MTAbstract absName) (MBody ne (Opens []) (topDefs a))
mkRes ps r = MModule q (MTResource resName) (MBody ne (Opens ops) (topDefs r))
mkAbs a = MModule q (MTAbstract absName) (MBody ne (OpenIn []) (topDefs a))
mkRes ps r = MModule q (MTResource resName) (MBody ne (OpenIn ops) (topDefs r))
where ops = map OName ps
mkCnc ps r = MModule q (MTConcrete cncName absName)
(MBody ne (Opens (map OName (resName:ps))) (topDefs r))
mkPack (m, ds) = MModule q (MTResource m) (MBody ne (Opens []) (topDefs ds))
(MBody ne (OpenIn (map OName (resName:ps))) (topDefs r))
mkPack (m, ds) = MModule q (MTResource m) (MBody ne (OpenIn []) (topDefs ds))
topDefs t = t
ne = NoExt
q = CMCompl