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

restructured some of the new GF format; modules now in place up to gfo generation

Browse Source
This commit is contained in:
aarne
2007-12-07 20:47:58 +00:00
parent 8437e6d295
commit d9521d2f4c
23 changed files with 403 additions and 427 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
src/GF/Devel/CheckM.hs
View File

@@ -20,8 +20,7 @@ module GF.Devel.CheckM (Check,
) where ) where
import GF.Data.Operations import GF.Data.Operations
import GF.Devel.Grammar.Modules import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Terms
import GF.Infra.Ident import GF.Infra.Ident
import GF.Devel.Grammar.PrGF import GF.Devel.Grammar.PrGF

20
src/GF/Devel/Compile/CheckGrammar.hs
View File

@@ -29,10 +29,8 @@ module GF.Devel.Compile.CheckGrammar (
topoSortOpers topoSortOpers
) where ) where
import GF.Devel.Grammar.Modules import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Judgements import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.MkJudgements
import GF.Devel.Grammar.Macros import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.PrGF import GF.Devel.Grammar.PrGF
import GF.Devel.Grammar.Lookup import GF.Devel.Grammar.Lookup
@@ -187,19 +185,19 @@ checkCompleteGrammar abs cnc = do
js' <- foldM checkOne js fs js' <- foldM checkOne js fs
return $ cnc {mjments = js'} return $ cnc {mjments = js'}
where where
checkOne js i@(c, Left ju) = case jform ju of checkOne js i@(c, ju) = case jform ju of
JFun -> case Map.lookup c js of JFun -> case Map.lookup c js of
Just (Left j) | jform j == JLin -> return js Just j | jform j == JLin -> return js
_ -> do _ -> do
checkWarn $ "WARNING: no linearization of" +++ prt c checkWarn $ "WARNING: no linearization of" +++ prt c
return js return js
JCat -> case Map.lookup c js of JCat -> case Map.lookup c js of
Just (Left j) | jform ju == JLincat -> return js Just j | jform ju == JLincat -> return js
_ -> do ---- TODO: other things to check here _ -> do ---- TODO: other things to check here
checkWarn $ checkWarn $
"Warning: no linearization type for" +++ prt c ++ "Warning: no linearization type for" +++ prt c ++
", inserting default {s : Str}" ", inserting default {s : Str}"
return $ Map.insert c (Left (cncCat defLinType)) js return $ Map.insert c (cncCat defLinType) js
_ -> return js _ -> return js
checkResInfo :: GF -> Ident -> Ident -> Judgement -> Check Judgement checkResInfo :: GF -> Ident -> Ident -> Judgement -> Check Judgement
@@ -1055,12 +1053,12 @@ linTypeOfType cnc m typ = do
-- | dependency check, detecting circularities and returning topo-sorted list -- | dependency check, detecting circularities and returning topo-sorted list
allOperDependencies :: Ident -> Map.Map Ident JEntry -> [(Ident,[Ident])] allOperDependencies :: Ident -> Map.Map Ident Judgement -> [(Ident,[Ident])]
allOperDependencies m = allDependencies (==m) allOperDependencies m = allDependencies (==m)
allDependencies :: (Ident -> Bool) -> Map.Map Ident JEntry -> [(Ident,[Ident])] allDependencies :: (Ident -> Bool) -> Map.Map Ident Judgement -> [(Ident,[Ident])]
allDependencies ism b = allDependencies ism b =
[(f, nub (concatMap opersIn (pts i))) | (f,Left i) <- Map.assocs b] [(f, nub (concatMap opersIn (pts i))) | (f,i) <- Map.assocs b]
where where
opersIn t = case t of opersIn t = case t of
Q n c | ism n -> [c] Q n c | ism n -> [c]

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

@@ -9,9 +9,8 @@ import GF.Devel.Compile.Refresh
import GF.Devel.Compile.Optimize import GF.Devel.Compile.Optimize
import GF.Devel.Compile.Factorize import GF.Devel.Compile.Factorize
import GF.Devel.Grammar.Terms import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Modules import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Judgements
import GF.Infra.Ident import GF.Infra.Ident
import GF.Devel.Grammar.PrGF import GF.Devel.Grammar.PrGF
----import GF.Devel.Grammar.Lookup ----import GF.Devel.Grammar.Lookup

28
src/GF/Devel/Compile/Extend.hs
View File

@@ -20,9 +20,8 @@ module GF.Devel.Compile.Extend (
extendModule extendModule
) where ) where
import GF.Devel.Grammar.Modules import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Judgements import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.MkJudgements
import GF.Devel.Grammar.PrGF import GF.Devel.Grammar.PrGF
import GF.Devel.Grammar.Lookup import GF.Devel.Grammar.Lookup
import GF.Devel.Grammar.Macros import GF.Devel.Grammar.Macros
@@ -71,28 +70,23 @@ extendModule gf nmo0 = do
-- and the process is interrupted if unification fails. -- and the process is interrupted if unification fails.
-- If the extended module is incomplete, its judgements are just copied. -- If the extended module is incomplete, its judgements are just copied.
extendMod :: Bool -> Ident -> (Ident -> Bool) -> Ident -> extendMod :: Bool -> Ident -> (Ident -> Bool) -> Ident ->
MapJudgement -> MapJudgement -> Err MapJudgement Map Ident Judgement -> Map Ident Judgement ->
Err (Map Ident Judgement)
extendMod isCompl name cond base old new = foldM try new $ assocs old where extendMod isCompl name cond base old new = foldM try new $ assocs old where
try t i@(c,_) | not (cond c) = return t try t i@(c,_) | not (cond c) = return t
try t i@(c,_) = errIn ("constant" +++ prt c) $ try t i@(c,_) = errIn ("constant" +++ prt c) $
tryInsert (extendAnyInfo isCompl name base) indirIf t i tryInsert (extendAnyInfo isCompl name base) indirIf t i
indirIf = if isCompl then indirInfo name else id indirIf = if isCompl then indirInfo name else id
indirInfo :: Ident -> JEntry -> JEntry indirInfo :: Ident -> Judgement -> Judgement
indirInfo n info = Right $ case info of indirInfo n ju = case jform ju of
Right (k,b) -> (k,b) -- original link is passed JLink -> ju -- original link is passed
Left j -> (n,isConstructor j) _ -> linkInherited (isConstructor ju) n
extendAnyInfo :: Bool -> Ident -> Ident -> JEntry -> JEntry -> Err JEntry extendAnyInfo :: Bool -> Ident -> Ident -> Judgement -> Judgement -> Err Judgement
extendAnyInfo isc n o i j = extendAnyInfo isc n o i j =
errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $ case (i,j) of errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $
(Left j1,Left j2) -> liftM Left $ unifyJudgement j1 j2 unifyJudgement i j
(Right (m1,b1), Right (m2,b2)) -> do
testErr (b1 == b2) "inconsistent indirection status"
testErr (m1 == m2) $
"different sources of inheritance:" +++ show m1 +++ show m2
return i
_ -> Bad $ "cannot unify information in" ++++ prJEntry i ++++ prJEntry j
tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) -> tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) ->
Map a b -> (a,b) -> Err (Map a b) Map a b -> (a,b) -> Err (Map a b)

