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,
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.UseIO(IOE,FullPath,liftIO,getLibraryDirectory,putIfVerb,
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
-- '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) =
putPointE Normal opts "linking ... " $ do
let abs = srcAbsName gr cnc
@@ -46,10 +46,10 @@ link opts (cnc,_,gr) =
srcAbsName gr cnc = err (const cnc) id $ abstractOfConcrete gr cnc
-- | 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
(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
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]))
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
let jsa = jments abs
let jsc = jments cnc
@@ -300,7 +300,7 @@ checkReservedId x =
-- auxiliaries
-- | linearization types and defaults
linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type)
linTypeOfType :: Grammar -> ModuleName -> Type -> Check (Context,Type)
linTypeOfType cnc m typ = do
let (cont,cat) = typeSkeleton typ
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.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.Lockfield(lockLabel,isLockLabel,lockRecType) --unlockRecord
import GF.Compile.Compute.Value hiding (Error)
@@ -38,10 +38,10 @@ apply env = apply' env
-- * 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 CompleteEnv = CE {srcgr::SourceGrammar,rvs::ResourceValues,
data GlobalEnv = GE Grammar ResourceValues (L Ident)
data CompleteEnv = CE {srcgr::Grammar,rvs::ResourceValues,
gloc::L Ident,local::LocalScope}
type LocalScope = [Ident]
type Stack = [Value]
@@ -73,7 +73,7 @@ resource env (m,c) =
if isPredefCat c
then value0 env =<< lockRecType c defLinType -- hmm
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
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
Nothing) = do
let pcat = protoFCat gr (am,id) lincat
pvar = protoFCat gr (identW,cVar) typeStr
pvar = protoFCat gr (MN identW,cVar) typeStr
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 Data.Array.IArray
mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IOE D.PGF
mkCanon2pgf :: Options -> SourceGrammar -> ModuleName -> IOE D.PGF
mkCanon2pgf opts gr am = do
(an,abs) <- mkAbstr am
cncs <- mapM mkConcr (allConcretes gr am)
@@ -38,7 +38,7 @@ mkCanon2pgf opts gr am = do
where
cenv = resourceValues gr
mkAbstr am = return (i2i am, D.Abstr flags funs cats)
mkAbstr am = return (mi2i am, D.Abstr flags funs cats)
where
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
printnames = genPrintNames cdefs
return (i2i cm, D.Concr flags
return (mi2i cm, D.Concr flags
printnames
cncfuns
lindefs
@@ -102,6 +102,9 @@ mkCanon2pgf opts gr am = do
i2i :: Ident -> CId
i2i = utf8CId . ident2utf8
mi2i :: ModuleName -> CId
mi2i (MN i) = i2i i
mkType :: [Ident] -> A.Type -> C.Type
mkType scope t =
case GM.typeForm t of
@@ -179,9 +182,9 @@ genCncCats gr am cm cdefs =
in (index', (i2i id,cc) : cats)
mkCncCats index (_ :cdefs) = mkCncCats index cdefs
genCncFuns :: SourceGrammar
-> Ident
-> Ident
genCncFuns :: Grammar
-> ModuleName
-> ModuleName
-> Array SeqId Sequence
-> Array SeqId Sequence
-> [(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
modName = showIdent
modName (MN m) = showIdent m
parseModHeader opts file =

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

@@ -43,13 +43,13 @@ import Data.List (nub,(\\))
import GF.Text.Pretty
-- | 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
mi <- lookupModule g m
status <- buildStatus "" g (m,mi)
renameTerm status [] t
renameModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
renameModule :: FilePath -> Grammar -> Module -> Check Module
renameModule cwd gr mo@(m,mi) = do
status <- buildStatus cwd gr mo
js <- checkMapRecover (renameInfo cwd status mo) (jments mi)
@@ -115,7 +115,7 @@ renameIdentTerm' env@(act,imps) t0 =
-- in next V:
-- 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
AbsFun _ _ Nothing _ -> 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))
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
let gr1 = prependModule gr mo
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
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))
self2status :: Ident -> SourceModInfo -> StatusTree
self2status :: ModuleName -> ModuleInfo -> StatusTree
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 =
case info of
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
-- record projection from variable or constant $r$ or qualified expression with module $r$
| 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
, 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
addSubexpConsts ::
Ident -> Map Term (Int,Int) -> [(Ident,Info)] -> [(Ident,Info)]
ModuleName -> Map Term (Int,Int) -> [(Ident,Info)] -> [(Ident,Info)]
addSubexpConsts mo tree lins = do
let opers = [oper id trm | (trm,(_,id)) <- list]
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)))
--- 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
mapM (getInfo (collectSubterms mo)) js
(tree0,_) <- get
@@ -105,7 +105,7 @@ getSubtermsMod mo js = do
return $ fi
_ -> return fi
collectSubterms :: Ident -> Term -> TermM Term
collectSubterms :: ModuleName -> Term -> TermM Term
collectSubterms mo t = case t of
App f a -> do
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) =
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]
toDep (OQualif m1 m2,incl) =
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]
filter MIAll id = True

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

