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

refactor GF.Infra.Modules for better error messages

Browse Source
This commit is contained in:
krasimir
2010-01-31 15:54:25 +00:00
parent acd927f87b
commit be6465a2eb
10 changed files with 159 additions and 162 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -35,7 +35,7 @@ prDepGraph deps = unlines $ [
"ed" -> "style = \"dotted\""
data ModDeps = ModDeps {
modtype :: ModuleType Ident,
modtype :: ModuleType,
ofs :: [Ident],
extendeds :: [Ident],
openeds :: [Ident],

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

@@ -13,7 +13,7 @@
-----------------------------------------------------------------------------
module GF.Infra.Ident (-- * Identifiers
Ident(..), ident2bs, showIdent,
Ident(..), ident2bs, showIdent, ppIdent,
identC, identV, identA, identAV, identW,
argIdent, varStr, varX, isWildIdent, varIndex,
-- * refreshing identifiers
@@ -23,7 +23,7 @@ module GF.Infra.Ident (-- * Identifiers
import GF.Data.Operations
import qualified Data.ByteString.Char8 as BS
-- import Monad
import Text.PrettyPrint
-- | the constructors labelled /INTERNAL/ are
@@ -51,6 +51,9 @@ ident2bs i = case i of
showIdent :: Ident -> String
showIdent i = BS.unpack $! ident2bs i
ppIdent :: Ident -> Doc
ppIdent = text . showIdent
identC :: BS.ByteString -> Ident
identV :: BS.ByteString -> Int -> Ident
identA :: BS.ByteString -> Int -> Ident

259
src/compiler/GF/Infra/Modules.hs
View File

@@ -19,32 +19,32 @@
-----------------------------------------------------------------------------
module GF.Infra.Modules (
MGrammar(..), ModInfo(..), ModuleType(..),
MInclude (..),
extends, isInherited,inheritAll,
updateMGrammar, updateModule, replaceJudgements, addFlag,
addOpenQualif, flagsModule, allFlags, mapModules,
OpenSpec(..),
ModuleStatus(..),
openedModule, depPathModule, allDepsModule, partOfGrammar,
allExtends, allExtendSpecs, allExtendsPlus, allExtensions,
searchPathModule, addModule,
emptyMGrammar, emptyModInfo,
IdentM(..),
abstractOfConcrete, abstractModOfConcrete,
lookupModule, lookupModuleType, lookupInfo,
lookupPosition, ppPosition,
isModAbs, isModRes, isModCnc,
sameMType, isCompilableModule, isCompleteModule,
allAbstracts, greatestAbstract, allResources,
greatestResource, allConcretes, allConcreteModules
) where
MGrammar(..), ModInfo(..), ModuleType(..),
MInclude (..),
extends, isInherited,inheritAll,
updateMGrammar, updateModule, replaceJudgements, addFlag,
addOpenQualif, flagsModule, allFlags, mapModules,
OpenSpec(..),
ModuleStatus(..),
openedModule, depPathModule, allDepsModule, partOfGrammar,
allExtends, allExtendSpecs, allExtendsPlus, allExtensions,
searchPathModule, addModule,
emptyMGrammar, emptyModInfo,
abstractOfConcrete, abstractModOfConcrete,
lookupModule, lookupModuleType, lookupInfo,
lookupPosition, ppPosition,
isModAbs, isModRes, isModCnc,
sameMType, isCompilableModule, isCompleteModule,
allAbstracts, greatestAbstract, allResources,
greatestResource, allConcretes, allConcreteModules
) where
import GF.Infra.Ident
import GF.Infra.Option
import GF.Data.Operations
import Data.List
import qualified Data.Map as Map
import Text.PrettyPrint
-- AR 29/4/2003
@@ -53,95 +53,95 @@ import Text.PrettyPrint
-- The parameters tell what kind of data is involved.
-- Invariant: modules are stored in dependency order
newtype MGrammar i a = MGrammar {modules :: [(i,ModInfo i a)]}
newtype MGrammar a = MGrammar {modules :: [(Ident,ModInfo a)]}
deriving Show
data ModInfo i a = ModInfo {
mtype :: ModuleType i ,
mstatus :: ModuleStatus ,
data ModInfo a = ModInfo {
mtype :: ModuleType,
mstatus :: ModuleStatus,
flags :: Options,
extend :: [(i,MInclude i)],
mwith :: Maybe (i,MInclude i,[(i,i)]),
opens :: [OpenSpec i] ,
mexdeps :: [i] ,
jments :: BinTree i a ,
positions :: BinTree i (String,(Int,Int)) -- file, first line, last line
extend :: [(Ident,MInclude)],
mwith :: Maybe (Ident,MInclude,[(Ident,Ident)]),
opens :: [OpenSpec],
mexdeps :: [Ident],
jments :: Map.Map Ident a,
positions :: Map.Map Ident (String,(Int,Int)) -- file, first line, last line
}
deriving Show
-- | encoding the type of the module
data ModuleType i =
data ModuleType =
MTAbstract
| MTResource
| MTConcrete i
-- ^ up to this, also used in GFC. Below, source only.
| MTConcrete Ident
-- ^ up to this, also used in GFO. Below, source only.
| MTInterface
| MTInstance i
deriving (Eq,Ord,Show)
| MTInstance Ident
deriving (Eq,Show)
data MInclude i = MIAll | MIOnly [i] | MIExcept [i]
deriving (Eq,Ord,Show)
data MInclude = MIAll | MIOnly [Ident] | MIExcept [Ident]
deriving (Eq,Show)
extends :: ModInfo i a -> [i]
extends :: ModInfo a -> [Ident]
extends = map fst . extend
isInherited :: Eq i => MInclude i -> i -> Bool
isInherited :: MInclude -> Ident -> Bool
isInherited c i = case c of
MIAll -> True
MIOnly is -> elem i is
MIExcept is -> notElem i is
inheritAll :: i -> (i,MInclude i)
inheritAll :: Ident -> (Ident,MInclude)
inheritAll i = (i,MIAll)
-- destructive update
-- | dep order preserved since old cannot depend on new
updateMGrammar :: Ord i => MGrammar i a -> MGrammar i a -> MGrammar i a
updateMGrammar old new = MGrammar $
updateMGrammar :: MGrammar a -> MGrammar a -> MGrammar a
updateMGrammar old new = MGrammar $
[(i,m) | (i,m) <- os, notElem i (map fst ns)] ++ ns
where
os = modules old
ns = modules new
updateModule :: Ord i => ModInfo i t -> i -> t -> ModInfo i t
updateModule :: ModInfo t -> Ident -> t -> ModInfo t
updateModule (ModInfo mt ms fs me mw ops med js ps) i t = ModInfo mt ms fs me mw ops med (updateTree (i,t) js) ps
replaceJudgements :: ModInfo i t -> BinTree i t -> ModInfo i t
replaceJudgements :: ModInfo t -> Map.Map Ident t -> ModInfo t
replaceJudgements (ModInfo mt ms fs me mw ops med _ ps) js = ModInfo mt ms fs me mw ops med js ps
addOpenQualif :: i -> i -> ModInfo i t -> ModInfo i t
addOpenQualif :: Ident -> Ident -> ModInfo t -> ModInfo t
addOpenQualif i j (ModInfo mt ms fs me mw ops med js ps) = ModInfo mt ms fs me mw (OQualif i j : ops) med js ps
addFlag :: Options -> ModInfo i t -> ModInfo i t
addFlag :: Options -> ModInfo t -> ModInfo t
addFlag f mo = mo {flags = flags mo `addOptions` f}
flagsModule :: (i,ModInfo i a) -> Options
flagsModule :: (Ident,ModInfo a) -> Options
flagsModule (_,mi) = flags mi
allFlags :: MGrammar i a -> Options
allFlags :: MGrammar a -> Options
allFlags gr = concatOptions [flags m | (_,m) <- modules gr]
mapModules :: (ModInfo i a -> ModInfo i a) -> MGrammar i a -> MGrammar i a
mapModules :: (ModInfo a -> ModInfo a) -> MGrammar a -> MGrammar a
mapModules f (MGrammar ms) = MGrammar (map (onSnd f) ms)
data OpenSpec i =
OSimple i
| OQualif i i
deriving (Eq,Ord,Show)
data OpenSpec =
OSimple Ident
| OQualif Ident Ident
deriving (Eq,Show)
data ModuleStatus =
MSComplete
| MSIncomplete
deriving (Eq,Ord,Show)
openedModule :: OpenSpec i -> i
openedModule :: OpenSpec -> Ident
openedModule o = case o of
OSimple m -> m
OQualif _ m -> m
-- | initial dependency list
depPathModule :: Ord i => ModInfo i a -> [OpenSpec i]
depPathModule :: ModInfo a -> [OpenSpec]
depPathModule m = fors m ++ exts m ++ opens m
where
fors m =
@@ -152,7 +152,7 @@ depPathModule m = fors m ++ exts m ++ opens m
exts m = map OSimple (extends m)
-- | all dependencies
allDepsModule :: Ord i => MGrammar i a -> ModInfo i a -> [OpenSpec i]
allDepsModule :: MGrammar a -> ModInfo a -> [OpenSpec]
allDepsModule gr m = iterFix add os0 where
os0 = depPathModule m
add os = [m | o <- os, Just n <- [lookup (openedModule o) mods],
@@ -160,14 +160,14 @@ allDepsModule gr m = iterFix add os0 where
mods = modules gr
-- | select just those modules that a given one depends on, including itself
partOfGrammar :: Ord i => MGrammar i a -> (i,ModInfo i a) -> MGrammar i a
partOfGrammar :: MGrammar a -> (Ident,ModInfo a) -> MGrammar a
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, without restricts
allExtends :: (Show i,Ord i) => MGrammar i a -> i -> [i]
allExtends :: MGrammar a -> Ident -> [Ident]
allExtends gr i =
case lookupModule gr i of
Ok m -> case extends m of
@@ -176,7 +176,7 @@ allExtends gr i =
_ -> []
-- | all modules that a module extends, directly or indirectly, with restricts
allExtendSpecs :: (Show i,Ord i) => MGrammar i a -> i -> [(i,MInclude i)]
allExtendSpecs :: MGrammar a -> Ident -> [(Ident,MInclude)]
allExtendSpecs gr i =
case lookupModule gr i of
Ok m -> case extend m of
@@ -185,7 +185,7 @@ allExtendSpecs gr i =
_ -> []
-- | this plus that an instance extends its interface
allExtendsPlus :: (Show i,Ord i) => MGrammar i a -> i -> [i]
allExtendsPlus :: MGrammar a -> Ident -> [Ident]
allExtendsPlus gr i =
case lookupModule gr i of
Ok m -> i : concatMap (allExtendsPlus gr) (exts m)
@@ -194,7 +194,7 @@ allExtendsPlus gr i =
exts m = extends m ++ [j | MTInstance j <- [mtype m]]
-- | conversely: all modules that extend a given module, incl. instances of interface
allExtensions :: (Show i,Ord i) => MGrammar i a -> i -> [i]
allExtensions :: MGrammar a -> Ident -> [Ident]
allExtensions gr i =
case lookupModule gr i of
Ok m -> let es = exts i in es ++ concatMap (allExtensions gr) es
@@ -205,36 +205,29 @@ allExtensions gr i =
mods = modules gr
-- | initial search path: the nonqualified dependencies
searchPathModule :: Ord i => ModInfo i a -> [i]
searchPathModule :: ModInfo a -> [Ident]
searchPathModule m = [i | OSimple i <- depPathModule m]
-- | a new module can safely be added to the end, since nothing old can depend on it
addModule :: Ord i =>
MGrammar i a -> i -> ModInfo i a -> MGrammar i a
addModule :: MGrammar a -> Ident -> ModInfo a -> MGrammar a
addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)])
emptyMGrammar :: MGrammar i a
emptyMGrammar :: MGrammar a
emptyMGrammar = MGrammar []
emptyModInfo :: ModInfo i a
emptyModInfo :: ModInfo a
emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] emptyBinTree emptyBinTree
-- | we store the module type with the identifier
data IdentM i = IdentM {
identM :: i ,
typeM :: ModuleType i
}
deriving (Eq,Ord,Show)
abstractOfConcrete :: (Show i, Eq i) => MGrammar i a -> i -> Err i
abstractOfConcrete :: MGrammar a -> Ident -> Err Ident
abstractOfConcrete gr c = do
n <- lookupModule gr c
case mtype n of
MTConcrete a -> return a
_ -> Bad $ "expected concrete" +++ show c
_ -> Bad $ render (text "expected concrete" <+> ppIdent c)
abstractModOfConcrete :: (Show i, Eq i) =>
MGrammar i a -> i -> Err (ModInfo i a)
abstractModOfConcrete :: MGrammar a -> Ident -> Err (ModInfo a)
abstractModOfConcrete gr c = do
a <- abstractOfConcrete gr c
lookupModule gr a
@@ -244,106 +237,110 @@ abstractModOfConcrete gr c = do
--- canonFileName s = prt s ++ ".gfc"
lookupModule :: (Show i,Eq i) => MGrammar i a -> i -> Err (ModInfo i a)
lookupModule :: MGrammar a -> Ident -> Err (ModInfo a)
lookupModule gr m = case lookup m (modules gr) of
Just i -> return i
_ -> Bad $ "unknown module" +++ show m
+++ "among" +++ unwords (map (show . fst) (modules gr)) ---- debug
Just i -> return i
Nothing -> Bad $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr)))
lookupModuleType :: (Show i,Eq i) => MGrammar i a -> i -> Err (ModuleType i)
lookupModuleType :: MGrammar a -> Ident -> Err ModuleType
lookupModuleType gr m = do
mi <- lookupModule gr m
return $ mtype mi
lookupInfo :: (Show i, Ord i) => ModInfo i a -> i -> Err a
lookupInfo mo i = lookupTree show i (jments mo)
lookupInfo :: ModInfo a -> Ident -> Err a
lookupInfo mo i = lookupTree showIdent i (jments mo)
lookupPosition :: (Show i, Ord i) => ModInfo i a -> i -> Err (String,(Int,Int))
lookupPosition mo i = lookupTree show i (positions mo)
lookupPosition :: ModInfo a -> Ident -> Err (String,(Int,Int))
lookupPosition mo i = lookupTree showIdent i (positions mo)
ppPosition :: (Show i, Ord i) => ModInfo i a -> i -> Doc
ppPosition :: ModInfo a -> Ident -> Doc
ppPosition mo i = case lookupPosition mo i of
Ok (f,(b,e)) | b == e -> text "in" <+> text f <> text ", line" <+> int b
| otherwise -> text "in" <+> text f <> text ", lines" <+> int b <> text "-" <> int e
_ -> empty
isModAbs :: ModInfo i a -> Bool
isModAbs m = case mtype m of
MTAbstract -> True
---- MTUnion t -> isModAbs t
_ -> False
isModAbs :: ModInfo a -> Bool
isModAbs m =
case mtype m of
MTAbstract -> True
_ -> False
isModRes :: ModInfo i a -> Bool
isModRes m = case mtype m of
MTResource -> True
MTInterface -> True ---
MTInstance _ -> True
_ -> False
isModRes :: ModInfo a -> Bool
isModRes m =
case mtype m of
MTResource -> True
MTInterface -> True ---
MTInstance _ -> True
_ -> False
isModCnc :: ModInfo i a -> Bool
isModCnc m = case mtype m of
MTConcrete _ -> True
_ -> False
isModCnc :: ModInfo a -> Bool
isModCnc m =
case mtype m of
MTConcrete _ -> True
_ -> False
sameMType :: Eq i => ModuleType i -> ModuleType i -> Bool
sameMType m n = case (n,m) of
(MTConcrete _, MTConcrete _) -> True
sameMType :: ModuleType -> ModuleType -> Bool
sameMType m n =
case (n,m) of
(MTConcrete _, MTConcrete _) -> True
(MTInstance _, MTInstance _) -> True
(MTInstance _, MTResource) -> True
(MTInstance _, MTConcrete _) -> True
(MTInstance _, MTInstance _) -> True
(MTInstance _, MTResource) -> True
(MTInstance _, MTConcrete _) -> True
(MTInterface, MTInstance _) -> True
(MTInterface, MTResource) -> True -- for reuse
(MTInterface, MTAbstract) -> True -- for reuse
(MTInterface, MTConcrete _) -> True -- for reuse
(MTInterface, MTInstance _) -> True
(MTInterface, MTResource) -> True -- for reuse
(MTInterface, MTAbstract) -> True -- for reuse
(MTInterface, MTConcrete _) -> True -- for reuse
(MTResource, MTInstance _) -> True
(MTResource, MTConcrete _) -> True -- for reuse
(MTResource, MTInstance _) -> True
(MTResource, MTConcrete _) -> True -- for reuse
_ -> m == n
_ -> m == n
-- | don't generate code for interfaces and for incomplete modules
isCompilableModule :: ModInfo i a -> Bool
isCompilableModule :: ModInfo a -> Bool
isCompilableModule m =
case mtype m of
MTInterface -> False
_ -> mstatus m == MSComplete
-- | interface and "incomplete M" are not complete
isCompleteModule :: (Eq i) => ModInfo i a -> Bool
isCompleteModule :: ModInfo a -> Bool
isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
-- | all abstract modules sorted from least to most dependent
allAbstracts :: (Ord i, Show i) => MGrammar i a -> [i]
allAbstracts :: MGrammar a -> [Ident]
allAbstracts gr =
case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of
Left is -> is
Right cycles -> error $ "Cyclic abstract modules: " ++ show cycles
Left is -> is
Right cycles -> error $ render (text "Cyclic abstract modules:" <+> vcat (map (hsep . map ppIdent) cycles))
-- | the last abstract in dependency order (head of list)
greatestAbstract :: (Ord i, Show i) => MGrammar i a -> Maybe i
greatestAbstract gr = case allAbstracts gr of
[] -> Nothing
as -> return $ last as
greatestAbstract :: MGrammar a -> Maybe Ident
greatestAbstract gr =
case allAbstracts gr of
[] -> Nothing
as -> return $ last as
-- | all resource modules
allResources :: MGrammar i a -> [i]
allResources :: MGrammar a -> [Ident]
allResources gr = [i | (i,m) <- modules gr, isModRes m || isModCnc m]
-- | the greatest resource in dependency order
greatestResource :: MGrammar i a -> Maybe i
greatestResource gr = case allResources gr of
[] -> Nothing
a -> return $ head a ---- why not last as in Abstract? works though AR 24/5/2008
greatestResource :: MGrammar a -> Maybe Ident
greatestResource gr =
case allResources gr of
[] -> Nothing
a -> return $ head a ---- why not last as in Abstract? works though AR 24/5/2008
-- | all concretes for a given abstract
allConcretes :: Eq i => MGrammar i a -> i -> [i]
allConcretes gr a =
allConcretes :: MGrammar a -> Ident -> [Ident]
allConcretes gr a =
[i | (i, m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m]
-- | all concrete modules for any abstract
allConcreteModules :: Eq i => MGrammar i a -> [i]
allConcreteModules gr =
allConcreteModules :: MGrammar a -> [Ident]
allConcreteModules gr =
[i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]