62
src/GF/Devel/Compile/Factorize.hs
View File

@@ -24,10 +24,8 @@ module GF.Devel.Compile.Factorize (
shareModule shareModule
) where ) where
import GF.Devel.Grammar.Modules import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Judgements import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.MkJudgements
import GF.Devel.Grammar.PrGF (prt) import GF.Devel.Grammar.PrGF (prt)
import qualified GF.Devel.Grammar.Macros as C import qualified GF.Devel.Grammar.Macros as C
@@ -53,10 +51,11 @@ unshareModule :: GF -> SourceModule -> SourceModule
unshareModule gr = processModule (const (unoptim gr)) unshareModule gr = processModule (const (unoptim gr))
processModule :: (Ident -> Term -> Term) -> SourceModule -> SourceModule processModule :: (Ident -> Term -> Term) -> SourceModule -> SourceModule
processModule opt (i,m) = (i, C.judgementOpModule (shareInfo (opt i)) m) processModule opt (i,mo) =
(i, mo {mjments = Map.map (shareInfo (opt i)) (mjments mo)})
shareInfo :: (Term -> Term) -> Judgement -> Err Judgement shareInfo :: (Term -> Term) -> Judgement -> Judgement
shareInfo opt ju = return $ ju {jdef = opt (jdef ju)} shareInfo opt ju = ju {jdef = opt (jdef ju)}
-- the function putting together optimizations -- the function putting together optimizations
optim :: Ident -> Term -> Term optim :: Ident -> Term -> Term
@@ -169,34 +168,25 @@ cse is possible in the grammar. It is used by the flag pg -printer=subs.
-} -}
subexpModule :: SourceModule -> SourceModule subexpModule :: SourceModule -> SourceModule
subexpModule (mo,m) = errVal (mo,m) $ case m of subexpModule (m,mo) = errVal (m,mo) $ case mtype mo of
M.ModMod (M.Module mt st fs me ops js) -> do MTAbstract -> return (m,mo)
(tree,_) <- appSTM (getSubtermsMod mo (tree2list js)) (Map.empty,0) _ -> do
js2 <- liftM buildTree $ addSubexpConsts mo tree $ tree2list js let js = listJudgements mo
return (mo,M.ModMod (M.Module mt st fs me ops js2)) (tree,_) <- appSTM (getSubtermsMod m js) (Map.empty,0)
_ -> return (mo,m) js2 <- addSubexpConsts m tree js
return (m, mo{mjments = Map.fromList js2})
unsubexpModule :: SourceModule -> SourceModule unsubexpModule :: SourceModule -> SourceModule
unsubexpModule mo@(i,m) = case m of unsubexpModule (m,mo) = (m, mo{mjments = rebuild (mjments mo)})
M.ModMod (M.Module mt st fs me ops js) | hasSub ljs ->
(i, M.ModMod (M.Module mt st fs me ops
(rebuild (map unparInfo ljs))))
where ljs = tree2list js
_ -> (i,m)
where where
-- perform this iff the module has opers unparInfo (c, ju) = case jtype ju of
hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs] EInt 8 -> [] -- subexp-generated opers
unparInfo (c,info) = case info of _ -> [(c, ju {jdef = unparTerm (jdef ju)})]
CncFun xs (Yes t) m -> [(c, CncFun xs (Yes (unparTerm t)) m)]
ResOper (Yes (EInt 8)) _ -> [] -- subexp-generated opers
ResOper pty (Yes t) -> [(c, ResOper pty (Yes (unparTerm t)))]
_ -> [(c,info)]
unparTerm t = case t of unparTerm t = case t of
Q m c@(IC ('A':'\'':'\'':_)) -> --- name convention of subexp opers Q _ c@(IC ('_':'A':_)) -> --- name convention of subexp opers
errVal t $ liftM unparTerm $ lookupResDef gr m c maybe t (unparTerm . jdef) $ Map.lookup c (mjments mo)
_ -> C.composSafeOp unparTerm t _ -> C.composSafeOp unparTerm t
gr = M.MGrammar [mo] rebuild = Map.fromList . concat . map unparInfo . Map.assocs
rebuild = buildTree . concat
-- implementation -- implementation
@@ -204,20 +194,20 @@ type TermList = Map Term (Int,Int) -- number of occs, id
type TermM a = STM (TermList,Int) a type TermM a = STM (TermList,Int) a
addSubexpConsts :: addSubexpConsts ::
Ident -> Map Term (Int,Int) -> [(Ident,Info)] -> Err [(Ident,Info)] Ident -> Map Term (Int,Int) -> [(Ident,Judgement)] -> Err [(Ident,Judgement)]
addSubexpConsts mo tree lins = do addSubexpConsts mo tree lins = do
let opers = [oper id trm | (trm,(_,id)) <- list] let opers = [oper id trm | (trm,(_,id)) <- list]
mapM mkOne $ opers ++ lins mapM mkOne $ opers ++ lins
where where
mkOne (f,def) = (f,def {jdef = recomp f (jdef def)}) mkOne (f, def) = return (f, def {jdef = recomp f (jdef def)})
recomp f t = case Map.lookup t tree of recomp f t = case Map.lookup t tree of
Just (_,id) | ident id /= f -> return $ Q mo (ident id) Just (_,id) | ident id /= f -> Q mo (ident id)
_ -> C.composOp (recomp f) t _ -> C.composSafeOp (recomp f) t
list = Map.toList tree list = Map.toList tree
oper id trm = (ident id, resOper (EInt 8) (Yes trm)) oper id trm = (ident id, resOper (EInt 8) trm)
--- impossible type encoding generated opers --- impossible type encoding generated opers
getSubtermsMod :: Ident -> [(Ident,Judgement)] -> TermM (Map Term (Int,Int)) getSubtermsMod :: Ident -> [(Ident,Judgement)] -> TermM (Map Term (Int,Int))
@@ -226,7 +216,7 @@ getSubtermsMod mo js = do
(tree0,_) <- readSTM (tree0,_) <- readSTM
return $ Map.filter (\ (nu,_) -> nu > 1) tree0 return $ Map.filter (\ (nu,_) -> nu > 1) tree0
where where
getInfo get fi@(f,i) = do getInfo get fi@(_,i) = do
get (jdef i) get (jdef i)
return $ fi return $ fi

0
src/GF/Devel/Grammar/GF.cf → src/GF/Devel/Compile/GF.cf
View File

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

