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

ModuleName and Ident are now distinct types

Browse Source 
This makes the documentation clearer, and can potentially catch more
programming mistakes.
This commit is contained in:
hallgren
2014-10-21 19:20:31 +00:00
parent 491e8b2bb8
commit 1048a89ca7
24 changed files with 156 additions and 132 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -8,7 +8,7 @@ import GF.CompileOne(compileOne)
import GF.Grammar.Grammar(Grammar,emptyGrammar, import GF.Grammar.Grammar(Grammar,emptyGrammar,
abstractOfConcrete,prependModule)--,msrc,modules abstractOfConcrete,prependModule)--,msrc,modules
import GF.Infra.Ident(Ident,identS)--,showIdent import GF.Infra.Ident(ModuleName,moduleNameS)--,showIdent
import GF.Infra.Option import GF.Infra.Option
import GF.Infra.UseIO(IOE,FullPath,liftIO,getLibraryDirectory,putIfVerb, import GF.Infra.UseIO(IOE,FullPath,liftIO,getLibraryDirectory,putIfVerb,
justModuleName,extendPathEnv,putStrE,putPointE) justModuleName,extendPathEnv,putStrE,putPointE)
@@ -32,7 +32,7 @@ compileToPGF opts fs = link opts =<< batchCompile opts fs
-- | Link a grammar into a 'PGF' that can be used to 'PGF.linearize' and -- | Link a grammar into a 'PGF' that can be used to 'PGF.linearize' and
-- 'PGF.parse' with the "PGF" run-time system. -- 'PGF.parse' with the "PGF" run-time system.
link :: Options -> (Ident,t,Grammar) -> IOE PGF link :: Options -> (ModuleName,t,Grammar) -> IOE PGF
link opts (cnc,_,gr) = link opts (cnc,_,gr) =
putPointE Normal opts "linking ... " $ do putPointE Normal opts "linking ... " $ do
let abs = srcAbsName gr cnc let abs = srcAbsName gr cnc
@@ -46,10 +46,10 @@ link opts (cnc,_,gr) =
srcAbsName gr cnc = err (const cnc) id $ abstractOfConcrete gr cnc srcAbsName gr cnc = err (const cnc) id $ abstractOfConcrete gr cnc
-- | Compile the given grammar files and everything they depend on -- | Compile the given grammar files and everything they depend on
batchCompile :: Options -> [FilePath] -> IOE (Ident,UTCTime,Grammar) batchCompile :: Options -> [FilePath] -> IOE (ModuleName,UTCTime,Grammar)
batchCompile opts files = do batchCompile opts files = do
(gr,menv) <- foldM (compileModule opts) emptyCompileEnv files (gr,menv) <- foldM (compileModule opts) emptyCompileEnv files
let cnc = identS (justModuleName (last files)) let cnc = moduleNameS (justModuleName (last files))
t = maximum . map fst $ Map.elems menv t = maximum . map fst $ Map.elems menv
return (cnc,t,gr) return (cnc,t,gr)
{- {-

4
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -82,7 +82,7 @@ checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty
nest 2 (vcat [f <+> "on" <+> fsep is | (f,is) <- cs])) nest 2 (vcat [f <+> "on" <+> fsep is | (f,is) <- cs]))
allDeps = concatMap (allDependencies (const True) . jments . snd) mos allDeps = concatMap (allDependencies (const True) . jments . snd) mos
checkCompleteGrammar :: Options -> FilePath -> SourceGrammar -> SourceModule -> SourceModule -> Check SourceModule checkCompleteGrammar :: Options -> FilePath -> Grammar -> Module -> Module -> Check Module
checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc empty $ do checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc empty $ do
let jsa = jments abs let jsa = jments abs
let jsc = jments cnc let jsc = jments cnc
@@ -300,7 +300,7 @@ checkReservedId x =
-- auxiliaries -- auxiliaries
-- | linearization types and defaults -- | linearization types and defaults
linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type) linTypeOfType :: Grammar -> ModuleName -> Type -> Check (Context,Type)
linTypeOfType cnc m typ = do linTypeOfType cnc m typ = do
let (cont,cat) = typeSkeleton typ let (cont,cat) = typeSkeleton typ
val <- lookLin cat val <- lookLin cat

10
src/compiler/GF/Compile/Compute/ConcreteNew.hs
View File

@@ -7,7 +7,7 @@ module GF.Compile.Compute.ConcreteNew
import GF.Grammar hiding (Env, VGen, VApp, VRecType) import GF.Grammar hiding (Env, VGen, VApp, VRecType)
import GF.Grammar.Lookup(lookupResDefLoc,allParamValues) import GF.Grammar.Lookup(lookupResDefLoc,allParamValues)
import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr,isPredefCat) import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr)
import GF.Grammar.PatternMatch(matchPattern,measurePatt) import GF.Grammar.PatternMatch(matchPattern,measurePatt)
import GF.Grammar.Lockfield(lockLabel,isLockLabel,lockRecType) --unlockRecord import GF.Grammar.Lockfield(lockLabel,isLockLabel,lockRecType) --unlockRecord
import GF.Compile.Compute.Value hiding (Error) import GF.Compile.Compute.Value hiding (Error)
@@ -38,10 +38,10 @@ apply env = apply' env
-- * Environments -- * Environments
type ResourceValues = Map.Map Ident (Map.Map Ident (Err Value)) type ResourceValues = Map.Map ModuleName (Map.Map Ident (Err Value))
data GlobalEnv = GE SourceGrammar ResourceValues (L Ident) data GlobalEnv = GE Grammar ResourceValues (L Ident)
data CompleteEnv = CE {srcgr::SourceGrammar,rvs::ResourceValues, data CompleteEnv = CE {srcgr::Grammar,rvs::ResourceValues,
gloc::L Ident,local::LocalScope} gloc::L Ident,local::LocalScope}
type LocalScope = [Ident] type LocalScope = [Ident]
type Stack = [Value] type Stack = [Value]
@@ -73,7 +73,7 @@ resource env (m,c) =
if isPredefCat c if isPredefCat c
then value0 env =<< lockRecType c defLinType -- hmm then value0 env =<< lockRecType c defLinType -- hmm
else maybe e id $ Map.lookup c =<< Map.lookup m (rvs env) else maybe e id $ Map.lookup c =<< Map.lookup m (rvs env)
where e = fail $ "Not found: "++showIdent m++"."++showIdent c where e = fail $ "Not found: "++render m++"."++showIdent c
-- | Convert operators once, not every time they are looked up -- | Convert operators once, not every time they are looked up
resourceValues :: SourceGrammar -> GlobalEnv resourceValues :: SourceGrammar -> GlobalEnv

2
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -108,7 +108,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ linc
mprn mprn
Nothing) = do Nothing) = do
let pcat = protoFCat gr (am,id) lincat let pcat = protoFCat gr (am,id) lincat
pvar = protoFCat gr (identW,cVar) typeStr pvar = protoFCat gr (MN identW,cVar) typeStr
pmcfgEnv0 = emptyPMCFGEnv pmcfgEnv0 = emptyPMCFGEnv

