mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-05 17:22:51 -06:00
Reduced clutter in monadic code
+ Eliminated vairous ad-hoc coersion functions between specific monads (IO, Err, IOE, Check) in favor of more general lifting functions (liftIO, liftErr). + Generalized many basic monadic operations from specific monads to arbitrary monads in the appropriate class (MonadIO and/or ErrorMonad), thereby completely eliminating the need for lifting functions in lots of places. This can be considered a small step forward towards a cleaner compiler API and more malleable compiler code in general.
This commit is contained in:
hallgren
@@ -50,10 +50,10 @@ checkModule opts sgr mo@(m,mi) = do
|
||||
checkRestrictedInheritance sgr mo
|
||||
mo <- case mtype mi of
|
||||
MTConcrete a -> do let gr = prependModule sgr mo
|
||||
abs <- checkErr $ lookupModule gr a
|
||||
abs <- lookupModule gr a
|
||||
checkCompleteGrammar opts gr (a,abs) mo
|
||||
_ -> return mo
|
||||
infoss <- checkErr $ topoSortJments2 mo
|
||||
infoss <- topoSortJments2 mo
|
||||
foldM updateCheckInfos mo infoss
|
||||
where
|
||||
updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check
|
||||
@@ -246,7 +246,7 @@ checkInfo opts sgr (m,mo) c info = do
|
||||
|
||||
ResOverload os tysts -> chIn NoLoc "overloading" $ do
|
||||
tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts -- return explicit ones
|
||||
tysts0 <- checkErr $ lookupOverload gr (m,c) -- check against inherited ones too
|
||||
tysts0 <- lookupOverload gr (m,c) -- check against inherited ones too
|
||||
tysts1 <- mapM (uncurry $ flip (checkLType gr []))
|
||||
[(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
|
||||
--- this can only be a partial guarantee, since matching
|
||||
@@ -267,7 +267,7 @@ checkInfo opts sgr (m,mo) c info = do
|
||||
nest 2 (text "Happened in" <+> text cat <+> ppIdent c))
|
||||
|
||||
mkPar (f,co) = do
|
||||
vs <- checkErr $ liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
|
||||
vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
|
||||
return $ map (mkApp (QC (m,f))) vs
|
||||
|
||||
checkUniq xss = case xss of
|
||||
@@ -317,13 +317,13 @@ linTypeOfType cnc m typ = do
|
||||
let vars = mkRecType varLabel $ replicate n typeStr
|
||||
symb = argIdent n cat i
|
||||
rec <- if n==0 then return val else
|
||||
checkErr $ errIn (render (text "extending" $$
|
||||
errIn (render (text "extending" $$
|
||||
nest 2 (ppTerm Unqualified 0 vars) $$
|
||||
text "with" $$
|
||||
nest 2 (ppTerm Unqualified 0 val))) $
|
||||
plusRecType vars val
|
||||
return (Explicit,symb,rec)
|
||||
lookLin (_,c) = checks [ --- rather: update with defLinType ?
|
||||
checkErr (lookupLincat cnc m c) >>= computeLType cnc []
|
||||
lookupLincat cnc m c >>= computeLType cnc []
|
||||
,return defLinType
|
||||
]
|
||||
|
||||
@@ -23,10 +23,9 @@ import GF.Grammar.Predef
|
||||
import GF.Grammar.Lockfield (isLockLabel)
|
||||
import GF.Data.BacktrackM
|
||||
import GF.Data.Operations
|
||||
import GF.Infra.UseIO (IOE)
|
||||
import GF.Infra.UseIO (IOE,ePutStr,ePutStrLn)
|
||||
import GF.Data.Utilities (updateNthM) --updateNth
|
||||
import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues,ppL)
|
||||
import System.IO(hPutStr,hPutStrLn,stderr)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.List as List
|
||||
@@ -39,7 +38,6 @@ import Data.Array.Unboxed
|
||||
--import Data.Char (isDigit)
|
||||
import Control.Monad
|
||||
import Control.Monad.Identity
|
||||
import Control.Monad.Trans (liftIO)
|
||||
--import Control.Exception
|
||||
|
||||
----------------------------------------------------------------------
|
||||
@@ -48,7 +46,7 @@ import Control.Monad.Trans (liftIO)
|
||||
generatePMCFG :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule
|
||||
generatePMCFG opts sgr opath cmo@(cm,cmi) = do
|
||||
(seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr cenv opath am cm) Map.empty (jments cmi)
|
||||
when (verbAtLeast opts Verbose) $ liftIO $ hPutStrLn stderr ""
|
||||
when (verbAtLeast opts Verbose) $ ePutStrLn ""
|
||||
return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js})
|
||||
where
|
||||
cenv = resourceValues gr
|
||||
@@ -87,9 +85,9 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
|
||||
!funs_cnt = e-s+1
|
||||
in (prods_cnt,funs_cnt)
|
||||
|
||||
when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr ("\n+ "++showIdent id ++ " " ++ show (product (map catFactor pargs)))
|
||||
when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id ++ " " ++ show (product (map catFactor pargs)))
|
||||
seqs1 `seq` stats `seq` return ()
|
||||
when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr (" "++show stats)
|
||||
when (verbAtLeast opts Verbose) $ ePutStr (" "++show stats)
|
||||
return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg))
|
||||
where
|
||||
(ctxt,res,_) = err bug typeForm (lookupFunType gr am id)
|
||||
@@ -128,7 +126,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ linc
|
||||
|
||||
let pmcfg = getPMCFG pmcfgEnv2
|
||||
|
||||
when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr ("\n+ "++showIdent id++" "++show (catFactor pcat))
|
||||
when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" "++show (catFactor pcat))
|
||||
seqs2 `seq` pmcfg `seq` return (seqs2,GF.Grammar.CncCat mty mdef mref mprn (Just pmcfg))
|
||||
where
|
||||
addLindef lins (newCat', newArgs') env0 =
|
||||
|
||||
@@ -35,8 +35,6 @@ import GF.Grammar.Grammar
|
||||
import GF.Grammar.Binary
|
||||
|
||||
import Control.Monad
|
||||
--import Data.Char
|
||||
--import Data.List
|
||||
import Data.Maybe(isJust)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.Map as Map
|
||||
@@ -52,11 +50,11 @@ type ModEnv = Map.Map ModName (UTCTime,[ModName])
|
||||
|
||||
-- | Returns a list of all files to be compiled in topological order i.e.
|
||||
-- the low level (leaf) modules are first.
|
||||
getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath]
|
||||
getAllFiles :: (MonadIO m,ErrorMonad m) => Options -> [InitPath] -> ModEnv -> FileName -> m [FullPath]
|
||||
getAllFiles opts ps env file = do
|
||||
-- read module headers from all files recursively
|
||||
ds <- liftM reverse $ get [] [] (justModuleName file)
|
||||
ioeIO $ putIfVerb opts $ "all modules:" +++ show [name | (name,_,_,_,_,_) <- ds]
|
||||
liftIO $ putIfVerb opts $ "all modules:" +++ show [name | (name,_,_,_,_,_) <- ds]
|
||||
return $ paths ds
|
||||
where
|
||||
-- construct list of paths to read
|
||||
@@ -71,12 +69,12 @@ getAllFiles opts ps env file = do
|
||||
|
||||
-- | traverses the dependency graph and returns a topologicaly sorted
|
||||
-- list of ModuleInfo. An error is raised if there is circular dependency
|
||||
get :: [ModName] -- ^ keeps the current path in the dependency graph to avoid cycles
|
||||
{- get :: [ModName] -- ^ keeps the current path in the dependency graph to avoid cycles
|
||||
-> [ModuleInfo] -- ^ a list of already traversed modules
|
||||
-> ModName -- ^ the current module
|
||||
-> IOE [ModuleInfo] -- ^ the final
|
||||
-> IOE [ModuleInfo] -- ^ the final -}
|
||||
get trc ds name
|
||||
| name `elem` trc = ioeErr $ Bad $ "circular modules" +++ unwords trc
|
||||
| name `elem` trc = raise $ "circular modules" +++ unwords trc
|
||||
| (not . null) [n | (n,_,_,_,_,_) <- ds, name == n] --- file already read
|
||||
= return ds
|
||||
| otherwise = do
|
||||
@@ -91,20 +89,20 @@ getAllFiles opts ps env file = do
|
||||
|
||||
-- searches for module in the search path and if it is found
|
||||
-- returns 'ModuleInfo'. It fails if there is no such module
|
||||
findModule :: ModName -> IOE ModuleInfo
|
||||
--findModule :: ModName -> IOE ModuleInfo
|
||||
findModule name = do
|
||||
(file,gfTime,gfoTime) <- do
|
||||
mb_gfFile <- ioeIO $ getFilePath ps (gfFile name)
|
||||
mb_gfFile <- getFilePath ps (gfFile name)
|
||||
case mb_gfFile of
|
||||
Just gfFile -> do gfTime <- ioeIO $ toUTCTime `fmap` getModificationTime gfFile
|
||||
mb_gfoTime <- ioeIO $ catch (liftM Just $ toUTCTime `fmap` getModificationTime (gf2gfo opts gfFile))
|
||||
Just gfFile -> do gfTime <- liftIO $ toUTCTime `fmap` getModificationTime gfFile
|
||||
mb_gfoTime <- liftIO $ catch (liftM Just $ toUTCTime `fmap` getModificationTime (gf2gfo opts gfFile))
|
||||
(\_->return Nothing)
|
||||
return (gfFile, Just gfTime, mb_gfoTime)
|
||||
Nothing -> do mb_gfoFile <- ioeIO $ getFilePath (maybe id (:) (flag optGFODir opts) ps) (gfoFile name)
|
||||
Nothing -> do mb_gfoFile <- getFilePath (maybe id (:) (flag optGFODir opts) ps) (gfoFile name)
|
||||
case mb_gfoFile of
|
||||
Just gfoFile -> do gfoTime <- ioeIO $ toUTCTime `fmap` getModificationTime gfoFile
|
||||
Just gfoFile -> do gfoTime <- liftIO $ toUTCTime `fmap` getModificationTime gfoFile
|
||||
return (gfoFile, Nothing, Just gfoTime)
|
||||
Nothing -> ioeErr $ Bad (render (text "File" <+> text (gfFile name) <+> text "does not exist." $$
|
||||
Nothing -> raise (render (text "File" <+> text (gfFile name) <+> text "does not exist." $$
|
||||
text "searched in:" <+> vcat (map text ps)))
|
||||
|
||||
|
||||
@@ -114,21 +112,21 @@ getAllFiles opts ps env file = do
|
||||
(st,(mname,imps)) <-
|
||||
case st of
|
||||
CSEnv -> return (st, (name, maybe [] snd mb_envmod))
|
||||
CSRead -> do mb_mo <- ioeIO $ decodeModuleHeader ((if isGFO file then id else gf2gfo opts) file)
|
||||
CSRead -> do mb_mo <- liftIO $ decodeModuleHeader ((if isGFO file then id else gf2gfo opts) file)
|
||||
case mb_mo of
|
||||
Just mo -> return (st,importsOfModule mo)
|
||||
Nothing
|
||||
| isGFO file -> ioeErr $ Bad (file ++ " is compiled with different GF version and I can't find the source file")
|
||||
| otherwise -> do s <- ioeIO $ BS.readFile file
|
||||
| isGFO file -> raise (file ++ " is compiled with different GF version and I can't find the source file")
|
||||
| otherwise -> do s <- liftIO $ BS.readFile file
|
||||
case runP pModHeader s of
|
||||
Left (Pn l c,msg) -> ioeBad (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)
|
||||
Left (Pn l c,msg) -> raise (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)
|
||||
Right mo -> return (CSComp,importsOfModule mo)
|
||||
CSComp -> do s <- ioeIO $ BS.readFile file
|
||||
CSComp -> do s <- liftIO $ BS.readFile file
|
||||
case runP pModHeader s of
|
||||
Left (Pn l c,msg) -> ioeBad (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)
|
||||
Left (Pn l c,msg) -> raise (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)
|
||||
Right mo -> return (st,importsOfModule mo)
|
||||
ioeErr $ testErr (mname == name)
|
||||
("module name" +++ mname +++ "differs from file name" +++ name)
|
||||
testErr (mname == name)
|
||||
("module name" +++ mname +++ "differs from file name" +++ name)
|
||||
return (name,st,t,isJust gfTime,imps,dropFileName file)
|
||||
|
||||
isGFO :: FilePath -> Bool
|
||||
@@ -212,16 +210,16 @@ importsOfModule (m,mi) = (modName m,depModInfo mi [])
|
||||
modName = showIdent
|
||||
|
||||
-- | options can be passed to the compiler by comments in @--#@, in the main file
|
||||
getOptionsFromFile :: FilePath -> IOE Options
|
||||
getOptionsFromFile :: (MonadIO m,ErrorMonad m) => FilePath -> m Options
|
||||
getOptionsFromFile file = do
|
||||
s <- ioe $ catch (fmap Ok $ BS.readFile file)
|
||||
(\_ -> return (Bad $ "File " ++ file ++ " does not exist"))
|
||||
s <- handle (liftIO $ BS.readFile file)
|
||||
(\_ -> raise $ "File " ++ file ++ " does not exist")
|
||||
let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s
|
||||
fs = map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls
|
||||
ioeErr $ parseModuleOptions fs
|
||||
liftErr $ parseModuleOptions fs
|
||||
|
||||
getFilePath :: [FilePath] -> String -> IO (Maybe FilePath)
|
||||
getFilePath paths file = get paths
|
||||
getFilePath :: MonadIO m => [FilePath] -> String -> m (Maybe FilePath)
|
||||
getFilePath paths file = liftIO $ get paths
|
||||
where
|
||||
get [] = return Nothing
|
||||
get (p:ps) = do
|
||||
|
||||
@@ -45,7 +45,7 @@ import Text.PrettyPrint
|
||||
-- | this gives top-level access to renaming term input in the cc command
|
||||
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term
|
||||
renameSourceTerm g m t = do
|
||||
mi <- checkErr $ lookupModule g m
|
||||
mi <- lookupModule g m
|
||||
status <- buildStatus g (m,mi)
|
||||
renameTerm status [] t
|
||||
|
||||
@@ -72,12 +72,12 @@ renameIdentTerm' env@(act,imps) t0 =
|
||||
Cn c -> ident (\_ s -> checkError s) c
|
||||
Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
|
||||
Q (m',c) -> do
|
||||
m <- checkErr (lookupErr m' qualifs)
|
||||
m <- lookupErr m' qualifs
|
||||
f <- lookupTree showIdent c m
|
||||
return $ f c
|
||||
QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
|
||||
QC (m',c) -> do
|
||||
m <- checkErr (lookupErr m' qualifs)
|
||||
m <- lookupErr m' qualifs
|
||||
f <- lookupTree showIdent c m
|
||||
return $ f c
|
||||
_ -> return t0
|
||||
@@ -127,7 +127,7 @@ buildStatus :: SourceGrammar -> SourceModule -> Check Status
|
||||
buildStatus gr mo@(m,mi) = checkIn (ppLocation (msrc mi) NoLoc <> colon) $ do
|
||||
let gr1 = prependModule gr mo
|
||||
exts = [(OSimple m,mi) | (m,mi) <- allExtends gr1 m]
|
||||
ops <- checkErr $ mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi)
|
||||
ops <- mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi)
|
||||
let sts = map modInfo2status (exts++ops)
|
||||
return (if isModCnc mi
|
||||
then (emptyBinTree, reverse sts) -- the module itself does not define any names
|
||||
|
||||
@@ -19,7 +19,7 @@ writeTags opts gr file mo = do
|
||||
let imports = getImports opts gr mo
|
||||
locals = getLocalTags [] mo
|
||||
txt = unlines ((Set.toList . Set.fromList) (imports++locals))
|
||||
putPointE Normal opts (" write file" +++ file) $ ioeIO $ writeFile file txt
|
||||
putPointE Normal opts (" write file" +++ file) $ liftIO $ writeFile file txt
|
||||
|
||||
getLocalTags x (m,mi) =
|
||||
[showIdent i ++ "\t" ++ k ++ "\t" ++ l ++ "\t" ++ t
|
||||
|
||||
@@ -23,7 +23,7 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
|
||||
| isPredefConstant ty -> return ty ---- shouldn't be needed
|
||||
|
||||
Q (m,ident) -> checkIn (text "module" <+> ppIdent m) $ do
|
||||
ty' <- checkErr (lookupResDef gr (m,ident))
|
||||
ty' <- lookupResDef gr (m,ident)
|
||||
if ty' == ty then return ty else comp g ty' --- is this necessary to test?
|
||||
|
||||
Vr ident -> checkLookup ident g -- never needed to compute!
|
||||
@@ -50,7 +50,7 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
|
||||
r' <- comp g r
|
||||
s' <- comp g s
|
||||
case (r',s') of
|
||||
(RecType rs, RecType ss) -> checkErr (plusRecType r' s') >>= comp g
|
||||
(RecType rs, RecType ss) -> plusRecType r' s' >>= comp g
|
||||
_ -> return $ ExtR r' s'
|
||||
|
||||
RecType fs -> do
|
||||
@@ -59,7 +59,7 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
|
||||
|
||||
ELincat c t -> do
|
||||
t' <- comp g t
|
||||
checkErr $ lockRecType c t' ---- locking to be removed AR 20/6/2009
|
||||
lockRecType c t' ---- locking to be removed AR 20/6/2009
|
||||
|
||||
_ | ty == typeTok -> return typeStr
|
||||
_ | isPredefConstant ty -> return ty
|
||||
@@ -76,9 +76,9 @@ inferLType gr g trm = case trm of
|
||||
Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident)
|
||||
|
||||
Q ident -> checks [
|
||||
termWith trm $ checkErr (lookupResType gr ident) >>= computeLType gr g
|
||||
termWith trm $ lookupResType gr ident >>= computeLType gr g
|
||||
,
|
||||
checkErr (lookupResDef gr ident) >>= inferLType gr g
|
||||
lookupResDef gr ident >>= inferLType gr g
|
||||
,
|
||||
checkError (text "cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
|
||||
]
|
||||
@@ -88,9 +88,9 @@ inferLType gr g trm = case trm of
|
||||
Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident)
|
||||
|
||||
QC ident -> checks [
|
||||
termWith trm $ checkErr (lookupResType gr ident) >>= computeLType gr g
|
||||
termWith trm $ lookupResType gr ident >>= computeLType gr g
|
||||
,
|
||||
checkErr (lookupResDef gr ident) >>= inferLType gr g
|
||||
lookupResDef gr ident >>= inferLType gr g
|
||||
,
|
||||
checkError (text "cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
|
||||
]
|
||||
@@ -214,10 +214,10 @@ inferLType gr g trm = case trm of
|
||||
sT' <- computeLType gr g sT
|
||||
|
||||
let trm' = ExtR r' s'
|
||||
---- trm' <- checkErr $ plusRecord r' s'
|
||||
---- trm' <- plusRecord r' s'
|
||||
case (rT', sT') of
|
||||
(RecType rs, RecType ss) -> do
|
||||
rt <- checkErr $ plusRecType rT' sT'
|
||||
rt <- plusRecType rT' sT'
|
||||
checkLType gr g trm' rt ---- return (trm', rt)
|
||||
_ | rT' == typeType && sT' == typeType -> return (trm', typeType)
|
||||
_ -> checkError (text "records or record types expected in" <+> ppTerm Unqualified 0 trm)
|
||||
@@ -249,7 +249,7 @@ inferLType gr g trm = case trm of
|
||||
|
||||
ELin c trm -> do
|
||||
(trm',ty) <- inferLType gr g trm
|
||||
ty' <- checkErr $ lockRecType c ty ---- lookup c; remove lock AR 20/6/2009
|
||||
ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009
|
||||
return $ (ELin c trm', ty')
|
||||
|
||||
_ -> checkError (text "cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
|
||||
@@ -289,7 +289,7 @@ inferLType gr g trm = case trm of
|
||||
_ -> False
|
||||
|
||||
inferPatt p = case p of
|
||||
PP (q,c) ps | q /= cPredef -> checkErr $ liftM valTypeCnc (lookupResType gr (q,c))
|
||||
PP (q,c) ps | q /= cPredef -> liftM valTypeCnc (lookupResType gr (q,c))
|
||||
PAs _ p -> inferPatt p
|
||||
PNeg p -> inferPatt p
|
||||
PAlt p q -> checks [inferPatt p, inferPatt q]
|
||||
@@ -423,7 +423,7 @@ checkLType gr g trm typ0 = do
|
||||
case allParamValues gr arg of
|
||||
Ok vs -> do
|
||||
let ps0 = map fst cs
|
||||
ps <- checkErr $ testOvershadow ps0 vs
|
||||
ps <- testOvershadow ps0 vs
|
||||
if null ps
|
||||
then return ()
|
||||
else checkWarn (text "patterns never reached:" $$
|
||||
@@ -511,7 +511,7 @@ checkLType gr g trm typ0 = do
|
||||
checkLType gr g (Let (x,(Just ty,def')) body) typ
|
||||
|
||||
ELin c tr -> do
|
||||
tr1 <- checkErr $ unlockRecord c tr
|
||||
tr1 <- unlockRecord c tr
|
||||
checkLType gr g tr1 typ
|
||||
|
||||
_ -> do
|
||||
@@ -547,7 +547,7 @@ pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context
|
||||
pattContext env g typ p = case p of
|
||||
PV x -> return [(Explicit,x,typ)]
|
||||
PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
|
||||
t <- checkErr $ lookupResType env (q,c)
|
||||
t <- lookupResType env (q,c)
|
||||
let (cont,v) = typeFormCnc t
|
||||
checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p)
|
||||
(length cont == length ps)
|
||||
|
||||
@@ -55,7 +55,7 @@ extendModule gr (name,m)
|
||||
return (name,m')
|
||||
where
|
||||
extOne mo (n,cond) = do
|
||||
m0 <- checkErr $ lookupModule gr n
|
||||
m0 <- lookupModule gr n
|
||||
|
||||
-- test that the module types match, and find out if the old is complete
|
||||
unless (sameMType (mtype m) (mtype mo))
|
||||
@@ -93,7 +93,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_))
|
||||
text "has open interfaces and must therefore be declared incomplete"))
|
||||
case mt of
|
||||
MTInstance (i0,mincl) -> do
|
||||
m1 <- checkErr $ lookupModule gr i0
|
||||
m1 <- lookupModule gr i0
|
||||
unless (isModRes m1)
|
||||
(checkError (text "interface expected instead of" <+> ppIdent i0))
|
||||
js' <- extendMod gr False ((i0,m1), isInherited mincl) i (jments mi)
|
||||
@@ -101,7 +101,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_))
|
||||
case extends mi of
|
||||
[] -> return mi{jments=js'}
|
||||
j0s -> do
|
||||
m0s <- checkErr $ mapM (lookupModule gr) j0s
|
||||
m0s <- mapM (lookupModule gr) j0s
|
||||
let notInM0 c _ = all (not . isInBinTree c . jments) m0s
|
||||
let js2 = filterBinTree notInM0 js'
|
||||
return mi{jments=js2}
|
||||
@@ -114,7 +114,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_))
|
||||
[i | i <- is, notElem i infs]
|
||||
unless (stat' == MSComplete || stat == MSIncomplete)
|
||||
(checkError (text "module" <+> ppIdent i <+> text "remains incomplete"))
|
||||
ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- checkErr $ lookupModule gr ext
|
||||
ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
|
||||
let ops1 = nub $
|
||||
ops_ ++ -- N.B. js has been name-resolved already
|
||||
[OQualif i j | (i,j) <- ops] ++
|
||||
@@ -145,10 +145,10 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
|
||||
Just j -> case unifyAnyInfo name i j of
|
||||
Ok k -> return $ updateTree (c,k) new
|
||||
Bad _ -> do (base,j) <- case j of
|
||||
AnyInd _ m -> checkErr $ lookupOrigInfo gr (m,c)
|
||||
AnyInd _ m -> lookupOrigInfo gr (m,c)
|
||||
_ -> return (base,j)
|
||||
(name,i) <- case i of
|
||||
AnyInd _ m -> checkErr $ lookupOrigInfo gr (m,c)
|
||||
AnyInd _ m -> lookupOrigInfo gr (m,c)
|
||||
_ -> return (name,i)
|
||||
checkError (text "cannot unify the information" $$
|
||||
nest 4 (ppJudgement Qualified (c,i)) $$
|
||||
|
||||
Reference in New Issue
Block a user