@@ -15,17 +15,18 @@
module GF.Devel.Compile.GetGrammar where module GF.Devel.Compile.GetGrammar where
import GF.Devel.UseIO import GF.Devel.UseIO
import GF.Devel.Grammar.Modules import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
----import GF.Devel.PrGrammar ----import GF.Devel.PrGrammar
import GF.Devel.Grammar.SourceToGF import GF.Devel.Compile.SourceToGF
---- import Macros ---- import Macros
---- import Rename ---- import Rename
--- import Custom --- import Custom
import GF.Devel.Grammar.ParGF import GF.Devel.Compile.ParGF
import qualified GF.Devel.Grammar.LexGF as L import qualified GF.Devel.Compile.LexGF as L
import GF.Data.Operations import GF.Data.Operations
import qualified GF.Devel.Grammar.ErrM as E ---- import qualified GF.Devel.Compile.ErrM as E ----
import GF.Infra.Option ---- import GF.Infra.Option ----
import GF.Devel.ReadFiles ---- import GF.Devel.ReadFiles ----

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

@@ -14,9 +14,8 @@
module GF.Devel.Compile.Optimize (optimizeModule) where module GF.Devel.Compile.Optimize (optimizeModule) where
import GF.Devel.Grammar.Modules import GF.Devel.Grammar.Grammar
--import GF.Devel.Grammar.Judgements import GF.Devel.Grammar.Construct
--import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.Macros import GF.Devel.Grammar.Macros
--import GF.Devel.Grammar.PrGF --import GF.Devel.Grammar.PrGF
import GF.Devel.Grammar.Compute import GF.Devel.Grammar.Compute

4
src/GF/Devel/Compile/Refresh.hs
View File

@@ -18,8 +18,8 @@ module GF.Devel.Compile.Refresh (
refreshTermN refreshTermN
) where ) where
import GF.Devel.Grammar.Modules import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Terms import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Macros import GF.Devel.Grammar.Macros
import GF.Infra.Ident import GF.Infra.Ident

16
src/GF/Devel/Compile/Rename.hs
View File

@@ -24,9 +24,8 @@ module GF.Devel.Compile.Rename (
renameModule renameModule
) where ) where
import GF.Devel.Grammar.Modules import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Judgements import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.Macros import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.PrGF import GF.Devel.Grammar.PrGF
import GF.Infra.Ident import GF.Infra.Ident
@@ -61,7 +60,8 @@ renameIdentTerm :: RenameEnv -> Term -> Err Term
renameIdentTerm (gf, (name,mo)) trm = case trm of renameIdentTerm (gf, (name,mo)) trm = case trm of
Vr i -> looks i Vr i -> looks i
Con i -> looks i Con i -> looks i
Q m i -> getQualified m >>= look i Q m i -> getQualified m >>= look i
QC m i -> getQualified m >>= look i
_ -> return trm _ -> return trm
where where
looks i = do looks i = do
@@ -76,10 +76,10 @@ renameIdentTerm (gf, (name,mo)) trm = case trm of
(return t) (return t)
---- _ -> fail $ unwords $ "identifier" : prt i : "ambiguous:" : map prt ts ---- _ -> fail $ unwords $ "identifier" : prt i : "ambiguous:" : map prt ts
look i m = do look i m = do
entry <- lookupIdent gf m i ju <- lookupIdent gf m i
return $ case entry of return $ case jform ju of
Left j -> if isConstructor j then QC m i else Q m i JLink -> if isConstructor ju then QC (jlink ju) i else Q (jlink ju) i
Right (n,b) -> if b then QC n i else Q n i _ -> if isConstructor ju then QC m i else Q m i
pool = nub $ name : pool = nub $ name :
maybe name id (interfaceName mo) : maybe name id (interfaceName mo) :
IC "Predef" : IC "Predef" :

69
src/GF/Devel/Grammar/SourceToGF.hs → src/GF/Devel/Compile/SourceToGF.hs
View File

