diff options
| author | hallgren <hallgren@chalmers.se> | 2014-10-21 19:20:31 +0000 |
|---|---|---|
| committer | hallgren <hallgren@chalmers.se> | 2014-10-21 19:20:31 +0000 |
| commit | 391b301881bee7de9580f2c6d819144161e6a51d (patch) | |
| tree | 11e61e5252bfe6939eee9ef14d19bd7ca6c8bb40 /src | |
| parent | 3bfcfa157dc291e03bfb4db3baed8b0098d76f50 (diff) | |
ModuleName and Ident are now distinct types
This makes the documentation clearer, and can potentially catch more
programming mistakes.
Diffstat (limited to 'src')
24 files changed, 157 insertions, 133 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) } - -ModHeaderBody :: { ( [(Ident,MInclude)] - , Maybe (Ident,MInclude,[(Ident,Ident)]) + : '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 :: { ( [(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" |