15
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -30,7 +30,7 @@ import qualified Data.Map as Map
import qualified Data.IntMap as IntMap import qualified Data.IntMap as IntMap
import Data.Array.IArray import Data.Array.IArray
mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IOE D.PGF mkCanon2pgf :: Options -> SourceGrammar -> ModuleName -> IOE D.PGF
mkCanon2pgf opts gr am = do mkCanon2pgf opts gr am = do
(an,abs) <- mkAbstr am (an,abs) <- mkAbstr am
cncs <- mapM mkConcr (allConcretes gr am) cncs <- mapM mkConcr (allConcretes gr am)
@@ -38,7 +38,7 @@ mkCanon2pgf opts gr am = do
where where
cenv = resourceValues gr cenv = resourceValues gr
mkAbstr am = return (i2i am, D.Abstr flags funs cats) mkAbstr am = return (mi2i am, D.Abstr flags funs cats)
where where
aflags = err (const noOptions) mflags (lookupModule gr am) aflags = err (const noOptions) mflags (lookupModule gr am)
@@ -78,7 +78,7 @@ mkCanon2pgf opts gr am = do
= genCncFuns gr am cm ex_seqs_arr seqs cdefs fid_cnt1 cnccats = genCncFuns gr am cm ex_seqs_arr seqs cdefs fid_cnt1 cnccats
printnames = genPrintNames cdefs printnames = genPrintNames cdefs
return (i2i cm, D.Concr flags return (mi2i cm, D.Concr flags
printnames printnames
cncfuns cncfuns
lindefs lindefs
@@ -102,6 +102,9 @@ mkCanon2pgf opts gr am = do
i2i :: Ident -> CId i2i :: Ident -> CId
i2i = utf8CId . ident2utf8 i2i = utf8CId . ident2utf8
mi2i :: ModuleName -> CId
mi2i (MN i) = i2i i
mkType :: [Ident] -> A.Type -> C.Type mkType :: [Ident] -> A.Type -> C.Type
mkType scope t = mkType scope t =
case GM.typeForm t of case GM.typeForm t of
@@ -179,9 +182,9 @@ genCncCats gr am cm cdefs =
in (index', (i2i id,cc) : cats) in (index', (i2i id,cc) : cats)
mkCncCats index (_ :cdefs) = mkCncCats index cdefs mkCncCats index (_ :cdefs) = mkCncCats index cdefs
genCncFuns :: SourceGrammar genCncFuns :: Grammar
-> Ident -> ModuleName
-> Ident -> ModuleName
-> Array SeqId Sequence -> Array SeqId Sequence
-> Array SeqId Sequence -> Array SeqId Sequence
-> [(QIdent, Info)] -> [(QIdent, Info)]

2
src/compiler/GF/Compile/ReadFiles.hs
View File

@@ -211,7 +211,7 @@ importsOfModule (m,mi) = (modName m,depModInfo mi [])
depInst (m,n) xs = modName m:modName n:xs depInst (m,n) xs = modName m:modName n:xs
modName = showIdent modName (MN m) = showIdent m
parseModHeader opts file = parseModHeader opts file =

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

@@ -43,13 +43,13 @@ import Data.List (nub,(\\))
import GF.Text.Pretty import GF.Text.Pretty
-- | this gives top-level access to renaming term input in the cc command -- | this gives top-level access to renaming term input in the cc command
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term renameSourceTerm :: Grammar -> ModuleName -> Term -> Check Term
renameSourceTerm g m t = do renameSourceTerm g m t = do
mi <- lookupModule g m mi <- lookupModule g m
status <- buildStatus "" g (m,mi) status <- buildStatus "" g (m,mi)
renameTerm status [] t renameTerm status [] t
renameModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule renameModule :: FilePath -> Grammar -> Module -> Check Module
renameModule cwd gr mo@(m,mi) = do renameModule cwd gr mo@(m,mi) = do
status <- buildStatus cwd gr mo status <- buildStatus cwd gr mo
js <- checkMapRecover (renameInfo cwd status mo) (jments mi) js <- checkMapRecover (renameInfo cwd status mo) (jments mi)
@@ -115,7 +115,7 @@ renameIdentTerm' env@(act,imps) t0 =
-- in next V: -- in next V:
-- Bad $ "conflicting imports:" +++ unwords (map prt ts) -- Bad $ "conflicting imports:" +++ unwords (map prt ts)
info2status :: Maybe Ident -> (Ident,Info) -> StatusInfo info2status :: Maybe ModuleName -> (Ident,Info) -> StatusInfo
info2status mq (c,i) = case i of info2status mq (c,i) = case i of
AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq
ResValue _ -> maybe Con (curry QC) mq ResValue _ -> maybe Con (curry QC) mq
@@ -129,7 +129,7 @@ tree2status o = case o of
OSimple i -> mapTree (info2status (Just i)) OSimple i -> mapTree (info2status (Just i))
OQualif i j -> mapTree (info2status (Just j)) OQualif i j -> mapTree (info2status (Just j))
buildStatus :: FilePath -> SourceGrammar -> SourceModule -> Check Status buildStatus :: FilePath -> Grammar -> Module -> Check Status
buildStatus cwd gr mo@(m,mi) = checkInModule cwd mi NoLoc empty $ do buildStatus cwd gr mo@(m,mi) = checkInModule cwd mi NoLoc empty $ do
let gr1 = prependModule gr mo let gr1 = prependModule gr mo
exts = [(OSimple m,mi) | (m,mi) <- allExtends gr1 m] exts = [(OSimple m,mi) | (m,mi) <- allExtends gr1 m]
@@ -139,14 +139,14 @@ buildStatus cwd gr mo@(m,mi) = checkInModule cwd mi NoLoc empty $ do
then (emptyBinTree, reverse sts) -- the module itself does not define any names then (emptyBinTree, reverse sts) -- the module itself does not define any names
else (self2status m mi,reverse sts)) -- so the empty ident is not needed else (self2status m mi,reverse sts)) -- so the empty ident is not needed
modInfo2status :: (OpenSpec,SourceModInfo) -> (OpenSpec, StatusTree) modInfo2status :: (OpenSpec,ModuleInfo) -> (OpenSpec, StatusTree)
modInfo2status (o,mo) = (o,tree2status o (jments mo)) modInfo2status (o,mo) = (o,tree2status o (jments mo))
self2status :: Ident -> SourceModInfo -> StatusTree self2status :: ModuleName -> ModuleInfo -> StatusTree
self2status c m = mapTree (info2status (Just c)) (jments m) self2status c m = mapTree (info2status (Just c)) (jments m)
renameInfo :: FilePath -> Status -> SourceModule -> Ident -> Info -> Check Info renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info
renameInfo cwd status (m,mi) i info = renameInfo cwd status (m,mi) i info =
case info of case info of
AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco) AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco)
@@ -220,7 +220,7 @@ renameTerm env vars = ren vars where
P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either
-- record projection from variable or constant $r$ or qualified expression with module $r$ -- record projection from variable or constant $r$ or qualified expression with module $r$
| elem r vs -> return trm -- try var proj first .. | elem r vs -> return trm -- try var proj first ..
| otherwise -> checks [ renid' (Q (r,label2ident l)) -- .. and qualified expression second. | otherwise -> checks [ renid' (Q (MN r,label2ident l)) -- .. and qualified expression second.
, renid' t >>= \t -> return (P t l) -- try as a constant at the end , renid' t >>= \t -> return (P t l) -- try as a constant at the end
, checkError ("unknown qualified constant" <+> trm) , checkError ("unknown qualified constant" <+> trm)
] ]

6
src/compiler/GF/Compile/SubExOpt.hs
View File