@@ -12,7 +12,7 @@
-- based on the skeleton Haskell module generated by the BNF converter -- based on the skeleton Haskell module generated by the BNF converter
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Devel.Grammar.SourceToGF ( module GF.Devel.Compile.SourceToGF (
transGrammar, transGrammar,
transModDef, transModDef,
transExp, transExp,
@@ -21,18 +21,15 @@ module GF.Devel.Grammar.SourceToGF (
newReservedWords newReservedWords
) where ) where
import qualified GF.Devel.Grammar.Terms as G import qualified GF.Devel.Grammar.Grammar as G
----import qualified GF.Grammar.PrGrammar as GP import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Judgements
import GF.Devel.Grammar.MkJudgements
import GF.Devel.Grammar.Modules
import qualified GF.Devel.Grammar.Macros as M import qualified GF.Devel.Grammar.Macros as M
----import qualified GF.Compile.Update as U ----import qualified GF.Compile.Update as U
--import qualified GF.Infra.Option as GO --import qualified GF.Infra.Option as GO
--import qualified GF.Compile.ModDeps as GD --import qualified GF.Compile.ModDeps as GD
import GF.Infra.Ident import GF.Infra.Ident
import GF.Devel.Grammar.AbsGF import GF.Devel.Compile.AbsGF
import GF.Devel.Grammar.PrintGF (printTree) import GF.Devel.Compile.PrintGF (printTree)
----import GF.Source.PrintGF ----import GF.Source.PrintGF
----import GF.Compile.RemoveLiT --- for bw compat ----import GF.Compile.RemoveLiT --- for bw compat
import GF.Data.Operations import GF.Data.Operations
@@ -64,14 +61,14 @@ transName n = case n of
PIdentName i -> transIdent i PIdentName i -> transIdent i
ListName i -> transIdent (mkListId i) ListName i -> transIdent (mkListId i)
transGrammar :: Grammar -> Err GF transGrammar :: Grammar -> Err G.GF
transGrammar x = case x of transGrammar x = case x of
Gr moddefs -> do Gr moddefs -> do
moddefs' <- mapM transModDef moddefs moddefs' <- mapM transModDef moddefs
let mos = Map.fromList moddefs' let mos = Map.fromList moddefs'
return $ emptyGF {gfmodules = mos} return $ emptyGF {G.gfmodules = mos}
transModDef :: ModDef -> Err (Ident,Module) transModDef :: ModDef -> Err (Ident, G.Module)
transModDef x = case x of transModDef x = case x of
MModule compl mtyp body -> do MModule compl mtyp body -> do
@@ -80,17 +77,17 @@ transModDef x = case x of
(trDef, mtyp', id') <- case mtyp of (trDef, mtyp', id') <- case mtyp of
MAbstract id -> do MAbstract id -> do
id' <- transIdent id id' <- transIdent id
return (transAbsDef, MTAbstract, id') return (transAbsDef, G.MTAbstract, id')
MGrammar id -> mkModRes id MTGrammar body MGrammar id -> mkModRes id G.MTGrammar body
MResource id -> mkModRes id MTGrammar body MResource id -> mkModRes id G.MTGrammar body
MConcrete id open -> do MConcrete id open -> do
id' <- transIdent id id' <- transIdent id
open' <- transIdent open open' <- transIdent open
return (transCncDef, MTConcrete open', id') return (transCncDef, G.MTConcrete open', id')
MInterface id -> mkModRes id MTInterface body MInterface id -> mkModRes id G.MTInterface body
MInstance id open -> do MInstance id open -> do
open' <- transIdent open open' <- transIdent open
mkModRes id (MTInstance open') body mkModRes id (G.MTInstance open') body
mkBody (isCompl, trDef, mtyp', id') body mkBody (isCompl, trDef, mtyp', id') body
where where
@@ -102,9 +99,9 @@ transModDef x = case x of
opens' <- transOpens opens opens' <- transOpens opens
defs0 <- mapM trDef $ getTopDefs defs defs0 <- mapM trDef $ getTopDefs defs
let defs' = Map.fromListWith unifyJudgements let defs' = Map.fromListWith unifyJudgements
[(i,Left d) | Left ds <- defs0, (i,d) <- ds] [(i,d) | Left ds <- defs0, (i,d) <- ds]
let flags' = Map.fromList [f | Right fs <- defs0, f <- fs] let flags' = Map.fromList [f | Right fs <- defs0, f <- fs]
return (id', Module mtyp' isc [] [] extends' opens' flags' defs') return (id', G.Module mtyp' isc [] [] extends' opens' flags' defs')
MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens [] MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens []
MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs
@@ -116,9 +113,9 @@ transModDef x = case x of
opens' <- transOpens opens opens' <- transOpens opens
defs0 <- mapM trDef $ getTopDefs defs defs0 <- mapM trDef $ getTopDefs defs
let defs' = Map.fromListWith unifyJudgements let defs' = Map.fromListWith unifyJudgements
[(i,Left d) | Left ds <- defs0, (i,d) <- ds] [(i,d) | Left ds <- defs0, (i,d) <- ds]
let flags' = Map.fromList [f | Right fs <- defs0, f <- fs] let flags' = Map.fromList [f | Right fs <- defs0, f <- fs]
return (id', Module mtyp' isc [] [(m',insts')] extends' opens' flags' defs') return (id', G.Module mtyp' isc [] [(m',insts')] extends' opens' flags' defs')
_ -> fail "deprecated module form" _ -> fail "deprecated module form"
@@ -135,7 +132,7 @@ transComplMod x = case x of
CMCompl -> True CMCompl -> True
CMIncompl -> False CMIncompl -> False
transExtend :: Extend -> Err [(Ident,MInclude)] transExtend :: Extend -> Err [(Ident,G.MInclude)]
transExtend x = case x of transExtend x = case x of
Ext ids -> mapM transIncludedExt ids Ext ids -> mapM transIncludedExt ids
NoExt -> return [] NoExt -> return []
@@ -150,13 +147,13 @@ transOpen x = case x of
OName id -> transIdent id >>= \y -> return (y,y) OName id -> transIdent id >>= \y -> return (y,y)
OQual id m -> liftM2 (,) (transIdent id) (transIdent m) OQual id m -> liftM2 (,) (transIdent id) (transIdent m)
transIncludedExt :: Included -> Err (Ident, MInclude) transIncludedExt :: Included -> Err (Ident, G.MInclude)
transIncludedExt x = case x of transIncludedExt x = case x of
IAll i -> liftM2 (,) (transIdent i) (return MIAll) IAll i -> liftM2 (,) (transIdent i) (return G.MIAll)
ISome i ids -> liftM2 (,) (transIdent i) (liftM MIOnly $ mapM transIdent ids) ISome i ids -> liftM2 (,) (transIdent i) (liftM G.MIOnly $ mapM transIdent ids)
IMinus i ids -> liftM2 (,) (transIdent i) (liftM MIExcept $ mapM transIdent ids) IMinus i ids -> liftM2 (,) (transIdent i) (liftM G.MIExcept $ mapM transIdent ids)
transAbsDef :: TopDef -> Err (Either [(Ident,Judgement)] [(Ident,String)]) transAbsDef :: TopDef -> Err (Either [(Ident,G.Judgement)] [(Ident,String)])
transAbsDef x = case x of transAbsDef x = case x of
DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs
DefFun fundefs -> do DefFun fundefs -> do
@@ -209,7 +206,7 @@ transFlagDef x = case x of
-- | Cat definitions can also return some fun defs -- | Cat definitions can also return some fun defs
-- if it is a list category definition -- if it is a list category definition
transCatDef :: CatDef -> Err [(Ident, Judgement)] transCatDef :: CatDef -> Err [(Ident, G.Judgement)]
transCatDef x = case x of transCatDef x = case x of
SimpleCatDef id ddecls -> liftM (:[]) $ cat id ddecls SimpleCatDef id ddecls -> liftM (:[]) $ cat id ddecls
ListCatDef id ddecls -> listCat id ddecls 0 ListCatDef id ddecls -> listCat id ddecls 0
@@ -233,9 +230,9 @@ transCatDef x = case x of
xs = map (G.Vr . fst) cont xs = map (G.Vr . fst) cont
cd = M.mkDecl (M.mkApp (G.Vr id') xs) cd = M.mkDecl (M.mkApp (G.Vr id') xs)
lc = M.mkApp (G.Vr li') xs lc = M.mkApp (G.Vr li') xs
niltyp = M.mkProd (cont ++ genericReplicate size cd) lc niltyp = mkProd (cont ++ genericReplicate size cd) lc
nilfund = (baseId, absFun niltyp) ---- (yes niltyp) (yes G.EData)) nilfund = (baseId, absFun niltyp) ---- (yes niltyp) (yes G.EData))
constyp = M.mkProd (cont ++ [cd, M.mkDecl lc]) lc constyp = mkProd (cont ++ [cd, M.mkDecl lc]) lc
consfund = (consId, absFun constyp) ---- (yes constyp) (yes G.EData)) consfund = (consId, absFun constyp) ---- (yes constyp) (yes G.EData))
return [catd,nilfund,consfund] return [catd,nilfund,consfund]
mkId x i = if isWildIdent x then (mkIdent "x" i) else x mkId x i = if isWildIdent x then (mkIdent "x" i) else x
@@ -254,7 +251,7 @@ transDataDef x = case x of
DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id) DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id)
-} -}
transResDef :: TopDef -> Err (Either [(Ident,Judgement)] [(Ident,String)]) transResDef :: TopDef -> Err (Either [(Ident,G.Judgement)] [(Ident,String)])
transResDef x = case x of transResDef x = case x of
DefPar pardefs -> do DefPar pardefs -> do
pardefs' <- mapM transParDef pardefs pardefs' <- mapM transParDef pardefs
@@ -274,10 +271,10 @@ transResDef x = case x of
mkParamDefs (p,pars) = mkParamDefs (p,pars) =
if null pars if null pars
then [(p,addJType M.meta0 (emptyJudgement JParam))] -- in an interface then [(p,addJType M.meta0 (emptyJudgement G.JParam))] -- in an interface
else (p,resParam pars) : paramConstructors p pars else (p,resParam pars) : paramConstructors p pars
mkOverload (c,j) = case (jtype j, jdef j) of mkOverload (c,j) = case (G.jtype j, G.jdef j) of
(_,G.App keyw (G.R fs@(_:_:_))) | isOverloading keyw c fs -> (_,G.App keyw (G.R fs@(_:_:_))) | isOverloading keyw c fs ->
[(c,resOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])] [(c,resOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])]
@@ -293,7 +290,7 @@ transParDef x = case x of
ParDefDir id params -> liftM2 (,) (transIdent id) (mapM transParConstr params) ParDefDir id params -> liftM2 (,) (transIdent id) (mapM transParConstr params)
ParDefAbs id -> liftM2 (,) (transIdent id) (return []) ParDefAbs id -> liftM2 (,) (transIdent id) (return [])
transCncDef :: TopDef -> Err (Either [(Ident,Judgement)] [(Ident,String)]) transCncDef :: TopDef -> Err (Either [(Ident,G.Judgement)] [(Ident,String)])
transCncDef x = case x of transCncDef x = case x of
DefLincat defs -> do DefLincat defs -> do
defs' <- liftM concat $ mapM transPrintDef defs defs' <- liftM concat $ mapM transPrintDef defs
@@ -425,7 +422,7 @@ transExp x = case x of
ETyped exp0 exp -> liftM2 G.Typed (transExp exp0) (transExp exp) ETyped exp0 exp -> liftM2 G.Typed (transExp exp0) (transExp exp)
EExample exp str -> liftM2 G.Example (transExp exp) (return str) EExample exp str -> liftM2 G.Example (transExp exp) (return str)
EProd decl exp -> liftM2 M.mkProd (transDecl decl) (transExp exp) EProd decl exp -> liftM2 mkProd (transDecl decl) (transExp exp)
ETType exp0 exp -> liftM2 G.Table (transExp exp0) (transExp exp) ETType exp0 exp -> liftM2 G.Table (transExp exp0) (transExp exp)
EConcat exp0 exp -> liftM2 G.C (transExp exp0) (transExp exp) EConcat exp0 exp -> liftM2 G.C (transExp exp0) (transExp exp)
EGlue exp0 exp -> liftM2 G.Glue (transExp exp0) (transExp exp) EGlue exp0 exp -> liftM2 G.Glue (transExp exp0) (transExp exp)
@@ -506,7 +503,7 @@ transSort x = case x of
transPatt :: Patt -> Err G.Patt transPatt :: Patt -> Err G.Patt
transPatt x = case x of transPatt x = case x of
PW -> return G.wildPatt PW -> return wildPatt
PV id -> liftM G.PV $ transIdent id PV id -> liftM G.PV $ transIdent id
PC id patts -> liftM2 G.PC (transIdent id) (mapM transPatt patts) PC id patts -> liftM2 G.PC (transIdent id) (mapM transPatt patts)
PCon id -> liftM2 G.PC (transIdent id) (return []) PCon id -> liftM2 G.PC (transIdent id) (return [])