@@ -29,7 +29,7 @@ import Control.Monad
import GF.Text.Pretty
-- | 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
where
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,
-- and the process is interrupted if unification fails.
-- If the extended module is incomplete, its judgements are just copied.
extendMod :: SourceGrammar ->
Bool -> (SourceModule,Ident -> Bool) -> Ident ->
extendMod :: Grammar ->
Bool -> (Module,Ident -> Bool) -> ModuleName ->
BinTree Ident Info -> Check (BinTree Ident Info)
extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
where
@@ -160,7 +160,7 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
where
i = globalizeLoc (msrc mi) i0
indirInfo :: Ident -> Info -> Info
indirInfo :: ModuleName -> Info -> Info
indirInfo n info = AnyInd b n' where
(b,n') = case info of
ResValue _ -> (True,n)
@@ -187,7 +187,7 @@ globalizeLoc fpath i =
External _ loc -> loc
loc -> loc
unifyAnyInfo :: Ident -> Info -> Info -> Err Info
unifyAnyInfo :: ModuleName -> Info -> Info -> Err Info
unifyAnyInfo m i j = case (i,j) of
(AbsCat mc1, AbsCat 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.Data.Operations
import GF.Grammar.Grammar(emptyGrammar,prependModule)
import GF.Infra.Ident(identS)
import GF.Infra.Ident(moduleNameS)
import GF.Text.Pretty
import qualified Data.ByteString.Lazy as BS
@@ -137,7 +137,7 @@ batchCompile1 lib_dir (opts,filepaths) =
cache <- liftIO $ newIOCache compile'
ts <- liftIO $ parMapM (compile cache) filepaths
gr <- readMVar sgr
let cnc = identS (justModuleName (fst (last filepaths)))
let cnc = moduleNameS (justModuleName (fst (last filepaths)))
ds <- M.toList <$> readMVar deps
{-
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.Grammar.CFG
import GF.Infra.Ident(showIdent)
--import GF.Infra.Ident(showIdent)
import GF.Infra.UseIO
import GF.Infra.Option
import GF.Data.ErrM
import GF.System.Directory
import GF.Text.Pretty(render)
import Data.Maybe
import qualified Data.Map as Map
@@ -53,7 +54,7 @@ compileSourceFiles opts fs =
-- | Create a @.pgf@ file from the output of 'parallelBatchCompile'.
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")
t_pgf <- if outputJustPGF opts
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.Infra.Ident
import GF.Text.Pretty(render)
--import GF.Infra.Option ---
import GF.Grammar.Macros
import GF.Grammar.Lookup
@@ -20,7 +21,7 @@ import qualified Data.Map as Map
import Data.List (nub)
--import Debug.Trace
stripSourceGrammar :: SourceGrammar -> SourceGrammar
stripSourceGrammar :: Grammar -> Grammar
stripSourceGrammar sgr = mGrammar [(i, m{jments = Map.map stripInfo (jments m)}) | (i,m) <- modules sgr]
stripInfo :: Info -> Info
@@ -42,7 +43,7 @@ constantsInTerm = nub . consts where
QC c -> [c]
_ -> collectOp consts t
constantDeps :: SourceGrammar -> QIdent -> Err [QIdent]
constantDeps :: Grammar -> QIdent -> Err [QIdent]
constantDeps sgr f = return $ nub $ iterFix more start where
start = constants f
more = concatMap constants
@@ -54,23 +55,23 @@ getIdTerm :: Term -> Err QIdent
getIdTerm t = case t of
Q 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)
constantDepsTerm :: SourceGrammar -> Term -> Err [Term]
constantDepsTerm :: Grammar -> Term -> Err [Term]
constantDepsTerm sgr t = do
i <- getIdTerm t
cs <- constantDeps sgr i
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
Ok tts -> return $ concat [[ty,tr] | (_,(ty,tr)) <- tts]
_ -> return $
[ty | Ok ty <- [lookupResType sgr c]] ++ -- type sig may be missing
[ty | Ok ty <- [lookupResDef sgr c]]
sizeConstant :: SourceGrammar -> Term -> Int
sizeConstant :: Grammar -> Term -> Int
sizeConstant sgr t = err (const 0) id $ do
c <- getIdTerm t
fmap (sum . map sizeTerm) $ termsOfConstant sgr c
@@ -131,20 +132,20 @@ sizesModule (_,m) =
in (length tb + sum (map snd tb),tb)
-- the size of a grammar
sizeGrammar :: SourceGrammar -> Int
sizeGrammar :: Grammar -> Int
sizeGrammar = fst . sizesGrammar
sizesGrammar :: SourceGrammar -> (Int,[(Ident,(Int,[(Ident,Int)]))])
sizesGrammar :: Grammar -> (Int,[(ModuleName,(Int,[(Ident,Int)]))])
sizesGrammar g =
let
ms = modules g
mz = [(i,sizesModule m) | m@(i,j) <- ms]
in (length mz + sum (map (fst . snd) mz), mz)
printSizesGrammar :: SourceGrammar -> String
printSizesGrammar :: Grammar -> String
printSizesGrammar g = unlines $
("total" +++ show s):
[showIdent m +++ "total" +++ show i ++++
[render m +++ "total" +++ show i ++++
unlines [indent 2 (showIdent j +++ show k) | (j,k) <- js]
| (m,(i,js)) <- sg
]

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

@@ -37,6 +37,10 @@ instance Binary Ident where
then return identW
else return (identC (rawIdentC bs))
instance Binary ModuleName where
put (MN id) = put id
get = fmap MN get
instance Binary Grammar where
put = put . modules
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
-- ^ A grammar is a self-contained collection of grammar modules
-- | A grammar is a self-contained collection of grammar modules
data Grammar = MGrammar {
moduleMap :: Map.Map ModuleName ModuleInfo,
modules :: [Module]
}
type ModuleName = Ident
-- | Modules
type Module = (ModuleName, ModuleInfo)
data ModuleInfo = ModInfo {
@@ -96,7 +96,7 @@ data ModuleInfo = ModInfo {
mextend :: [(ModuleName,MInclude)],
mwith :: Maybe (ModuleName,MInclude,[(ModuleName,ModuleName)]),
mopens :: [OpenSpec],
mexdeps :: [Ident],
mexdeps :: [ModuleName],
msrc :: FilePath,
mseqs :: Maybe (Array SeqId Sequence),
jments :: Map.Map Ident Info
@@ -112,9 +112,9 @@ instance HasSourcePath ModuleInfo where sourcePath = msrc
data ModuleType =
MTAbstract
| MTResource
| MTConcrete Ident
| MTConcrete ModuleName
| MTInterface
| MTInstance (Ident,MInclude)
| MTInstance (ModuleName,MInclude)
deriving (Eq,Show)
data MInclude = MIAll | MIOnly [Ident] | MIExcept [Ident]
@@ -142,7 +142,7 @@ data ModuleStatus =
| MSIncomplete
deriving (Eq,Ord,Show)
openedModule :: OpenSpec -> Ident
openedModule :: OpenSpec -> ModuleName
openedModule o = case o of
OSimple m -> m
OQualif _ m -> m
@@ -167,14 +167,14 @@ allDepsModule gr m = iterFix add os0 where
mods = modules gr
-- | 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]
where
mods = modules gr
modsFor = (i:) $ map openedModule $ allDepsModule gr m
-- | all modules that a module extends, directly or indirectly, with restricts
allExtends :: Grammar -> Ident -> [Module]
allExtends :: Grammar -> ModuleName -> [Module]
allExtends gr m =
case lookupModule gr m of
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
| 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
| 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'
-- indirection to module Ident
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
| AnyInd Bool ModuleName -- ^ (/INDIR/) the 'Bool' says if canonical
deriving Show
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 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
lookupResDef :: ErrorMonad m => SourceGrammar -> QIdent -> m Term
lookupResDef :: ErrorMonad m => Grammar -> QIdent -> m Term
lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x)
lookupResDefLoc gr (m,c)
@@ -85,7 +85,7 @@ lookupResDefLoc gr (m,c)
ResValue _ -> return (noLoc (QC (m,c)))
_ -> 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
info <- lookupQIdentInfo gr (m,c)
case info of
@@ -101,7 +101,7 @@ lookupResType gr (m,c) = do
ResValue (L _ t) -> return t
_ -> 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
info <- lookupQIdentInfo gr (m,c)
case info of
@@ -115,26 +115,26 @@ lookupOverload gr (m,c) = do
_ -> raise $ render (c <+> "is not an overloaded operation")
-- | 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
info <- lookupQIdentInfo gr (m,c)
case info of
AnyInd _ n -> lookupOrigInfo gr (n,c)
i -> return (m,i)
allOrigInfos :: SourceGrammar -> Ident -> [(QIdent,Info)]
allOrigInfos :: Grammar -> ModuleName -> [(QIdent,Info)]
allOrigInfos gr m = fromErr [] $ do
mo <- lookupModule gr m
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
(_,info) <- lookupOrigInfo gr c
case info of
ResParam _ (Just pvs) -> return pvs
_ -> 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 =
case ptyp of
_ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
@@ -153,7 +153,7 @@ allParamValues cnc ptyp =
-- to normalize records and record types
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
info <- lookupQIdentInfo gr (m,c)
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
_ -> 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 = do
info <- lookupQIdentInfo gr (m,c)
@@ -171,7 +171,7 @@ lookupLincat gr m c = do
_ -> raise (render (c <+> "has no linearization type in" <+> m))
-- | 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
info <- lookupQIdentInfo gr (m,c)
case info of
@@ -180,7 +180,7 @@ lookupFunType gr m c = do
_ -> raise (render ("cannot find type of" <+> c))
-- | 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
info <- lookupQIdentInfo gr (m,c)
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
-- 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 =
[((m,op),typ,loc) |
(m,mi) <- maybe [] (allExtends gr) (greatestResource gr),
@@ -214,7 +214,7 @@ allOpers gr =
_ -> typ
--- 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
isProdTo t typ = eqProd typ t || case typ of
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
qualifTerm :: Ident -> Term -> Term
qualifTerm :: ModuleName -> Term -> Term
qualifTerm m = qualif [] where
qualif xs t = case t of
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])
Q 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))
typeFormCnc :: Type -> (Context, Type)
@@ -416,7 +416,7 @@ patt2term pt = case pt of
PNeg a -> appCons cNeg [(patt2term a)] --- an encoding
redirectTerm :: Ident -> Term -> Term
redirectTerm :: ModuleName -> Term -> Term
redirectTerm n t = case t of
QC (_,f) -> QC (n,f)
Q (_,f) -> Q (n,f)
@@ -588,7 +588,7 @@ sortRec = sortBy ordLabel where
-- | 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 =
[(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b]
where

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

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

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

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

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

@@ -3,15 +3,16 @@ module GF.Infra.Dependencies (
) where
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)
-- 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
prDepGraph :: [(Ident,ModDeps)] -> String
prDepGraph :: [(ModuleName,ModDeps)] -> String
prDepGraph deps = unlines $ [
"digraph {"
] ++
@@ -20,16 +21,16 @@ prDepGraph deps = unlines $ [
"}"
]
where
mkNode (i,dep) = unwords [showIdent i, "[",nodeAttr (modtype dep),"]"]
mkNode (i,dep) = unwords [render i, "[",nodeAttr (modtype dep),"]"]
nodeAttr ty = case ty of
MTAbstract -> "style = \"solid\", shape = \"box\""
MTConcrete _ -> "style = \"solid\", shape = \"ellipse\""
_ -> "style = \"dashed\", shape = \"ellipse\""
mkArrows (i,dep) =
[unwords [showIdent i,"->",showIdent j,"[",arrowAttr "of","]"] | j <- ofs dep] ++
[unwords [showIdent i,"->",showIdent j,"[",arrowAttr "ex","]"] | j <- extendeds dep] ++
[unwords [showIdent i,"->",showIdent j,"[",arrowAttr "op","]"] | j <- openeds dep] ++
[unwords [showIdent i,"->",showIdent j,"[",arrowAttr "ed","]"] | j <- extrads dep]
[unwords [render i,"->",render j,"[",arrowAttr "of","]"] | j <- ofs dep] ++
[unwords [render i,"->",render j,"[",arrowAttr "ex","]"] | j <- extendeds dep] ++
[unwords [render i,"->",render j,"[",arrowAttr "op","]"] | j <- openeds dep] ++
[unwords [render i,"->",render j,"[",arrowAttr "ed","]"] | j <- extrads dep]
arrowAttr s = case s of
"of" -> "style = \"solid\", arrowhead = \"empty\""
"ex" -> "style = \"solid\""
@@ -38,18 +39,18 @@ prDepGraph deps = unlines $ [
data ModDeps = ModDeps {
modtype :: ModuleType,
ofs :: [Ident],
extendeds :: [Ident],
openeds :: [Ident],
extrads :: [Ident],
functors :: [Ident],
interfaces :: [Ident],
instances :: [Ident]
ofs :: [ModuleName],
extendeds :: [ModuleName],
openeds :: [ModuleName],
extrads :: [ModuleName],
functors :: [ModuleName],
interfaces :: [ModuleName],
instances :: [ModuleName]
}
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]
where
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
}
yes i = case monly of
Just only -> match (showIdent i) only
Just only -> match (render i) only
_ -> True
match s os = any (\x -> doMatch x s) os
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
ModuleName(..), moduleNameS,
Ident, ident2utf8, showIdent, prefixIdent,
identS, identC, identV, identA, identAV, identW,
argIdent, isArgIdent, getArgIndex,
@@ -34,6 +35,15 @@ import PGF.Internal(Binary(..))
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
-- internal representation never returned by the parser
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 strip = if elem "-strip" os then stripSourceGrammar else id
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
case 0 of
_ | elem "-detailedsize" os -> putStrLn (printSizesGrammar mygr)
@@ -246,9 +246,9 @@ execute1 opts gfenv0 s0 =
let sz = sizesGrammar mygr
putStrLn $ unlines $
("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_
(\ 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))
(modules 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 GF.Infra.Option(optionsGFO)
import GF.Infra.Ident(showIdent)
import GF.Infra.Ident(showIdent,ModuleName(..))
import GF.Grammar.Grammar
import GF.Grammar.Printer(ppParams,ppTerm,getAbs,TermPrintQual(..))
import GF.Grammar.Parser(runP,pModDef)
@@ -56,10 +56,10 @@ convAbstract (modid,src) =
case lookup "startcat" flags of
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
convExtend (modid,MIAll) = return (convId modid)
convExtend (modid,MIAll) = return (convModId modid)
convExtend _ = fail "unsupported module extension"
convAbsJments jments = foldM convAbsJment ([],[]) (jmentList jments)
@@ -86,6 +86,7 @@ convSimpleType (Vr id) = return (convId id)
convSimpleType t = fail "unsupported type"
convId = showIdent
convModId (MN m) = convId m
convConcrete (modid,src) =
do unless (isModCnc src) $ fail "Concrete syntax expected"
@@ -100,13 +101,13 @@ convConcrete (modid,src) =
langcode = "" -- !!!
conc = Concrete langcode opens ps lcs os ls
abs = Abstract "-" [] [] -- dummy
return $ Grammar (convId modid) extends abs [conc]
return $ Grammar (convModId modid) extends abs [conc]
convOpens = mapM convOpen
convOpen o =
case o of
OSimple id -> return (convId id)
OSimple id -> return (convModId id)
_ -> fail "unsupported module open"