refactor GF.Infra.Modules for better error messages

This commit is contained in:
krasimir
2010-01-31 15:54:25 +00:00
parent c93e406997
commit 4485e97181
10 changed files with 159 additions and 162 deletions

View File

@@ -570,7 +570,7 @@ prTrace tr n = trace (render (text "-- OBSERVE" <+> A.ppTerm Unqualified 0 tr <
-- | this function finds out what modules are really needed in the canonical gr. -- | this function finds out what modules are really needed in the canonical gr.
-- its argument is typically a concrete module name -- its argument is typically a concrete module name
requiredCanModules :: (Ord i, Show i) => Bool -> M.MGrammar i a -> i -> [i] requiredCanModules :: Bool -> M.MGrammar a -> Ident -> [Ident]
requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where
exts = M.allExtends gr c exts = M.allExtends gr c
ops = if isSingle ops = if isSingle

View File

@@ -57,7 +57,7 @@ renameModule ms (name,mo) = checkIn (text "renaming module" <+> ppIdent name) $
js2 <- checkMap (renameInfo mo status) js1 js2 <- checkMap (renameInfo mo status) js1
return (name, mo {opens = map forceQualif (opens mo), jments = js2}) return (name, mo {opens = map forceQualif (opens mo), jments = js2})
type Status = (StatusTree, [(OpenSpec Ident, StatusTree)]) type Status = (StatusTree, [(OpenSpec, StatusTree)])
type StatusTree = BinTree Ident StatusInfo type StatusTree = BinTree Ident StatusInfo
@@ -112,7 +112,7 @@ info2status mq (c,i) = case i of
AnyInd False m -> maybe Cn (const (Q m)) mq AnyInd False m -> maybe Cn (const (Q m)) mq
_ -> maybe Cn Q mq _ -> maybe Cn Q mq
tree2status :: OpenSpec Ident -> BinTree Ident Info -> BinTree Ident StatusInfo tree2status :: OpenSpec -> BinTree Ident Info -> BinTree Ident StatusInfo
tree2status o = case o of tree2status o = case o of
OSimple i -> mapTree (info2status (Just i)) OSimple i -> mapTree (info2status (Just i))
OQualif i j -> mapTree (info2status (Just j)) OQualif i j -> mapTree (info2status (Just j))
@@ -127,7 +127,7 @@ buildStatus gr c mo = let mo' = self2status c mo in do
then (emptyBinTree, reverse sts) -- the module itself does not define any names then (emptyBinTree, reverse sts) -- the module itself does not define any names
else (mo',reverse sts) -- so the empty ident is not needed else (mo',reverse sts) -- so the empty ident is not needed
modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree) modInfo2status :: (OpenSpec,SourceModInfo) -> (OpenSpec, StatusTree)
modInfo2status (o,mo) = (o,tree2status o (jments mo)) modInfo2status (o,mo) = (o,tree2status o (jments mo))
self2status :: Ident -> SourceModInfo -> StatusTree self2status :: Ident -> SourceModInfo -> StatusTree

View File

@@ -26,16 +26,16 @@ instance Binary Ident where
then return identW then return identW
else return (identC bs) else return (identC bs)
instance (Ord i, Binary i, Binary a) => Binary (MGrammar i a) where instance Binary a => Binary (MGrammar a) where
put (MGrammar ms) = put ms put (MGrammar ms) = put ms
get = fmap MGrammar get get = fmap MGrammar get
instance (Ord i, Binary i, Binary a) => Binary (ModInfo i a) where instance Binary a => Binary (ModInfo a) where
put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,jments mi,positions mi) put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,jments mi,positions mi)
get = do (mtype,mstatus,flags,extend,mwith,opens,med,jments,positions) <- get get = do (mtype,mstatus,flags,extend,mwith,opens,med,jments,positions) <- get
return (ModInfo mtype mstatus flags extend mwith opens med jments positions) return (ModInfo mtype mstatus flags extend mwith opens med jments positions)
instance (Binary i) => Binary (ModuleType i) where instance Binary ModuleType where
put MTAbstract = putWord8 0 put MTAbstract = putWord8 0
put MTResource = putWord8 2 put MTResource = putWord8 2
put (MTConcrete i) = putWord8 3 >> put i put (MTConcrete i) = putWord8 3 >> put i
@@ -50,7 +50,7 @@ instance (Binary i) => Binary (ModuleType i) where
5 -> get >>= return . MTInstance 5 -> get >>= return . MTInstance
_ -> decodingError _ -> decodingError
instance (Binary i) => Binary (MInclude i) where instance Binary MInclude where
put MIAll = putWord8 0 put MIAll = putWord8 0
put (MIOnly xs) = putWord8 1 >> put xs put (MIOnly xs) = putWord8 1 >> put xs
put (MIExcept xs) = putWord8 2 >> put xs put (MIExcept xs) = putWord8 2 >> put xs
@@ -61,7 +61,7 @@ instance (Binary i) => Binary (MInclude i) where
2 -> fmap MIExcept get 2 -> fmap MIExcept get
_ -> decodingError _ -> decodingError
instance Binary i => Binary (OpenSpec i) where instance Binary OpenSpec where
put (OSimple i) = putWord8 0 >> put i put (OSimple i) = putWord8 0 >> put i
put (OQualif i j) = putWord8 1 >> put (i,j) put (OQualif i j) = putWord8 1 >> put (i,j)
get = do tag <- getWord8 get = do tag <- getWord8