3
src/GF/Devel/Grammar/AppPredefined.hs
View File

@@ -18,7 +18,8 @@ module GF.Devel.Grammar.AppPredefined (
appPredefined appPredefined
) where ) where
import GF.Devel.Grammar.Terms import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Macros import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.PrGF (prt,prt_,prtBad) import GF.Devel.Grammar.PrGF (prt,prt_,prtBad)
import GF.Infra.Ident import GF.Infra.Ident

4
src/GF/Devel/Grammar/Compute.hs
View File

@@ -18,8 +18,8 @@ module GF.Devel.Grammar.Compute (
computeTermRec computeTermRec
) where ) where
import GF.Devel.Grammar.Modules import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Terms import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Macros import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.Lookup import GF.Devel.Grammar.Lookup
import GF.Devel.Grammar.PrGF import GF.Devel.Grammar.PrGF

216
src/GF/Devel/Grammar/Construct.hs Normal file
View File

@@ -0,0 +1,216 @@
module GF.Devel.Grammar.Construct where
import GF.Devel.Grammar.Grammar
import GF.Infra.Ident
import GF.Data.Operations
import Control.Monad
import Data.Map
import Debug.Trace (trace)
------------------
-- abstractions on Grammar
------------------
-- abstractions on GF
emptyGF :: GF
emptyGF = GF Nothing [] empty empty
type SourceModule = (Ident,Module)
listModules :: GF -> [SourceModule]
listModules = assocs.gfmodules
addModule :: Ident -> Module -> GF -> GF
addModule c m gf = gf {gfmodules = insert c m (gfmodules gf)}
-- abstractions on Module
emptyModule :: Ident -> Module
emptyModule m = Module MTGrammar True [] [] [] [] empty empty
isCompleteModule :: Module -> Bool
isCompleteModule = miscomplete
isInterface :: Module -> Bool
isInterface m = case mtype m of
MTInterface -> True
MTAbstract -> True
_ -> False
interfaceName :: Module -> Maybe Ident
interfaceName mo = case mtype mo of
MTInstance i -> return i
MTConcrete i -> return i
_ -> Nothing
listJudgements :: Module -> [(Ident,Judgement)]
listJudgements = assocs . mjments
isInherited :: MInclude -> Ident -> Bool
isInherited mi i = case mi of
MIExcept is -> notElem i is
MIOnly is -> elem i is
_ -> True
-- abstractions on Judgement
isConstructor :: Judgement -> Bool
isConstructor j = jdef j == EData
isLink :: Judgement -> Bool
isLink j = jform j == JLink
-- constructing judgements from parse tree
emptyJudgement :: JudgementForm -> Judgement
emptyJudgement form = Judgement form meta meta meta (identC "#NOLINK") 0 where
meta = Meta 0
addJType :: Type -> Judgement -> Judgement
addJType tr ju = ju {jtype = tr}
addJDef :: Term -> Judgement -> Judgement
addJDef tr ju = ju {jdef = tr}
addJPrintname :: Term -> Judgement -> Judgement
addJPrintname tr ju = ju {jprintname = tr}
linkInherited :: Bool -> Ident -> Judgement
linkInherited can mo = (emptyJudgement JLink){
jlink = mo,
jdef = if can then EData else Meta 0
}
absCat :: Context -> Judgement
absCat co = addJType (mkProd co typeType) (emptyJudgement JCat)
absFun :: Type -> Judgement
absFun ty = addJType ty (emptyJudgement JFun)
cncCat :: Type -> Judgement
cncCat ty = addJType ty (emptyJudgement JLincat)
cncFun :: Term -> Judgement
cncFun tr = addJDef tr (emptyJudgement JLin)
resOperType :: Type -> Judgement
resOperType ty = addJType ty (emptyJudgement JOper)
resOperDef :: Term -> Judgement
resOperDef tr = addJDef tr (emptyJudgement JOper)
resOper :: Type -> Term -> Judgement
resOper ty tr = addJDef tr (resOperType ty)
resOverload :: [(Type,Term)] -> Judgement
resOverload tts = resOperDef (Overload tts)
-- param p = ci gi is encoded as p : ((ci : gi) -> EData) -> Type
-- we use EData instead of p to make circularity check easier
resParam :: [(Ident,Context)] -> Judgement
resParam cos = addJType constrs (emptyJudgement JParam) where
constrs = mkProd [(c,mkProd co EData) | (c,co) <- cos] typeType
-- to enable constructor type lookup:
-- create an oper for each constructor p = c g, as c : g -> p = EData
paramConstructors :: Ident -> [(Ident,Context)] -> [(Ident,Judgement)]
paramConstructors p cs =
[(c,resOper (mkProd co (Con p)) EData) | (c,co) <- cs]
-- unifying contents of judgements
---- used in SourceToGF; make error-free and informative
unifyJudgements j k = case unifyJudgement j k of
Ok l -> l
Bad s -> error s
unifyJudgement :: Judgement -> Judgement -> Err Judgement
unifyJudgement old new = do
testErr (jform old == jform new) "different judment forms"
[jty,jde,jpri] <- mapM unifyField [jtype,jdef,jprintname]
return $ old{jtype = jty, jdef = jde, jprintname = jpri}
where
unifyField field = unifyTerm (field old) (field new)
unifyTerm oterm nterm = case (oterm,nterm) of
(Meta _,t) -> return t
(t,Meta _) -> return t
_ -> do
if (nterm /= oterm)
then (trace (unwords ["illegal update of",show oterm,"to",show nterm])
(return ()))
else return () ---- to recover from spurious qualification conflicts
---- testErr (nterm == oterm)
---- (unwords ["illegal update of",prt oterm,"to",prt nterm])
return nterm
-- abstractions on Term
type Cat = QIdent
type Fun = QIdent
type QIdent = (Ident,Ident)
-- | branches à la Alfa
newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read)
type Con = Ident ---
varLabel :: Int -> Label
varLabel = LVar
wildPatt :: Patt
wildPatt = PW
type Trm = Term
mkProd :: Context -> Type -> Type
mkProd = flip (foldr (uncurry Prod))
-- type constants
typeType :: Type
typeType = Sort "Type"
typePType :: Type
typePType = Sort "PType"
typeStr :: Type
typeStr = Sort "Str"
typeTok :: Type ---- deprecated
typeTok = Sort "Tok"
cPredef :: Ident
cPredef = identC "Predef"
cPredefAbs :: Ident
cPredefAbs = identC "PredefAbs"
typeString, typeFloat, typeInt :: Term
typeInts :: Integer -> Term
typeString = constPredefRes "String"
typeInt = constPredefRes "Int"
typeFloat = constPredefRes "Float"
typeInts i = App (constPredefRes "Ints") (EInt i)
isTypeInts :: Term -> Bool
isTypeInts ty = case ty of
App c _ -> c == constPredefRes "Ints"
_ -> False
cnPredef = constPredefRes
constPredefRes :: String -> Term
constPredefRes s = Q (IC "Predef") (identC s)
isPredefConstant :: Term -> Bool
isPredefConstant t = case t of
Q (IC "Predef") _ -> True
Q (IC "PredefAbs") _ -> True
_ -> False

