diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index 364b54bd3..76b16260d 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -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. -- 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 exts = M.allExtends gr c ops = if isSingle diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index 30616b4cb..b3f3426da 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -57,7 +57,7 @@ renameModule ms (name,mo) = checkIn (text "renaming module" <+> ppIdent name) $ js2 <- checkMap (renameInfo mo status) js1 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 @@ -112,7 +112,7 @@ info2status mq (c,i) = case i of AnyInd False m -> maybe Cn (const (Q m)) 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 OSimple i -> mapTree (info2status (Just i)) 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 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)) self2status :: Ident -> SourceModInfo -> StatusTree diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs index fbad5ac7e..7e56492cb 100644 --- a/src/compiler/GF/Grammar/Binary.hs +++ b/src/compiler/GF/Grammar/Binary.hs @@ -26,16 +26,16 @@ instance Binary Ident where then return identW 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 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) get = do (mtype,mstatus,flags,extend,mwith,opens,med,jments,positions) <- get 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 MTResource = putWord8 2 put (MTConcrete i) = putWord8 3 >> put i @@ -50,7 +50,7 @@ instance (Binary i) => Binary (ModuleType i) where 5 -> get >>= return . MTInstance _ -> decodingError -instance (Binary i) => Binary (MInclude i) where +instance Binary MInclude where put MIAll = putWord8 0 put (MIOnly xs) = putWord8 1 >> put xs put (MIExcept xs) = putWord8 2 >> put xs @@ -61,7 +61,7 @@ instance (Binary i) => Binary (MInclude i) where 2 -> fmap MIExcept get _ -> decodingError -instance Binary i => Binary (OpenSpec i) where +instance Binary OpenSpec where put (OSimple i) = putWord8 0 >> put i put (OQualif i j) = putWord8 1 >> put (i,j) get = do tag <- getWord8 diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index 8d1468d9d..e0ca01341 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -53,11 +53,11 @@ import GF.Data.Operations import qualified Data.ByteString.Char8 as BS -- | grammar as presented to the compiler -type SourceGrammar = MGrammar Ident Info +type SourceGrammar = MGrammar Info emptySourceGrammar = MGrammar [] -type SourceModInfo = ModInfo Ident Info +type SourceModInfo = ModInfo Info type SourceModule = (Ident, SourceModInfo) diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs index 074f0c5ec..d56c1ee30 100644 --- a/src/compiler/GF/Grammar/Lookup.hs +++ b/src/compiler/GF/Grammar/Lookup.hs @@ -55,7 +55,7 @@ lookupIdent c t = Ok v -> return v 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) lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y index 320053674..ef4a5d84b 100644 --- a/src/compiler/GF/Grammar/Parser.y +++ b/src/compiler/GF/Grammar/Parser.y @@ -135,7 +135,7 @@ ComplMod : {- empty -} { MSComplete } | 'incomplete' { MSIncomplete } -ModType :: { (ModuleType Ident,Ident) } +ModType :: { (ModuleType,Ident) } ModType : 'abstract' Ident { (MTAbstract, $2) } | 'resource' Ident { (MTResource, $2) } @@ -143,9 +143,9 @@ ModType | 'concrete' Ident 'of' Ident { (MTConcrete $4, $2) } | 'instance' Ident 'of' Ident { (MTInstance $4, $2) } -ModHeaderBody :: { ( [(Ident,MInclude Ident)] - , Maybe (Ident,MInclude Ident,[(Ident,Ident)]) - , [OpenSpec Ident] +ModHeaderBody :: { ( [(Ident,MInclude)] + , Maybe (Ident,MInclude,[(Ident,Ident)]) + , [OpenSpec] ) } ModHeaderBody : 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), []) } | ModOpen { ([], Nothing, $1) } -ModOpen :: { [OpenSpec Ident] } +ModOpen :: { [OpenSpec] } ModOpen : { [] } | 'open' ListOpen { $2 } -ModBody :: { ( [(Ident,MInclude Ident)] - , Maybe (Ident,MInclude Ident,[(Ident,Ident)]) - , Maybe ([OpenSpec Ident],[(Ident,SrcSpan,Info)],Options) +ModBody :: { ( [(Ident,MInclude)] + , Maybe (Ident,MInclude,[(Ident,Ident)]) + , Maybe ([OpenSpec],[(Ident,SrcSpan,Info)],Options) ) } ModBody : ListIncluded '**' Included 'with' ListInst '**' ModContent { ($1, Just (fst $3,snd $3,$5), Just $7) } @@ -175,7 +175,7 @@ ModBody | ModContent { ([], Nothing, Just $1) } | ModBody ';' { $1 } -ModContent :: { ([OpenSpec Ident],[(Ident,SrcSpan,Info)],Options) } +ModContent :: { ([OpenSpec],[(Ident,SrcSpan,Info)],Options) } ModContent : '{' 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]) } @@ -185,12 +185,12 @@ ListTopDef : {- empty -} { [] } | TopDef ListTopDef { $1 : $2 } -ListOpen :: { [OpenSpec Ident] } +ListOpen :: { [OpenSpec] } ListOpen : Open { [$1] } | Open ',' ListOpen { $1 : $3 } -Open :: { OpenSpec Ident } +Open :: { OpenSpec } Open : Ident { OSimple $1 } | '(' Ident '=' Ident ')' { OQualif $2 $4 } @@ -204,12 +204,12 @@ Inst :: { (Ident,Ident) } Inst : '(' Ident '=' Ident ')' { ($2,$4) } -ListIncluded :: { [(Ident,MInclude Ident)] } +ListIncluded :: { [(Ident,MInclude)] } ListIncluded : Included { [$1] } | Included ',' ListIncluded { $1 : $3 } -Included :: { (Ident,MInclude Ident) } +Included :: { (Ident,MInclude) } Included : Ident { ($1,MIAll ) } | Ident '[' ListIdent ']' { ($1,MIOnly $3) } diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index 06cac9705..996a7a807 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -9,7 +9,6 @@ module GF.Grammar.Printer ( TermPrintQual(..) - , ppIdent , ppLabel , ppModule , ppJudgement @@ -256,8 +255,6 @@ ppDDecl q (_,id,typ) | id == identW = ppTerm q 6 typ | otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ) -ppIdent = text . showIdent - ppQIdent q m id = case q of Qualified -> ppIdent m <> char '.' <> ppIdent id diff --git a/src/compiler/GF/Infra/Dependencies.hs b/src/compiler/GF/Infra/Dependencies.hs index af2088711..9a870b139 100644 --- a/src/compiler/GF/Infra/Dependencies.hs +++ b/src/compiler/GF/Infra/Dependencies.hs @@ -35,7 +35,7 @@ prDepGraph deps = unlines $ [ "ed" -> "style = \"dotted\"" data ModDeps = ModDeps { - modtype :: ModuleType Ident, + modtype :: ModuleType, ofs :: [Ident], extendeds :: [Ident], openeds :: [Ident], diff --git a/src/compiler/GF/Infra/Ident.hs b/src/compiler/GF/Infra/Ident.hs index efe6f9261..967945be9 100644 --- a/src/compiler/GF/Infra/Ident.hs +++ b/src/compiler/GF/Infra/Ident.hs @@ -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 diff --git a/src/compiler/GF/Infra/Modules.hs b/src/compiler/GF/Infra/Modules.hs index 0710b8f40..40941c398 100644 --- a/src/compiler/GF/Infra/Modules.hs +++ b/src/compiler/GF/Infra/Modules.hs @@ -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]