From 1048a89ca769264fa6019f6ad6f0926868135ab4 Mon Sep 17 00:00:00 2001 From: hallgren Date: Tue, 21 Oct 2014 19:20:31 +0000 Subject: [PATCH] ModuleName and Ident are now distinct types This makes the documentation clearer, and can potentially catch more programming mistakes. --- src/compiler/GF/Compile.hs | 8 +-- src/compiler/GF/Compile/CheckGrammar.hs | 4 +- .../GF/Compile/Compute/ConcreteNew.hs | 10 ++-- src/compiler/GF/Compile/GeneratePMCFG.hs | 2 +- src/compiler/GF/Compile/GrammarToPGF.hs | 15 +++--- src/compiler/GF/Compile/ReadFiles.hs | 2 +- src/compiler/GF/Compile/Rename.hs | 16 +++--- src/compiler/GF/Compile/SubExOpt.hs | 6 +-- src/compiler/GF/Compile/Tags.hs | 4 +- src/compiler/GF/Compile/Update.hs | 10 ++-- src/compiler/GF/CompileInParallel.hs | 4 +- src/compiler/GF/Compiler.hs | 5 +- src/compiler/GF/Grammar/Analyse.hs | 21 ++++---- src/compiler/GF/Grammar/Binary.hs | 4 ++ src/compiler/GF/Grammar/Grammar.hs | 20 ++++---- src/compiler/GF/Grammar/Lookup.hs | 28 +++++----- src/compiler/GF/Grammar/MMacros.hs | 2 +- src/compiler/GF/Grammar/Macros.hs | 6 +-- src/compiler/GF/Grammar/Parser.y | 51 ++++++++++--------- src/compiler/GF/Grammar/Predef.hs | 8 +-- src/compiler/GF/Infra/Dependencies.hs | 35 ++++++------- src/compiler/GF/Infra/Ident.hs | 10 ++++ src/compiler/GF/Interactive.hs | 6 +-- src/compiler/SimpleEditor/Convert.hs | 11 ++-- 24 files changed, 156 insertions(+), 132 deletions(-) diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index 6e7c84ce2..2aee8e519 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -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) {- diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index be6f625a5..0e8f2b775 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -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 diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs index 6bc653983..06d9b0000 100644 --- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs +++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs @@ -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 diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 40872170c..bd7d4af6b 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -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 diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index d0b588d81..ba400bc82 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -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)] diff --git a/src/compiler/GF/Compile/ReadFiles.hs b/src/compiler/GF/Compile/ReadFiles.hs index 1523e91f1..3182e192c 100644 --- a/src/compiler/GF/Compile/ReadFiles.hs +++ b/src/compiler/GF/Compile/ReadFiles.hs @@ -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 = diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index 6ade83a8c..36f90ef46 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -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) ] diff --git a/src/compiler/GF/Compile/SubExOpt.hs b/src/compiler/GF/Compile/SubExOpt.hs index 56e41d55c..d1c7842ad 100644 --- a/src/compiler/GF/Compile/SubExOpt.hs +++ b/src/compiler/GF/Compile/SubExOpt.hs @@ -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 diff --git a/src/compiler/GF/Compile/Tags.hs b/src/compiler/GF/Compile/Tags.hs index dab4ee343..6452e066f 100644 --- a/src/compiler/GF/Compile/Tags.hs +++ b/src/compiler/GF/Compile/Tags.hs @@ -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 diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 6a7b0e8d1..9556b6554 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -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) diff --git a/src/compiler/GF/CompileInParallel.hs b/src/compiler/GF/CompileInParallel.hs index 53f68c3a4..c8c25c8dc 100644 --- a/src/compiler/GF/CompileInParallel.hs +++ b/src/compiler/GF/CompileInParallel.hs @@ -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") diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs index e607c7acc..d8692c681 100644 --- a/src/compiler/GF/Compiler.hs +++ b/src/compiler/GF/Compiler.hs @@ -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 diff --git a/src/compiler/GF/Grammar/Analyse.hs b/src/compiler/GF/Grammar/Analyse.hs index adab6fcf5..5883ad4ff 100644 --- a/src/compiler/GF/Grammar/Analyse.hs +++ b/src/compiler/GF/Grammar/Analyse.hs @@ -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 ] diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs index 76c3796bc..5aed63363 100644 --- a/src/compiler/GF/Grammar/Binary.hs +++ b/src/compiler/GF/Grammar/Binary.hs @@ -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 diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index e9bf24046..5ea6e7704 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -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 diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs index e5ead0f13..fbab56499 100644 --- a/src/compiler/GF/Grammar/Lookup.hs +++ b/src/compiler/GF/Grammar/Lookup.hs @@ -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 diff --git a/src/compiler/GF/Grammar/MMacros.hs b/src/compiler/GF/Grammar/MMacros.hs index 30271a2d5..a86cf501a 100644 --- a/src/compiler/GF/Grammar/MMacros.hs +++ b/src/compiler/GF/Grammar/MMacros.hs @@ -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 diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index 66ef50ce9..95181cfbd 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/src/compiler/GF/Grammar/Macros.hs @@ -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 diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y index 387b69dd3..cf1f667da 100644 --- a/src/compiler/GF/Grammar/Parser.y +++ b/src/compiler/GF/Grammar/Parser.y @@ -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] diff --git a/src/compiler/GF/Grammar/Predef.hs b/src/compiler/GF/Grammar/Predef.hs index 633ced494..eec53788d 100644 --- a/src/compiler/GF/Grammar/Predef.hs +++ b/src/compiler/GF/Grammar/Predef.hs @@ -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" diff --git a/src/compiler/GF/Infra/Dependencies.hs b/src/compiler/GF/Infra/Dependencies.hs index 8c3d6666f..91ca0ad14 100644 --- a/src/compiler/GF/Infra/Dependencies.hs +++ b/src/compiler/GF/Infra/Dependencies.hs @@ -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 diff --git a/src/compiler/GF/Infra/Ident.hs b/src/compiler/GF/Infra/Ident.hs index 71e86fb37..7d0bed804 100644 --- a/src/compiler/GF/Infra/Ident.hs +++ b/src/compiler/GF/Infra/Ident.hs @@ -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 = diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index bcef32294..b4a04658f 100644 --- a/src/compiler/GF/Interactive.hs +++ b/src/compiler/GF/Interactive.hs @@ -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 diff --git a/src/compiler/SimpleEditor/Convert.hs b/src/compiler/SimpleEditor/Convert.hs index c0f7e3946..3ab1a131b 100644 --- a/src/compiler/SimpleEditor/Convert.hs +++ b/src/compiler/SimpleEditor/Convert.hs @@ -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"