@@ -68,7 +68,7 @@ type TermList = Map Term (Int,Int) -- number of occs, id
type TermM a = State (TermList,Int) a type TermM a = State (TermList,Int) a
addSubexpConsts :: addSubexpConsts ::
Ident -> Map Term (Int,Int) -> [(Ident,Info)] -> [(Ident,Info)] ModuleName -> Map Term (Int,Int) -> [(Ident,Info)] -> [(Ident,Info)]
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]
map mkOne $ opers ++ lins map mkOne $ opers ++ lins
@@ -90,7 +90,7 @@ addSubexpConsts mo tree lins = do
oper id trm = (operIdent id, ResOper (Just (L NoLoc (EInt 8))) (Just (L NoLoc trm))) oper id trm = (operIdent id, ResOper (Just (L NoLoc (EInt 8))) (Just (L NoLoc trm)))
--- impossible type encoding generated opers --- impossible type encoding generated opers
getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int)) getSubtermsMod :: ModuleName -> [(Ident,Info)] -> TermM (Map Term (Int,Int))
getSubtermsMod mo js = do getSubtermsMod mo js = do
mapM (getInfo (collectSubterms mo)) js mapM (getInfo (collectSubterms mo)) js
(tree0,_) <- get (tree0,_) <- get
@@ -105,7 +105,7 @@ getSubtermsMod mo js = do
return $ fi return $ fi
_ -> return fi _ -> return fi
collectSubterms :: Ident -> Term -> TermM Term collectSubterms :: ModuleName -> Term -> TermM Term
collectSubterms mo t = case t of collectSubterms mo t = case t of
App f a -> do App f a -> do
collect f collect f

4
src/compiler/GF/Compile/Tags.hs
View File

@@ -63,11 +63,11 @@ getImports opts gr mo@(m,mi) = concatMap toDep allOpens
toDep (OSimple m,incl) = toDep (OSimple m,incl) =
let Ok mi = lookupModule gr m let Ok mi = lookupModule gr m
in [showIdent id ++ "\t" ++ "indir" ++ "\t" ++ showIdent m ++ "\t\t" ++ gf2gftags opts (orig mi info) in [showIdent id ++ "\t" ++ "indir" ++ "\t" ++ render m ++ "\t\t" ++ gf2gftags opts (orig mi info)
| (id,info) <- Map.toList (jments mi), filter incl id] | (id,info) <- Map.toList (jments mi), filter incl id]
toDep (OQualif m1 m2,incl) = toDep (OQualif m1 m2,incl) =
let Ok mi = lookupModule gr m2 let Ok mi = lookupModule gr m2
in [showIdent id ++ "\t" ++ "indir" ++ "\t" ++ showIdent m2 ++ "\t" ++ showIdent m1 ++ "\t" ++ gf2gftags opts (orig mi info) in [showIdent id ++ "\t" ++ "indir" ++ "\t" ++ render m2 ++ "\t" ++ render m1 ++ "\t" ++ gf2gftags opts (orig mi info)
| (id,info) <- Map.toList (jments mi), filter incl id] | (id,info) <- Map.toList (jments mi), filter incl id]
filter MIAll id = True filter MIAll id = True

10
src/compiler/GF/Compile/Update.hs
View File

@@ -29,7 +29,7 @@ import Control.Monad
import GF.Text.Pretty import GF.Text.Pretty
-- | combine a list of definitions into a balanced binary search tree -- | combine a list of definitions into a balanced binary search tree
buildAnyTree :: Monad m => Ident -> [(Ident,Info)] -> m (BinTree Ident Info) buildAnyTree :: Monad m => ModuleName -> [(Ident,Info)] -> m (BinTree Ident Info)
buildAnyTree m = go Map.empty buildAnyTree m = go Map.empty
where where
go map [] = return map go map [] = return map
@@ -133,8 +133,8 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
-- | When extending a complete module: new information is inserted, -- | When extending a complete module: new information is inserted,
-- 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 :: SourceGrammar -> extendMod :: Grammar ->
Bool -> (SourceModule,Ident -> Bool) -> Ident -> Bool -> (Module,Ident -> Bool) -> ModuleName ->
BinTree Ident Info -> Check (BinTree Ident Info) BinTree Ident Info -> Check (BinTree Ident Info)
extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi) extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
where where
@@ -160,7 +160,7 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
where where
i = globalizeLoc (msrc mi) i0 i = globalizeLoc (msrc mi) i0
indirInfo :: Ident -> Info -> Info indirInfo :: ModuleName -> Info -> Info
indirInfo n info = AnyInd b n' where indirInfo n info = AnyInd b n' where
(b,n') = case info of (b,n') = case info of
ResValue _ -> (True,n) ResValue _ -> (True,n)
@@ -187,7 +187,7 @@ globalizeLoc fpath i =
External _ loc -> loc External _ loc -> loc
loc -> loc loc -> loc
unifyAnyInfo :: Ident -> Info -> Info -> Err Info unifyAnyInfo :: ModuleName -> Info -> Info -> Err Info
unifyAnyInfo m i j = case (i,j) of unifyAnyInfo m i j = case (i,j) of
(AbsCat mc1, AbsCat mc2) -> (AbsCat mc1, AbsCat mc2) ->
liftM AbsCat (unifyMaybeL mc1 mc2) liftM AbsCat (unifyMaybeL mc1 mc2)

4
src/compiler/GF/CompileInParallel.hs
View File