10
src/GF/Devel/Grammar/GFtoSource.hs
View File

@@ -9,11 +9,10 @@ module GF.Devel.Grammar.GFtoSource (
) where ) where
import GF.Devel.Grammar.Modules import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Judgements import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.Macros (contextOfType) import GF.Devel.Grammar.Macros (contextOfType)
import qualified GF.Devel.Grammar.AbsGF as P import qualified GF.Devel.Compile.AbsGF as P
import GF.Infra.Ident import GF.Infra.Ident
import GF.Data.Operations import GF.Data.Operations
@@ -43,7 +42,7 @@ trModule (i,mo) = P.MModule compl typ body where
body = P.MBody body = P.MBody
(trExtends (mextends mo)) (trExtends (mextends mo))
(mkOpens (map trOpen (mopens mo))) (mkOpens (map trOpen (mopens mo)))
(concatMap trAnyDef [(c,j) | (c,Left j) <- listJudgements mo] ++ (concatMap trAnyDef [(c,j) | (c,j) <- listJudgements mo] ++
map trFlag (Map.assocs (mflags mo))) map trFlag (Map.assocs (mflags mo)))
trExtends :: [(Ident,MInclude)] -> P.Extend trExtends :: [(Ident,MInclude)] -> P.Extend
@@ -89,6 +88,7 @@ trAnyDef (i,ju) = let
JLin -> JLin ->
[P.DefLin [trDef i (Meta 0) (jdef ju)]] [P.DefLin [trDef i (Meta 0) (jdef ju)]]
---- ++ [P.DefPrintFun [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]] ---- ++ [P.DefPrintFun [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]]
JLink -> []
{- {-
---- encoding of AnyInd without changing syntax. AR 20/9/2007 ---- encoding of AnyInd without changing syntax. AR 20/9/2007
AnyInd s b -> AnyInd s b ->

77
src/GF/Devel/Grammar/Terms.hs → src/GF/Devel/Grammar/Grammar.hs
View File

@@ -1,14 +1,69 @@
module GF.Devel.Grammar.Terms where module GF.Devel.Grammar.Grammar where
import GF.Infra.Ident import GF.Infra.Ident
import GF.Data.Operations import GF.Data.Operations
type Type = Term import Data.Map
type Cat = QIdent
type Fun = QIdent
type QIdent = (Ident,Ident)
------------------
-- definitions --
------------------
data GF = GF {
gfabsname :: Maybe Ident ,
gfcncnames :: [Ident] ,
gflags :: Map Ident String , -- value of a global flag
gfmodules :: Map Ident Module
}
data Module = Module {
mtype :: ModuleType,
miscomplete :: Bool,
minterfaces :: [(Ident,Ident)], -- non-empty for functors
minstances :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for instant'ions
mextends :: [(Ident,MInclude)],
mopens :: [(Ident,Ident)], -- used name, original name
mflags :: Map Ident String,
mjments :: Map Ident Judgement
}
data ModuleType =
MTAbstract
| MTConcrete Ident
| MTInterface
| MTInstance Ident
| MTGrammar
deriving Eq
data MInclude =
MIAll
| MIExcept [Ident]
| MIOnly [Ident]
type Indirection = (Ident,Bool) -- module of origin, whether canonical
data Judgement = Judgement {
jform :: JudgementForm, -- cat fun lincat lin oper param
jtype :: Type, -- context type lincat - type constrs
jdef :: Term, -- lindef def lindef lin def values
jprintname :: Term, -- - - prname prname - -
jlink :: Ident,
jposition :: Int
}
data JudgementForm =
JCat
| JFun
| JLincat
| JLin
| JOper
| JParam
| JLink
deriving Eq
type Type = Term
data Term = data Term =
Vr Ident -- ^ variable Vr Ident -- ^ variable
@@ -104,15 +159,3 @@ type Assign = (Label, (Maybe Type, Term))
type Case = (Patt, Term) type Case = (Patt, Term)
type LocalDef = (Ident, (Maybe Type, Term)) type LocalDef = (Ident, (Maybe Type, Term))
-- | branches à la Alfa
newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read)
type Con = Ident ---
varLabel :: Int -> Label
varLabel = LVar
wildPatt :: Patt
wildPatt = PW
type Trm = Term

21
src/GF/Devel/Grammar/Judgements.hs
View File

@@ -1,21 +0,0 @@
module GF.Devel.Grammar.Judgements where
import GF.Devel.Grammar.Terms
import GF.Infra.Ident
data Judgement = Judgement {
jform :: JudgementForm, -- cat fun lincat lin oper param
jtype :: Type, -- context type lincat - type constrs
jdef :: Term, -- lindef def lindef lin def values
jprintname :: Term -- - - prname prname - -
}
data JudgementForm =
JCat
| JFun
| JLincat
| JLin
| JOper
| JParam
deriving Eq

17
src/GF/Devel/Grammar/Lookup.hs
View File

@@ -1,9 +1,8 @@
module GF.Devel.Grammar.Lookup where module GF.Devel.Grammar.Lookup where
import GF.Devel.Grammar.Modules import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Judgements import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Macros import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.PrGF import GF.Devel.Grammar.PrGF
import GF.Infra.Ident import GF.Infra.Ident
@@ -103,15 +102,19 @@ lookupModule :: GF -> Ident -> Err Module
lookupModule gf m = do lookupModule gf m = do
maybe (raiseIdent "module not found:" m) return $ mlookup m (gfmodules gf) maybe (raiseIdent "module not found:" m) return $ mlookup m (gfmodules gf)
lookupIdent :: GF -> Ident -> Ident -> Err JEntry -- this finds the immediate definition, which can be a link
lookupIdent :: GF -> Ident -> Ident -> Err Judgement
lookupIdent gf m c = do lookupIdent gf m c = do
mo <- lookupModule gf m mo <- lookupModule gf m
maybe (raiseIdent "constant not found" c) return $ mlookup c (mjments mo) maybe (raiseIdent "constant not found:" c) return $ mlookup c (mjments mo)
-- this follows the link
lookupJudgement :: GF -> Ident -> Ident -> Err Judgement lookupJudgement :: GF -> Ident -> Ident -> Err Judgement
lookupJudgement gf m c = do lookupJudgement gf m c = do
eji <- lookupIdent gf m c ju <- lookupIdent gf m c
either return (\n -> lookupJudgement gf (fst n) c) eji case jform ju of
JLink -> lookupJudgement gf (jlink ju) c
_ -> return ju
mlookup = Data.Map.lookup mlookup = Data.Map.lookup

58
src/GF/Devel/Grammar/Macros.hs
View File

@@ -1,8 +1,7 @@
module GF.Devel.Grammar.Macros where module GF.Devel.Grammar.Macros where
import GF.Devel.Grammar.Terms import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Judgements import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Modules
import GF.Infra.Ident import GF.Infra.Ident
import GF.Data.Str import GF.Data.Str
@@ -81,9 +80,6 @@ typeSkeleton typ = do
-- construct types and terms -- construct types and terms
mkProd :: Context -> Type -> Type
mkProd = flip (foldr (uncurry Prod))
mkFunType :: [Type] -> Type -> Type mkFunType :: [Type] -> Type -> Type
mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt]) t -- nondep prod mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt]) t -- nondep prod
@@ -156,49 +152,6 @@ plusRecord t1 t2 =
zipAssign :: [Label] -> [Term] -> [Assign] zipAssign :: [Label] -> [Term] -> [Assign]
zipAssign ls ts = [assign l t | (l,t) <- zip ls ts] zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
-- type constants
typeType :: Type
typeType = Sort "Type"
typePType :: Type
typePType = Sort "PType"
typeStr :: Type
typeStr = Sort "Str"
typeTok :: Type ---- deprecated
typeTok = Sort "Tok"
cPredef :: Ident
cPredef = identC "Predef"
cPredefAbs :: Ident
cPredefAbs = identC "PredefAbs"
typeString, typeFloat, typeInt :: Term
typeInts :: Integer -> Term
typeString = constPredefRes "String"
typeInt = constPredefRes "Int"
typeFloat = constPredefRes "Float"
typeInts i = App (constPredefRes "Ints") (EInt i)
isTypeInts :: Term -> Bool
isTypeInts ty = case ty of
App c _ -> c == constPredefRes "Ints"
_ -> False
cnPredef = constPredefRes
constPredefRes :: String -> Term
constPredefRes s = Q (IC "Predef") (identC s)
isPredefConstant :: Term -> Bool
isPredefConstant t = case t of
Q (IC "Predef") _ -> True
Q (IC "PredefAbs") _ -> True
_ -> False
defLinType :: Type defLinType :: Type
defLinType = RecType [(LIdent "s", typeStr)] defLinType = RecType [(LIdent "s", typeStr)]
@@ -230,10 +183,8 @@ termOpModule f = judgementOpModule fj where
judgementOpModule :: Monad m => (Judgement -> m Judgement) -> Module -> m Module judgementOpModule :: Monad m => (Judgement -> m Judgement) -> Module -> m Module
judgementOpModule f m = do judgementOpModule f m = do
mjs <- mapMapM fj (mjments m) mjs <- mapMapM f (mjments m)
return m {mjments = mjs} return m {mjments = mjs}
where
fj = either (liftM Left . f) (return . Right)
entryOpModule :: Monad m => entryOpModule :: Monad m =>
(Ident -> Judgement -> m Judgement) -> Module -> m Module (Ident -> Judgement -> m Judgement) -> Module -> m Module
@@ -241,8 +192,7 @@ entryOpModule f m = do
mjs <- liftM Map.fromAscList $ mapm $ Map.assocs $ mjments m mjs <- liftM Map.fromAscList $ mapm $ Map.assocs $ mjments m
return $ m {mjments = mjs} return $ m {mjments = mjs}
where where
mapm = mapM (\ (i,j) -> liftM ((,) i) (fe i j)) mapm = mapM (\ (i,j) -> liftM ((,) i) (f i j))
fe i j = either (liftM Left . f i) (return . Right) j
termOpJudgement :: Monad m => (Term -> m Term) -> Judgement -> m Judgement termOpJudgement :: Monad m => (Term -> m Term) -> Judgement -> m Judgement
termOpJudgement f j = do termOpJudgement f j = do