View File

@@ -53,11 +53,11 @@ import GF.Data.Operations
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
-- | grammar as presented to the compiler -- | grammar as presented to the compiler
type SourceGrammar = MGrammar Ident Info type SourceGrammar = MGrammar Info
emptySourceGrammar = MGrammar [] emptySourceGrammar = MGrammar []
type SourceModInfo = ModInfo Ident Info type SourceModInfo = ModInfo Info
type SourceModule = (Ident, SourceModInfo) type SourceModule = (Ident, SourceModInfo)

View File

@@ -55,7 +55,7 @@ lookupIdent c t =
Ok v -> return v Ok v -> return v
Bad _ -> Bad ("unknown identifier" +++ showIdent c) Bad _ -> Bad ("unknown identifier" +++ showIdent c)
lookupIdentInfo :: ModInfo Ident a -> Ident -> Err a lookupIdentInfo :: ModInfo a -> Ident -> Err a
lookupIdentInfo mo i = lookupIdent i (jments mo) lookupIdentInfo mo i = lookupIdent i (jments mo)
lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term

View File

@@ -135,7 +135,7 @@ ComplMod
: {- empty -} { MSComplete } : {- empty -} { MSComplete }
| 'incomplete' { MSIncomplete } | 'incomplete' { MSIncomplete }
ModType :: { (ModuleType Ident,Ident) } ModType :: { (ModuleType,Ident) }
ModType ModType
: 'abstract' Ident { (MTAbstract, $2) } : 'abstract' Ident { (MTAbstract, $2) }
| 'resource' Ident { (MTResource, $2) } | 'resource' Ident { (MTResource, $2) }
@@ -143,9 +143,9 @@ ModType
| 'concrete' Ident 'of' Ident { (MTConcrete $4, $2) } | 'concrete' Ident 'of' Ident { (MTConcrete $4, $2) }
| 'instance' Ident 'of' Ident { (MTInstance $4, $2) } | 'instance' Ident 'of' Ident { (MTInstance $4, $2) }
ModHeaderBody :: { ( [(Ident,MInclude Ident)] ModHeaderBody :: { ( [(Ident,MInclude)]
, Maybe (Ident,MInclude Ident,[(Ident,Ident)]) , Maybe (Ident,MInclude,[(Ident,Ident)])
, [OpenSpec Ident] , [OpenSpec]
) } ) }
ModHeaderBody ModHeaderBody
: ListIncluded '**' Included 'with' ListInst '**' ModOpen { ($1, Just (fst $3,snd $3,$5), $7) } : ListIncluded '**' Included 'with' ListInst '**' ModOpen { ($1, Just (fst $3,snd $3,$5), $7) }
@@ -156,14 +156,14 @@ ModHeaderBody
| Included 'with' ListInst { ([], Just (fst $1,snd $1,$3), []) } | Included 'with' ListInst { ([], Just (fst $1,snd $1,$3), []) }
| ModOpen { ([], Nothing, $1) } | ModOpen { ([], Nothing, $1) }
ModOpen :: { [OpenSpec Ident] } ModOpen :: { [OpenSpec] }
ModOpen ModOpen
: { [] } : { [] }
| 'open' ListOpen { $2 } | 'open' ListOpen { $2 }
ModBody :: { ( [(Ident,MInclude Ident)] ModBody :: { ( [(Ident,MInclude)]
, Maybe (Ident,MInclude Ident,[(Ident,Ident)]) , Maybe (Ident,MInclude,[(Ident,Ident)])
, Maybe ([OpenSpec Ident],[(Ident,SrcSpan,Info)],Options) , Maybe ([OpenSpec],[(Ident,SrcSpan,Info)],Options)
) } ) }
ModBody ModBody
: ListIncluded '**' Included 'with' ListInst '**' ModContent { ($1, Just (fst $3,snd $3,$5), Just $7) } : ListIncluded '**' Included 'with' ListInst '**' ModContent { ($1, Just (fst $3,snd $3,$5), Just $7) }
@@ -175,7 +175,7 @@ ModBody
| ModContent { ([], Nothing, Just $1) } | ModContent { ([], Nothing, Just $1) }
| ModBody ';' { $1 } | ModBody ';' { $1 }
ModContent :: { ([OpenSpec Ident],[(Ident,SrcSpan,Info)],Options) } ModContent :: { ([OpenSpec],[(Ident,SrcSpan,Info)],Options) }
ModContent ModContent
: '{' ListTopDef '}' { ([],[d | Left ds <- $2, d <- ds],concatOptions [o | Right o <- $2]) } : '{' ListTopDef '}' { ([],[d | Left ds <- $2, d <- ds],concatOptions [o | Right o <- $2]) }
| 'open' ListOpen 'in' '{' ListTopDef '}' { ($2,[d | Left ds <- $5, d <- ds],concatOptions [o | Right o <- $5]) } | 'open' ListOpen 'in' '{' ListTopDef '}' { ($2,[d | Left ds <- $5, d <- ds],concatOptions [o | Right o <- $5]) }
@@ -185,12 +185,12 @@ ListTopDef
: {- empty -} { [] } : {- empty -} { [] }
| TopDef ListTopDef { $1 : $2 } | TopDef ListTopDef { $1 : $2 }
ListOpen :: { [OpenSpec Ident] } ListOpen :: { [OpenSpec] }
ListOpen ListOpen
: Open { [$1] } : Open { [$1] }
| Open ',' ListOpen { $1 : $3 } | Open ',' ListOpen { $1 : $3 }
Open :: { OpenSpec Ident } Open :: { OpenSpec }
Open Open
: Ident { OSimple $1 } : Ident { OSimple $1 }
| '(' Ident '=' Ident ')' { OQualif $2 $4 } | '(' Ident '=' Ident ')' { OQualif $2 $4 }
@@ -204,12 +204,12 @@ Inst :: { (Ident,Ident) }
Inst Inst
: '(' Ident '=' Ident ')' { ($2,$4) } : '(' Ident '=' Ident ')' { ($2,$4) }
ListIncluded :: { [(Ident,MInclude Ident)] } ListIncluded :: { [(Ident,MInclude)] }
ListIncluded ListIncluded
: Included { [$1] } : Included { [$1] }
| Included ',' ListIncluded { $1 : $3 } | Included ',' ListIncluded { $1 : $3 }
Included :: { (Ident,MInclude Ident) } Included :: { (Ident,MInclude) }
Included Included
: Ident { ($1,MIAll ) } : Ident { ($1,MIAll ) }
| Ident '[' ListIdent ']' { ($1,MIOnly $3) } | Ident '[' ListIdent ']' { ($1,MIOnly $3) }

View File

@@ -9,7 +9,6 @@
module GF.Grammar.Printer module GF.Grammar.Printer
( TermPrintQual(..) ( TermPrintQual(..)
, ppIdent
, ppLabel , ppLabel
, ppModule , ppModule
, ppJudgement , ppJudgement
@@ -256,8 +255,6 @@ ppDDecl q (_,id,typ)
| id == identW = ppTerm q 6 typ | id == identW = ppTerm q 6 typ
| otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ) | otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ)
ppIdent = text . showIdent
ppQIdent q m id = ppQIdent q m id =
case q of case q of
Qualified -> ppIdent m <> char '.' <> ppIdent id Qualified -> ppIdent m <> char '.' <> ppIdent id

View File

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

View File

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

View File

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