@@ -15,7 +15,7 @@ import GF.Infra.Option
import GF.Infra.UseIO import GF.Infra.UseIO
import GF.Data.Operations import GF.Data.Operations
import GF.Grammar.Grammar(emptyGrammar,prependModule) import GF.Grammar.Grammar(emptyGrammar,prependModule)
import GF.Infra.Ident(identS) import GF.Infra.Ident(moduleNameS)
import GF.Text.Pretty import GF.Text.Pretty
import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as BS
@@ -137,7 +137,7 @@ batchCompile1 lib_dir (opts,filepaths) =
cache <- liftIO $ newIOCache compile' cache <- liftIO $ newIOCache compile'
ts <- liftIO $ parMapM (compile cache) filepaths ts <- liftIO $ parMapM (compile cache) filepaths
gr <- readMVar sgr gr <- readMVar sgr
let cnc = identS (justModuleName (fst (last filepaths))) let cnc = moduleNameS (justModuleName (fst (last filepaths)))
ds <- M.toList <$> readMVar deps ds <- M.toList <$> readMVar deps
{- {-
liftIO $ writeFile (maybe "" id gfoDir</>"dependencies") liftIO $ writeFile (maybe "" id gfoDir</>"dependencies")

5
src/compiler/GF/Compiler.hs
View File

@@ -10,11 +10,12 @@ import GF.Compile.CFGtoPGF
import GF.Compile.GetGrammar import GF.Compile.GetGrammar
import GF.Grammar.CFG import GF.Grammar.CFG
import GF.Infra.Ident(showIdent) --import GF.Infra.Ident(showIdent)
import GF.Infra.UseIO import GF.Infra.UseIO
import GF.Infra.Option import GF.Infra.Option
import GF.Data.ErrM import GF.Data.ErrM
import GF.System.Directory import GF.System.Directory
import GF.Text.Pretty(render)
import Data.Maybe import Data.Maybe
import qualified Data.Map as Map import qualified Data.Map as Map
@@ -53,7 +54,7 @@ compileSourceFiles opts fs =
-- | Create a @.pgf@ file from the output of 'parallelBatchCompile'. -- | Create a @.pgf@ file from the output of 'parallelBatchCompile'.
linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) = linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
do let abs = showIdent (srcAbsName gr cnc) do let abs = render (srcAbsName gr cnc)
pgfFile = outputPath opts (grammarName' opts abs<.>"pgf") pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
t_pgf <- if outputJustPGF opts t_pgf <- if outputJustPGF opts
then maybeIO $ getModificationTime pgfFile then maybeIO $ getModificationTime pgfFile

21
src/compiler/GF/Grammar/Analyse.hs
View File

@@ -10,6 +10,7 @@ module GF.Grammar.Analyse (
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Infra.Ident import GF.Infra.Ident
import GF.Text.Pretty(render)
--import GF.Infra.Option --- --import GF.Infra.Option ---
import GF.Grammar.Macros import GF.Grammar.Macros
import GF.Grammar.Lookup import GF.Grammar.Lookup
@@ -20,7 +21,7 @@ import qualified Data.Map as Map
import Data.List (nub) import Data.List (nub)
--import Debug.Trace --import Debug.Trace
stripSourceGrammar :: SourceGrammar -> SourceGrammar stripSourceGrammar :: Grammar -> Grammar
stripSourceGrammar sgr = mGrammar [(i, m{jments = Map.map stripInfo (jments m)}) | (i,m) <- modules sgr] stripSourceGrammar sgr = mGrammar [(i, m{jments = Map.map stripInfo (jments m)}) | (i,m) <- modules sgr]
stripInfo :: Info -> Info stripInfo :: Info -> Info
@@ -42,7 +43,7 @@ constantsInTerm = nub . consts where
QC c -> [c] QC c -> [c]
_ -> collectOp consts t _ -> collectOp consts t
constantDeps :: SourceGrammar -> QIdent -> Err [QIdent] constantDeps :: Grammar -> QIdent -> Err [QIdent]
constantDeps sgr f = return $ nub $ iterFix more start where constantDeps sgr f = return $ nub $ iterFix more start where
start = constants f start = constants f
more = concatMap constants more = concatMap constants
@@ -54,23 +55,23 @@ getIdTerm :: Term -> Err QIdent
getIdTerm t = case t of getIdTerm t = case t of
Q i -> return i Q i -> return i
QC i -> return i QC i -> return i
P (Vr r) l -> return (r,label2ident l) --- needed if term is received from parser P (Vr r) l -> return (MN r,label2ident l) --- needed if term is received from parser
_ -> Bad ("expected qualified constant, not " ++ show t) _ -> Bad ("expected qualified constant, not " ++ show t)
constantDepsTerm :: SourceGrammar -> Term -> Err [Term] constantDepsTerm :: Grammar -> Term -> Err [Term]
constantDepsTerm sgr t = do constantDepsTerm sgr t = do
i <- getIdTerm t i <- getIdTerm t
cs <- constantDeps sgr i cs <- constantDeps sgr i
return $ map Q cs --- losing distinction Q/QC return $ map Q cs --- losing distinction Q/QC
termsOfConstant :: SourceGrammar -> QIdent -> Err [Term] termsOfConstant :: Grammar -> QIdent -> Err [Term]
termsOfConstant sgr c = case lookupOverload sgr c of termsOfConstant sgr c = case lookupOverload sgr c of
Ok tts -> return $ concat [[ty,tr] | (_,(ty,tr)) <- tts] Ok tts -> return $ concat [[ty,tr] | (_,(ty,tr)) <- tts]
_ -> return $ _ -> return $
[ty | Ok ty <- [lookupResType sgr c]] ++ -- type sig may be missing [ty | Ok ty <- [lookupResType sgr c]] ++ -- type sig may be missing
[ty | Ok ty <- [lookupResDef sgr c]] [ty | Ok ty <- [lookupResDef sgr c]]
sizeConstant :: SourceGrammar -> Term -> Int sizeConstant :: Grammar -> Term -> Int
sizeConstant sgr t = err (const 0) id $ do sizeConstant sgr t = err (const 0) id $ do
c <- getIdTerm t c <- getIdTerm t
fmap (sum . map sizeTerm) $ termsOfConstant sgr c fmap (sum . map sizeTerm) $ termsOfConstant sgr c
@@ -131,20 +132,20 @@ sizesModule (_,m) =
in (length tb + sum (map snd tb),tb) in (length tb + sum (map snd tb),tb)
-- the size of a grammar -- the size of a grammar
sizeGrammar :: SourceGrammar -> Int sizeGrammar :: Grammar -> Int
sizeGrammar = fst . sizesGrammar sizeGrammar = fst . sizesGrammar
sizesGrammar :: SourceGrammar -> (Int,[(Ident,(Int,[(Ident,Int)]))]) sizesGrammar :: Grammar -> (Int,[(ModuleName,(Int,[(Ident,Int)]))])
sizesGrammar g = sizesGrammar g =
let let
ms = modules g ms = modules g
mz = [(i,sizesModule m) | m@(i,j) <- ms] mz = [(i,sizesModule m) | m@(i,j) <- ms]
in (length mz + sum (map (fst . snd) mz), mz) in (length mz + sum (map (fst . snd) mz), mz)
printSizesGrammar :: SourceGrammar -> String printSizesGrammar :: Grammar -> String
printSizesGrammar g = unlines $ printSizesGrammar g = unlines $
("total" +++ show s): ("total" +++ show s):
[showIdent m +++ "total" +++ show i ++++ [render m +++ "total" +++ show i ++++
unlines [indent 2 (showIdent j +++ show k) | (j,k) <- js] unlines [indent 2 (showIdent j +++ show k) | (j,k) <- js]
| (m,(i,js)) <- sg | (m,(i,js)) <- sg
] ]

4
src/compiler/GF/Grammar/Binary.hs
View File

@@ -37,6 +37,10 @@ instance Binary Ident where
then return identW then return identW
else return (identC (rawIdentC bs)) else return (identC (rawIdentC bs))
instance Binary ModuleName where
put (MN id) = put id
get = fmap MN get
instance Binary Grammar where instance Binary Grammar where
put = put . modules put = put . modules
get = fmap mGrammar get get = fmap mGrammar get

20
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -80,13 +80,13 @@ import qualified Data.Map as Map
import GF.Text.Pretty import GF.Text.Pretty
-- ^ A grammar is a self-contained collection of grammar modules -- | A grammar is a self-contained collection of grammar modules
data Grammar = MGrammar { data Grammar = MGrammar {
moduleMap :: Map.Map ModuleName ModuleInfo, moduleMap :: Map.Map ModuleName ModuleInfo,
modules :: [Module] modules :: [Module]
} }
type ModuleName = Ident -- | Modules
type Module = (ModuleName, ModuleInfo) type Module = (ModuleName, ModuleInfo)
data ModuleInfo = ModInfo { data ModuleInfo = ModInfo {
@@ -96,7 +96,7 @@ data ModuleInfo = ModInfo {
mextend :: [(ModuleName,MInclude)], mextend :: [(ModuleName,MInclude)],
mwith :: Maybe (ModuleName,MInclude,[(ModuleName,ModuleName)]), mwith :: Maybe (ModuleName,MInclude,[(ModuleName,ModuleName)]),
mopens :: [OpenSpec], mopens :: [OpenSpec],
mexdeps :: [Ident], mexdeps :: [ModuleName],
msrc :: FilePath, msrc :: FilePath,
mseqs :: Maybe (Array SeqId Sequence), mseqs :: Maybe (Array SeqId Sequence),
jments :: Map.Map Ident Info jments :: Map.Map Ident Info
@@ -112,9 +112,9 @@ instance HasSourcePath ModuleInfo where sourcePath = msrc
data ModuleType = data ModuleType =
MTAbstract MTAbstract
| MTResource | MTResource
| MTConcrete Ident | MTConcrete ModuleName
| MTInterface | MTInterface
| MTInstance (Ident,MInclude) | MTInstance (ModuleName,MInclude)
deriving (Eq,Show) deriving (Eq,Show)
data MInclude = MIAll | MIOnly [Ident] | MIExcept [Ident] data MInclude = MIAll | MIOnly [Ident] | MIExcept [Ident]
@@ -142,7 +142,7 @@ data ModuleStatus =
| MSIncomplete | MSIncomplete
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
openedModule :: OpenSpec -> Ident openedModule :: OpenSpec -> ModuleName
openedModule o = case o of openedModule o = case o of
OSimple m -> m OSimple m -> m
OQualif _ m -> m OQualif _ m -> m
@@ -167,14 +167,14 @@ allDepsModule gr m = iterFix add os0 where
mods = modules gr mods = modules gr
-- | select just those modules that a given one depends on, including itself -- | select just those modules that a given one depends on, including itself
partOfGrammar :: Grammar -> (Ident,ModuleInfo) -> Grammar partOfGrammar :: Grammar -> Module -> Grammar
partOfGrammar gr (i,m) = mGrammar [mo | mo@(j,_) <- mods, elem j modsFor] partOfGrammar gr (i,m) = mGrammar [mo | mo@(j,_) <- mods, elem j modsFor]
where where
mods = modules gr mods = modules gr
modsFor = (i:) $ map openedModule $ allDepsModule gr m modsFor = (i:) $ map openedModule $ allDepsModule gr m
-- | all modules that a module extends, directly or indirectly, with restricts -- | all modules that a module extends, directly or indirectly, with restricts
allExtends :: Grammar -> Ident -> [Module] allExtends :: Grammar -> ModuleName -> [Module]
allExtends gr m = allExtends gr m =
case lookupModule gr m of case lookupModule gr m of
Ok mi -> (m,mi) : concatMap (allExtends gr . fst) (mextend mi) Ok mi -> (m,mi) : concatMap (allExtends gr . fst) (mextend mi)
@@ -331,14 +331,14 @@ data Info =
| ResValue (L Type) -- ^ (/RES/) to mark parameter constructors for lookup | ResValue (L Type) -- ^ (/RES/) to mark parameter constructors for lookup
| ResOper (Maybe (L Type)) (Maybe (L Term)) -- ^ (/RES/) | ResOper (Maybe (L Type)) (Maybe (L Term)) -- ^ (/RES/)
| ResOverload [Ident] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited | ResOverload [ModuleName] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited
-- judgements in concrete syntax -- judgements in concrete syntax
| CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) lindef ini'zed, | CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) lindef ini'zed,
| CncFun (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) type info added at 'TC' | CncFun (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) type info added at 'TC'
-- indirection to module Ident -- indirection to module Ident
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical | AnyInd Bool ModuleName -- ^ (/INDIR/) the 'Bool' says if canonical
deriving Show deriving Show
type Type = Term type Type = Term

28
src/compiler/GF/Grammar/Lookup.hs
View File

@@ -59,10 +59,10 @@ lookupIdent c t =
lookupIdentInfo :: ErrorMonad m => SourceModInfo -> Ident -> m Info lookupIdentInfo :: ErrorMonad m => SourceModInfo -> Ident -> m Info
lookupIdentInfo mo i = lookupIdent i (jments mo) lookupIdentInfo mo i = lookupIdent i (jments mo)
lookupQIdentInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m Info lookupQIdentInfo :: ErrorMonad m => Grammar -> QIdent -> m Info
lookupQIdentInfo gr (m,c) = flip lookupIdentInfo c =<< lookupModule gr m lookupQIdentInfo gr (m,c) = flip lookupIdentInfo c =<< lookupModule gr m
lookupResDef :: ErrorMonad m => SourceGrammar -> QIdent -> m Term lookupResDef :: ErrorMonad m => Grammar -> QIdent -> m Term
lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x) lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x)
lookupResDefLoc gr (m,c) lookupResDefLoc gr (m,c)
@@ -85,7 +85,7 @@ lookupResDefLoc gr (m,c)
ResValue _ -> return (noLoc (QC (m,c))) ResValue _ -> return (noLoc (QC (m,c)))
_ -> raise $ render (c <+> "is not defined in resource" <+> m) _ -> raise $ render (c <+> "is not defined in resource" <+> m)
lookupResType :: ErrorMonad m => SourceGrammar -> QIdent -> m Type lookupResType :: ErrorMonad m => Grammar -> QIdent -> m Type
lookupResType gr (m,c) = do lookupResType gr (m,c) = do
info <- lookupQIdentInfo gr (m,c) info <- lookupQIdentInfo gr (m,c)
case info of case info of
@@ -101,7 +101,7 @@ lookupResType gr (m,c) = do
ResValue (L _ t) -> return t ResValue (L _ t) -> return t
_ -> raise $ render (c <+> "has no type defined in resource" <+> m) _ -> raise $ render (c <+> "has no type defined in resource" <+> m)
lookupOverload :: ErrorMonad m => SourceGrammar -> QIdent -> m [([Type],(Type,Term))] lookupOverload :: ErrorMonad m => Grammar -> QIdent -> m [([Type],(Type,Term))]
lookupOverload gr (m,c) = do lookupOverload gr (m,c) = do
info <- lookupQIdentInfo gr (m,c) info <- lookupQIdentInfo gr (m,c)
case info of case info of
@@ -115,26 +115,26 @@ lookupOverload gr (m,c) = do
_ -> raise $ render (c <+> "is not an overloaded operation") _ -> raise $ render (c <+> "is not an overloaded operation")
-- | returns the original 'Info' and the module where it was found -- | returns the original 'Info' and the module where it was found
lookupOrigInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m (Ident,Info) lookupOrigInfo :: ErrorMonad m => Grammar -> QIdent -> m (ModuleName,Info)
lookupOrigInfo gr (m,c) = do lookupOrigInfo gr (m,c) = do
info <- lookupQIdentInfo gr (m,c) info <- lookupQIdentInfo gr (m,c)
case info of case info of
AnyInd _ n -> lookupOrigInfo gr (n,c) AnyInd _ n -> lookupOrigInfo gr (n,c)
i -> return (m,i) i -> return (m,i)
allOrigInfos :: SourceGrammar -> Ident -> [(QIdent,Info)] allOrigInfos :: Grammar -> ModuleName -> [(QIdent,Info)]
allOrigInfos gr m = fromErr [] $ do allOrigInfos gr m = fromErr [] $ do
mo <- lookupModule gr m mo <- lookupModule gr m
return [((m,c),i) | (c,_) <- tree2list (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]] return [((m,c),i) | (c,_) <- tree2list (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]]
lookupParamValues :: ErrorMonad m => SourceGrammar -> QIdent -> m [Term] lookupParamValues :: ErrorMonad m => Grammar -> QIdent -> m [Term]
lookupParamValues gr c = do lookupParamValues gr c = do
(_,info) <- lookupOrigInfo gr c (_,info) <- lookupOrigInfo gr c
case info of case info of
ResParam _ (Just pvs) -> return pvs ResParam _ (Just pvs) -> return pvs
_ -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined") _ -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
allParamValues :: ErrorMonad m => SourceGrammar -> Type -> m [Term] allParamValues :: ErrorMonad m => Grammar -> Type -> m [Term]
allParamValues cnc ptyp = allParamValues cnc ptyp =
case ptyp of case ptyp of
_ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]] _ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
@@ -153,7 +153,7 @@ allParamValues cnc ptyp =
-- to normalize records and record types -- to normalize records and record types
sortByFst = sortBy (\ x y -> compare (fst x) (fst y)) sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
lookupAbsDef :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m (Maybe Int,Maybe [Equation]) lookupAbsDef :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m (Maybe Int,Maybe [Equation])
lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
info <- lookupQIdentInfo gr (m,c) info <- lookupQIdentInfo gr (m,c)
case info of case info of
@@ -161,7 +161,7 @@ lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
AnyInd _ n -> lookupAbsDef gr n c AnyInd _ n -> lookupAbsDef gr n c
_ -> return (Nothing,Nothing) _ -> return (Nothing,Nothing)
lookupLincat :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type lookupLincat :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Type
lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed? lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
lookupLincat gr m c = do lookupLincat gr m c = do
info <- lookupQIdentInfo gr (m,c) info <- lookupQIdentInfo gr (m,c)
@@ -171,7 +171,7 @@ lookupLincat gr m c = do
_ -> raise (render (c <+> "has no linearization type in" <+> m)) _ -> raise (render (c <+> "has no linearization type in" <+> m))
-- | this is needed at compile time -- | this is needed at compile time
lookupFunType :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type lookupFunType :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Type
lookupFunType gr m c = do lookupFunType gr m c = do
info <- lookupQIdentInfo gr (m,c) info <- lookupQIdentInfo gr (m,c)
case info of case info of
@@ -180,7 +180,7 @@ lookupFunType gr m c = do
_ -> raise (render ("cannot find type of" <+> c)) _ -> raise (render ("cannot find type of" <+> c))
-- | this is needed at compile time -- | this is needed at compile time
lookupCatContext :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Context lookupCatContext :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Context
lookupCatContext gr m c = do lookupCatContext gr m c = do
info <- lookupQIdentInfo gr (m,c) info <- lookupQIdentInfo gr (m,c)
case info of case info of
@@ -192,7 +192,7 @@ lookupCatContext gr m c = do
-- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations -- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations
-- notice that it only gives the modules that are reachable and the opers that are included -- notice that it only gives the modules that are reachable and the opers that are included
allOpers :: SourceGrammar -> [((Ident,Ident),Type,Location)] allOpers :: Grammar -> [(QIdent,Type,Location)]
allOpers gr = allOpers gr =
[((m,op),typ,loc) | [((m,op),typ,loc) |
(m,mi) <- maybe [] (allExtends gr) (greatestResource gr), (m,mi) <- maybe [] (allExtends gr) (greatestResource gr),
@@ -214,7 +214,7 @@ allOpers gr =
_ -> typ _ -> typ
--- not for dependent types --- not for dependent types
allOpersTo :: SourceGrammar -> Type -> [((Ident,Ident),Type,Location)] allOpersTo :: Grammar -> Type -> [(QIdent,Type,Location)]
allOpersTo gr ty = [op | op@(_,typ,_) <- allOpers gr, isProdTo ty typ] where allOpersTo gr ty = [op | op@(_,typ,_) <- allOpers gr, isProdTo ty typ] where
isProdTo t typ = eqProd typ t || case typ of isProdTo t typ = eqProd typ t || case typ of
Prod _ _ a b -> isProdTo t b Prod _ _ a b -> isProdTo t b

2
src/compiler/GF/Grammar/MMacros.hs
View File

@@ -230,7 +230,7 @@ identVar _ = Bad "not a variable"
-- | light-weight rename for user interaction; also change names of internal vars -- | light-weight rename for user interaction; also change names of internal vars
qualifTerm :: Ident -> Term -> Term qualifTerm :: ModuleName -> Term -> Term
qualifTerm m = qualif [] where qualifTerm m = qualif [] where
qualif xs t = case t of qualif xs t = case t of
Abs b x t -> let x' = chV x in Abs b x' $ qualif (x':xs) t Abs b x t -> let x' = chV x in Abs b x' $ qualif (x':xs) t

6
src/compiler/GF/Grammar/Macros.hs
View File

@@ -46,7 +46,7 @@ typeForm t =
in ([],cat,args ++ [a]) in ([],cat,args ++ [a])
Q c -> ([],c,[]) Q c -> ([],c,[])
QC c -> ([],c,[]) QC c -> ([],c,[])
Sort c -> ([],(identW, c),[]) Sort c -> ([],(MN identW, c),[])
_ -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t)) _ -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))
typeFormCnc :: Type -> (Context, Type) typeFormCnc :: Type -> (Context, Type)
@@ -416,7 +416,7 @@ patt2term pt = case pt of
PNeg a -> appCons cNeg [(patt2term a)] --- an encoding PNeg a -> appCons cNeg [(patt2term a)] --- an encoding
redirectTerm :: Ident -> Term -> Term redirectTerm :: ModuleName -> Term -> Term
redirectTerm n t = case t of redirectTerm n t = case t of
QC (_,f) -> QC (n,f) QC (_,f) -> QC (n,f)
Q (_,f) -> Q (n,f) Q (_,f) -> Q (n,f)
@@ -588,7 +588,7 @@ sortRec = sortBy ordLabel where
-- | dependency check, detecting circularities and returning topo-sorted list -- | dependency check, detecting circularities and returning topo-sorted list
allDependencies :: (Ident -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])] allDependencies :: (ModuleName -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])]
allDependencies ism b = allDependencies ism b =
[(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b] [(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b]
where where

51
src/compiler/GF/Grammar/Parser.y
View File

@@ -140,16 +140,16 @@ ComplMod
: {- empty -} { MSComplete } : {- empty -} { MSComplete }
| 'incomplete' { MSIncomplete } | 'incomplete' { MSIncomplete }
ModType :: { (ModuleType,Ident) } ModType :: { (ModuleType,ModuleName) }
ModType ModType
: 'abstract' Ident { (MTAbstract, $2) } : 'abstract' ModuleName { (MTAbstract, $2) }
| 'resource' Ident { (MTResource, $2) } | 'resource' ModuleName { (MTResource, $2) }
| 'interface' Ident { (MTInterface, $2) } | 'interface' ModuleName { (MTInterface, $2) }
| 'concrete' Ident 'of' Ident { (MTConcrete $4, $2) } | 'concrete' ModuleName 'of' ModuleName { (MTConcrete $4, $2) }
| 'instance' Ident 'of' Included { (MTInstance $4, $2) } | 'instance' ModuleName 'of' Included { (MTInstance $4, $2) }
ModHeaderBody :: { ( [(Ident,MInclude)] ModHeaderBody :: { ( [(ModuleName,MInclude)]
, Maybe (Ident,MInclude,[(Ident,Ident)]) , Maybe (ModuleName,MInclude,[(ModuleName,ModuleName)])
, [OpenSpec] , [OpenSpec]
) } ) }
ModHeaderBody ModHeaderBody
@@ -166,8 +166,8 @@ ModOpen
: { [] } : { [] }
| 'open' ListOpen { $2 } | 'open' ListOpen { $2 }
ModBody :: { ( [(Ident,MInclude)] ModBody :: { ( [(ModuleName,MInclude)]
, Maybe (Ident,MInclude,[(Ident,Ident)]) , Maybe (ModuleName,MInclude,[(ModuleName,ModuleName)])
, Maybe ([OpenSpec],[(Ident,Info)],Options) , Maybe ([OpenSpec],[(Ident,Info)],Options)
) } ) }
ModBody ModBody
@@ -197,28 +197,28 @@ ListOpen
Open :: { OpenSpec } Open :: { OpenSpec }
Open Open
: Ident { OSimple $1 } : ModuleName { OSimple $1 }
| '(' Ident '=' Ident ')' { OQualif $2 $4 } | '(' ModuleName '=' ModuleName ')' { OQualif $2 $4 }
ListInst :: { [(Ident,Ident)] } ListInst :: { [(ModuleName,ModuleName)] }
ListInst ListInst
: Inst { [$1] } : Inst { [$1] }
| Inst ',' ListInst { $1 : $3 } | Inst ',' ListInst { $1 : $3 }
Inst :: { (Ident,Ident) } Inst :: { (ModuleName,ModuleName) }
Inst Inst
: '(' Ident '=' Ident ')' { ($2,$4) } : '(' ModuleName '=' ModuleName ')' { ($2,$4) }
ListIncluded :: { [(Ident,MInclude)] } ListIncluded :: { [(ModuleName,MInclude)] }
ListIncluded ListIncluded
: Included { [$1] } : Included { [$1] }
| Included ',' ListIncluded { $1 : $3 } | Included ',' ListIncluded { $1 : $3 }
Included :: { (Ident,MInclude) } Included :: { (ModuleName,MInclude) }
Included Included
: Ident { ($1,MIAll ) } : ModuleName { ($1,MIAll ) }
| Ident '[' ListIdent ']' { ($1,MIOnly $3) } | ModuleName '[' ListIdent ']' { ($1,MIOnly $3) }
| Ident '-' '[' ListIdent ']' { ($1,MIExcept $4) } | ModuleName '-' '[' ListIdent ']' { ($1,MIExcept $4) }
TopDef :: { Either [(Ident,Info)] Options } TopDef :: { Either [(Ident,Info)] Options }
TopDef TopDef
@@ -485,7 +485,7 @@ Patt
Patt1 :: { Patt } Patt1 :: { Patt }
Patt1 Patt1
: Ident ListPatt { PC $1 $2 } : Ident ListPatt { PC $1 $2 }
| Ident '.' Ident ListPatt { PP ($1,$3) $4 } | ModuleName '.' Ident ListPatt { PP ($1,$3) $4 }
| Patt3 '*' { PRep $1 } | Patt3 '*' { PRep $1 }
| Patt2 { $1 } | Patt2 { $1 }
@@ -501,10 +501,10 @@ Patt3
: '?' { PChar } : '?' { PChar }
| '[' String ']' { PChars $2 } | '[' String ']' { PChars $2 }
| '#' Ident { PMacro $2 } | '#' Ident { PMacro $2 }
| '#' Ident '.' Ident { PM ($2,$4) } | '#' ModuleName '.' Ident { PM ($2,$4) }
| '_' { PW } | '_' { PW }
| Ident { PV $1 } | Ident { PV $1 }
| Ident '.' Ident { PP ($1,$3) [] } | ModuleName '.' Ident { PP ($1,$3) [] }
| Integer { PInt $1 } | Integer { PInt $1 }
| Double { PFloat $1 } | Double { PFloat $1 }
| String { PString $1 } | String { PString $1 }
@@ -675,6 +675,9 @@ ERHS3 :: { ERHS }
| Ident { ENonTerm (showIdent $1,[]) } | Ident { ENonTerm (showIdent $1,[]) }
| '(' ERHS0 ')' { $2 } | '(' ERHS0 ')' { $2 }
ModuleName :: { ModuleName }
: Ident { MN $1 }
Posn :: { Posn } Posn :: { Posn }
Posn Posn
: {- empty -} {% getPosn } : {- empty -} {% getPosn }
@@ -730,7 +733,7 @@ mkOverload pdt pdf@(Just (L loc df)) =
case appForm df of case appForm df of
(keyw, ts@(_:_)) | isOverloading keyw -> (keyw, ts@(_:_)) | isOverloading keyw ->
case last ts of case last ts of
R fs -> [ResOverload [m | Vr m <- ts] [(L loc ty,L loc fu) | (_,(Just ty,fu)) <- fs]] R fs -> [ResOverload [MN m | Vr m <- ts] [(L loc ty,L loc fu) | (_,(Just ty,fu)) <- fs]]
_ -> [ResOper pdt pdf] _ -> [ResOper pdt pdf]
_ -> [ResOper pdt pdf] _ -> [ResOper pdt pdf]

8
src/compiler/GF/Grammar/Predef.hs
View File

@@ -10,16 +10,16 @@
module GF.Grammar.Predef where module GF.Grammar.Predef where
import GF.Infra.Ident(Ident,identS) import GF.Infra.Ident(Ident,identS,moduleNameS)
cType = identS "Type" cType = identS "Type"
cPType = identS "PType" cPType = identS "PType"
cTok = identS "Tok" cTok = identS "Tok"
cStr = identS "Str" cStr = identS "Str"
cStrs = identS "Strs" cStrs = identS "Strs"
cPredefAbs = identS "PredefAbs" cPredefAbs = moduleNameS "PredefAbs"
cPredefCnc = identS "PredefCnc" cPredefCnc = moduleNameS "PredefCnc"
cPredef = identS "Predef" cPredef = moduleNameS "Predef"
cInt = identS "Int" cInt = identS "Int"
cFloat = identS "Float" cFloat = identS "Float"
cString = identS "String" cString = identS "String"

35
src/compiler/GF/Infra/Dependencies.hs
View File

@@ -3,15 +3,16 @@ module GF.Infra.Dependencies (
) where ) where
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Infra.Ident(Ident,showIdent) --import GF.Infra.Ident(Ident)
import GF.Text.Pretty(render)
import Data.List (nub,isPrefixOf) import Data.List (nub,isPrefixOf)
-- the list gives the only modules to show, e.g. to hide the library details -- the list gives the only modules to show, e.g. to hide the library details
depGraph :: Maybe [String] -> SourceGrammar -> String depGraph :: Maybe [String] -> Grammar -> String
depGraph only = prDepGraph . grammar2moddeps only depGraph only = prDepGraph . grammar2moddeps only
prDepGraph :: [(Ident,ModDeps)] -> String prDepGraph :: [(ModuleName,ModDeps)] -> String
prDepGraph deps = unlines $ [ prDepGraph deps = unlines $ [
"digraph {" "digraph {"
] ++ ] ++
@@ -20,16 +21,16 @@ prDepGraph deps = unlines $ [
"}" "}"
] ]
where where
mkNode (i,dep) = unwords [showIdent i, "[",nodeAttr (modtype dep),"]"] mkNode (i,dep) = unwords [render i, "[",nodeAttr (modtype dep),"]"]
nodeAttr ty = case ty of nodeAttr ty = case ty of
MTAbstract -> "style = \"solid\", shape = \"box\"" MTAbstract -> "style = \"solid\", shape = \"box\""
MTConcrete _ -> "style = \"solid\", shape = \"ellipse\"" MTConcrete _ -> "style = \"solid\", shape = \"ellipse\""
_ -> "style = \"dashed\", shape = \"ellipse\"" _ -> "style = \"dashed\", shape = \"ellipse\""
mkArrows (i,dep) = mkArrows (i,dep) =
[unwords [showIdent i,"->",showIdent j,"[",arrowAttr "of","]"] | j <- ofs dep] ++ [unwords [render i,"->",render j,"[",arrowAttr "of","]"] | j <- ofs dep] ++
[unwords [showIdent i,"->",showIdent j,"[",arrowAttr "ex","]"] | j <- extendeds dep] ++ [unwords [render i,"->",render j,"[",arrowAttr "ex","]"] | j <- extendeds dep] ++
[unwords [showIdent i,"->",showIdent j,"[",arrowAttr "op","]"] | j <- openeds dep] ++ [unwords [render i,"->",render j,"[",arrowAttr "op","]"] | j <- openeds dep] ++
[unwords [showIdent i,"->",showIdent j,"[",arrowAttr "ed","]"] | j <- extrads dep] [unwords [render i,"->",render j,"[",arrowAttr "ed","]"] | j <- extrads dep]
arrowAttr s = case s of arrowAttr s = case s of
"of" -> "style = \"solid\", arrowhead = \"empty\"" "of" -> "style = \"solid\", arrowhead = \"empty\""
"ex" -> "style = \"solid\"" "ex" -> "style = \"solid\""
@@ -38,18 +39,18 @@ prDepGraph deps = unlines $ [
data ModDeps = ModDeps { data ModDeps = ModDeps {
modtype :: ModuleType, modtype :: ModuleType,
ofs :: [Ident], ofs :: [ModuleName],
extendeds :: [Ident], extendeds :: [ModuleName],
openeds :: [Ident], openeds :: [ModuleName],
extrads :: [Ident], extrads :: [ModuleName],
functors :: [Ident], functors :: [ModuleName],
interfaces :: [Ident], interfaces :: [ModuleName],
instances :: [Ident] instances :: [ModuleName]
} }
noModDeps = ModDeps MTAbstract [] [] [] [] [] [] [] noModDeps = ModDeps MTAbstract [] [] [] [] [] [] []
grammar2moddeps :: Maybe [String] -> SourceGrammar -> [(Ident,ModDeps)] grammar2moddeps :: Maybe [String] -> Grammar -> [(ModuleName,ModDeps)]
grammar2moddeps monly gr = [(i,depMod i m) | (i,m) <- modules gr, yes i] grammar2moddeps monly gr = [(i,depMod i m) | (i,m) <- modules gr, yes i]
where where
depMod i m = depMod i m =
@@ -64,7 +65,7 @@ grammar2moddeps monly gr = [(i,depMod i m) | (i,m) <- modules gr, yes i]
extrads = nub $ filter yes $ mexdeps m extrads = nub $ filter yes $ mexdeps m
} }
yes i = case monly of yes i = case monly of
Just only -> match (showIdent i) only Just only -> match (render i) only
_ -> True _ -> True
match s os = any (\x -> doMatch x s) os match s os = any (\x -> doMatch x s) os
doMatch x s = case last x of doMatch x s = case last x of