93
src/GF/Devel/Grammar/MkJudgements.hs
View File

@@ -1,93 +0,0 @@
module GF.Devel.Grammar.MkJudgements where
import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.Judgements
import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.PrGF
import GF.Infra.Ident
import GF.Data.Operations
import Control.Monad
import Data.Map
import Debug.Trace (trace) ----
-- constructing judgements from parse tree
emptyJudgement :: JudgementForm -> Judgement
emptyJudgement form = Judgement form meta meta meta where
meta = Meta 0
addJType :: Type -> Judgement -> Judgement
addJType tr ju = ju {jtype = tr}
addJDef :: Term -> Judgement -> Judgement
addJDef tr ju = ju {jdef = tr}
addJPrintname :: Term -> Judgement -> Judgement
addJPrintname tr ju = ju {jprintname = tr}
absCat :: Context -> Judgement
absCat co = addJType (mkProd co typeType) (emptyJudgement JCat)
absFun :: Type -> Judgement
absFun ty = addJType ty (emptyJudgement JFun)
cncCat :: Type -> Judgement
cncCat ty = addJType ty (emptyJudgement JLincat)
cncFun :: Term -> Judgement
cncFun tr = addJDef tr (emptyJudgement JLin)
resOperType :: Type -> Judgement
resOperType ty = addJType ty (emptyJudgement JOper)
resOperDef :: Term -> Judgement
resOperDef tr = addJDef tr (emptyJudgement JOper)
resOper :: Type -> Term -> Judgement
resOper ty tr = addJDef tr (resOperType ty)
resOverload :: [(Type,Term)] -> Judgement
resOverload tts = resOperDef (Overload tts)
-- param p = ci gi is encoded as p : ((ci : gi) -> EData) -> Type
-- we use EData instead of p to make circularity check easier
resParam :: [(Ident,Context)] -> Judgement
resParam cos = addJType constrs (emptyJudgement JParam) where
constrs = mkProd [(c,mkProd co EData) | (c,co) <- cos] typeType
-- to enable constructor type lookup:
-- create an oper for each constructor p = c g, as c : g -> p = EData
paramConstructors :: Ident -> [(Ident,Context)] -> [(Ident,Judgement)]
paramConstructors p cs =
[(c,resOper (mkProd co (Con p)) EData) | (c,co) <- cs]
-- unifying contents of judgements
---- used in SourceToGF; make error-free and informative
unifyJudgements (Left j) (Left k) = Left $ case unifyJudgement j k of
Ok l -> l
Bad s -> error s
unifyJudgement :: Judgement -> Judgement -> Err Judgement
unifyJudgement old new = do
testErr (jform old == jform new) "different judment forms"
[jty,jde,jpri] <- mapM unifyField [jtype,jdef,jprintname]
return $ old{jtype = jty, jdef = jde, jprintname = jpri}
where
unifyField field = unifyTerm (field old) (field new)
unifyTerm oterm nterm = case (oterm,nterm) of
(Meta _,t) -> return t
(t,Meta _) -> return t
_ -> do
if (nterm /= oterm)
then (trace (unwords ["illegal update of",prt oterm,"to",prt nterm])
(return ()))
else return () ---- to recover from spurious qualification conflicts
---- testErr (nterm == oterm)
---- (unwords ["illegal update of",prt oterm,"to",prt nterm])
return nterm