10
src/compiler/GF/Infra/Ident.hs
View File

@@ -13,6 +13,7 @@
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Infra.Ident (-- ** Identifiers module GF.Infra.Ident (-- ** Identifiers
ModuleName(..), moduleNameS,
Ident, ident2utf8, showIdent, prefixIdent, Ident, ident2utf8, showIdent, prefixIdent,
identS, identC, identV, identA, identAV, identW, identS, identC, identV, identA, identAV, identW,
argIdent, isArgIdent, getArgIndex, argIdent, isArgIdent, getArgIndex,
@@ -34,6 +35,15 @@ import PGF.Internal(Binary(..))
import GF.Text.Pretty import GF.Text.Pretty
-- | Module names
newtype ModuleName = MN Ident deriving (Eq,Ord)
moduleNameS = MN . identS
instance Show ModuleName where showsPrec d (MN m) = showsPrec d m
instance Pretty ModuleName where pp (MN m) = pp m
-- | the constructors labelled /INTERNAL/ are -- | the constructors labelled /INTERNAL/ are
-- internal representation never returned by the parser -- internal representation never returned by the parser
data Ident = data Ident =

6
src/compiler/GF/Interactive.hs
View File

@@ -238,7 +238,7 @@ execute1 opts gfenv0 s0 =
let (os,ts) = partition (isPrefixOf "-") ws let (os,ts) = partition (isPrefixOf "-") ws
let strip = if elem "-strip" os then stripSourceGrammar else id let strip = if elem "-strip" os then stripSourceGrammar else id
let mygr = strip $ case ts of let mygr = strip $ case ts of
_:_ -> mGrammar [(i,m) | (i,m) <- modules sgr, elem (showIdent i) ts] _:_ -> mGrammar [(i,m) | (i,m) <- modules sgr, elem (render i) ts]
[] -> sgr [] -> sgr
case 0 of case 0 of
_ | elem "-detailedsize" os -> putStrLn (printSizesGrammar mygr) _ | elem "-detailedsize" os -> putStrLn (printSizesGrammar mygr)
@@ -246,9 +246,9 @@ execute1 opts gfenv0 s0 =
let sz = sizesGrammar mygr let sz = sizesGrammar mygr
putStrLn $ unlines $ putStrLn $ unlines $
("total\t" ++ show (fst sz)): ("total\t" ++ show (fst sz)):
[showIdent j ++ "\t" ++ show (fst k) | (j,k) <- snd sz] [render j ++ "\t" ++ show (fst k) | (j,k) <- snd sz]
_ | elem "-save" os -> mapM_ _ | elem "-save" os -> mapM_
(\ m@(i,_) -> let file = (showIdent i ++ ".gfh") in (\ m@(i,_) -> let file = (render i ++ ".gfh") in
restricted $ writeFile file (render (ppModule Qualified m)) >> P.putStrLn ("wrote " ++ file)) restricted $ writeFile file (render (ppModule Qualified m)) >> P.putStrLn ("wrote " ++ file))
(modules mygr) (modules mygr)
_ -> putStrLn $ render mygr _ -> putStrLn $ render mygr

11
src/compiler/SimpleEditor/Convert.hs
View File

@@ -11,7 +11,7 @@ import GF.Text.Pretty(render,(<+>))
import qualified Data.ByteString.UTF8 as UTF8(fromString) import qualified Data.ByteString.UTF8 as UTF8(fromString)
import GF.Infra.Option(optionsGFO) import GF.Infra.Option(optionsGFO)
import GF.Infra.Ident(showIdent) import GF.Infra.Ident(showIdent,ModuleName(..))
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Grammar.Printer(ppParams,ppTerm,getAbs,TermPrintQual(..)) import GF.Grammar.Printer(ppParams,ppTerm,getAbs,TermPrintQual(..))
import GF.Grammar.Parser(runP,pModDef) import GF.Grammar.Parser(runP,pModDef)
@@ -56,10 +56,10 @@ convAbstract (modid,src) =
case lookup "startcat" flags of case lookup "startcat" flags of
Just (LStr cat) -> cat Just (LStr cat) -> cat
_ -> "-" _ -> "-"
return $ Grammar (convId modid) extends (Abstract startcat cats funs) [] return $ Grammar (convModId modid) extends (Abstract startcat cats funs) []
convExtends = mapM convExtend convExtends = mapM convExtend
convExtend (modid,MIAll) = return (convId modid) convExtend (modid,MIAll) = return (convModId modid)
convExtend _ = fail "unsupported module extension" convExtend _ = fail "unsupported module extension"
convAbsJments jments = foldM convAbsJment ([],[]) (jmentList jments) convAbsJments jments = foldM convAbsJment ([],[]) (jmentList jments)
@@ -86,6 +86,7 @@ convSimpleType (Vr id) = return (convId id)
convSimpleType t = fail "unsupported type" convSimpleType t = fail "unsupported type"
convId = showIdent convId = showIdent
convModId (MN m) = convId m
convConcrete (modid,src) = convConcrete (modid,src) =
do unless (isModCnc src) $ fail "Concrete syntax expected" do unless (isModCnc src) $ fail "Concrete syntax expected"
@@ -100,13 +101,13 @@ convConcrete (modid,src) =
langcode = "" -- !!! langcode = "" -- !!!
conc = Concrete langcode opens ps lcs os ls conc = Concrete langcode opens ps lcs os ls
abs = Abstract "-" [] [] -- dummy abs = Abstract "-" [] [] -- dummy
return $ Grammar (convId modid) extends abs [conc] return $ Grammar (convModId modid) extends abs [conc]
convOpens = mapM convOpen convOpens = mapM convOpen
convOpen o = convOpen o =
case o of case o of
OSimple id -> return (convId id) OSimple id -> return (convModId id)
_ -> fail "unsupported module open" _ -> fail "unsupported module open"