96
src/GF/Devel/Grammar/Modules.hs
View File

@@ -1,96 +0,0 @@
module GF.Devel.Grammar.Modules where
import GF.Devel.Grammar.Judgements
import GF.Devel.Grammar.Terms
import GF.Infra.Ident
import GF.Data.Operations
import Control.Monad
import Data.Map
data GF = GF {
gfabsname :: Maybe Ident ,
gfcncnames :: [Ident] ,
gflags :: Map Ident String , -- value of a global flag
gfmodules :: Map Ident Module
}
emptyGF :: GF
emptyGF = GF Nothing [] empty empty
type SourceModule = (Ident,Module)
listModules :: GF -> [SourceModule]
listModules = assocs.gfmodules
addModule :: Ident -> Module -> GF -> GF
addModule c m gf = gf {gfmodules = insert c m (gfmodules gf)}
data Module = Module {
mtype :: ModuleType,
miscomplete :: Bool,
minterfaces :: [(Ident,Ident)], -- non-empty for functors
minstances :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for instant'ions
mextends :: [(Ident,MInclude)],
mopens :: [(Ident,Ident)], -- used name, original name
mflags :: Map Ident String,
mjments :: MapJudgement
}
emptyModule :: Ident -> Module
emptyModule m = Module MTGrammar True [] [] [] [] empty empty
type MapJudgement = Map Ident JEntry -- def or indirection
isCompleteModule :: Module -> Bool
isCompleteModule = miscomplete ---- Prelude.null . minterfaces
isInterface :: Module -> Bool
isInterface m = case mtype m of
MTInterface -> True
MTAbstract -> True
_ -> False
interfaceName :: Module -> Maybe Ident
interfaceName mo = case mtype mo of
MTInstance i -> return i
MTConcrete i -> return i
_ -> Nothing
listJudgements :: Module -> [(Ident,JEntry)]
listJudgements = assocs . mjments
type JEntry = Either Judgement Indirection
data ModuleType =
MTAbstract
| MTConcrete Ident
| MTInterface
| MTInstance Ident
| MTGrammar
deriving Eq
data MInclude =
MIAll
| MIExcept [Ident]
| MIOnly [Ident]
type Indirection = (Ident,Bool) -- module of origin, whether canonical
isConstructorEntry :: Either Judgement Indirection -> Bool
isConstructorEntry ji = case ji of
Left j -> isConstructor j
Right i -> snd i
isConstructor :: Judgement -> Bool
isConstructor j = jdef j == EData
isInherited :: MInclude -> Ident -> Bool
isInherited mi i = case mi of
MIExcept is -> notElem i is
MIOnly is -> elem i is
_ -> True

2
src/GF/Devel/Grammar/PatternMatch.hs
View File

@@ -18,7 +18,7 @@ module GF.Devel.Grammar.PatternMatch (matchPattern,
) where ) where
import GF.Devel.Grammar.Terms import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Macros import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.PrGF import GF.Devel.Grammar.PrGF
import GF.Infra.Ident import GF.Infra.Ident

10
src/GF/Devel/Grammar/PrGF.hs
View File

@@ -21,11 +21,10 @@
module GF.Devel.Grammar.PrGF where module GF.Devel.Grammar.PrGF where
import qualified GF.Devel.Grammar.PrintGF as P import qualified GF.Devel.Compile.PrintGF as P
import GF.Devel.Grammar.GFtoSource import GF.Devel.Grammar.GFtoSource
import GF.Devel.Grammar.Modules import GF.Devel.Grammar.Grammar
import GF.Devel.Grammar.Judgements import GF.Devel.Grammar.Construct
import GF.Devel.Grammar.Terms
----import GF.Grammar.Values ----import GF.Grammar.Values
----import GF.Infra.Option ----import GF.Infra.Option
@@ -68,9 +67,6 @@ prGF = cprintTree . trGrammar
prModule :: SourceModule -> String prModule :: SourceModule -> String
prModule = cprintTree . trModule prModule = cprintTree . trModule
prJEntry :: JEntry -> String
prJEntry = either prt show
instance Print Judgement where instance Print Judgement where
prt j = cprintTree $ trAnyDef (wildIdent, j) prt j = cprintTree $ trAnyDef (wildIdent, j)
---- prt_ = prExp ---- prt_ = prExp