ref: 3b89a9b945f04d59290f4e5769f4aa2d8996fca3
parent: 7ef353722df91c6bd4dd0a3ad4d7db0f0bb77f72
author: Lennart Augustsson <lennart@augustsson.net>
date: Thu Nov 2 10:59:22 EDT 2023
Get rid of QualifiedDo
--- a/Makefile
+++ b/Makefile
@@ -5,7 +5,7 @@
OUTDIR=ghc-out
TOOLS=Tools
PROF= #-prof -fprof-auto
-EXTS= -XScopedTypeVariables -XQualifiedDo -XTupleSections
+EXTS= -XScopedTypeVariables -XTupleSections
GHCB=ghc $(PROF) -outputdir $(BOOTDIR)
GHCFLAGS=-i -ighc -ilib -i$(BOOTDIR) -hide-all-packages -XNoImplicitPrelude -XRebindableSyntax $(EXTS) -F -pgmF $(TOOLS)/convertY.sh
GHCC=$(GHCB) $(GHCFLAGS)
--- a/MicroHs.cabal
+++ b/MicroHs.cabal
@@ -38,7 +38,7 @@
hs-source-dirs: src ghc
ghc-options: -Wall -Wno-unrecognised-warning-flags -Wno-x-partial -F -pgmF ./Tools/convertX.sh -main-is MicroHs.Main
main-is: MicroHs/Main.hs
- default-extensions: ScopedTypeVariables QualifiedDo PatternGuards TupleSections
+ default-extensions: ScopedTypeVariables PatternGuards TupleSections
other-modules: MicroHs.Compile
MicroHs.Desugar
MicroHs.Exp
--- a/src/MicroHs/Compile.hs
+++ b/src/MicroHs/Compile.hs
@@ -6,11 +6,11 @@
compileCacheTop,
Cache, emptyCache, deleteFromCache,
) where
-import Prelude --Xhiding (Monad(..), mapM)
-import qualified System.IO as IO
+import Prelude
+import System.IO
import Control.DeepSeq
import qualified MicroHs.IdentMap as M
-import MicroHs.StateIO as S
+import MicroHs.StateIO
import MicroHs.Desugar
import MicroHs.Exp
import MicroHs.Expr
@@ -18,8 +18,6 @@
import MicroHs.Parse
import MicroHs.TypeCheck
--Ximport Compat
---Ximport qualified CompatIO as IO
---Ximport System.IO(Handle)
data Flags = Flags Int Bool [String] String Bool
--Xderiving (Show)
@@ -65,59 +63,59 @@
-----------------
compileCacheTop :: Flags -> Ident -> Cache -> IO ([(Ident, Exp)], Cache)
-compileCacheTop flags mn ch = IO.do
+compileCacheTop flags mn ch = do
(ds, ch') <- compile flags mn ch
t1 <- getTimeMilli
let
dsn = [ (n, compileOpt e) | (n, e) <- ds ]
- () <- IO.return (rnf dsn)
+ () <- return (rnf dsn)
t2 <- getTimeMilli
- IO.when (verbose flags > 0) $
+ when (verbose flags > 0) $
putStrLn $ "combinator conversion " ++ padLeft 6 (show (t2-t1)) ++ "ms"
- IO.return (dsn, ch')
+ return (dsn, ch')
--compileTop :: Flags -> IdentModule -> IO [LDef]
compileTop :: Flags -> Ident -> IO [(Ident, Exp)]
-compileTop flags mn = IO.fmap fst $ compileCacheTop flags mn emptyCache
+compileTop flags mn = fmap fst $ compileCacheTop flags mn emptyCache
compile :: Flags -> IdentModule -> Cache -> IO ([LDef], Cache)
-compile flags nm ach = IO.do
+compile flags nm ach = do
((_, t), ch) <- runStateIO (compileModuleCached flags nm) ach
- IO.when (verbose flags > 0) $
+ when (verbose flags > 0) $
putStrLn $ "total import time " ++ padLeft 6 (show t) ++ "ms"
- IO.return (concatMap bindingsOf $ M.elems $ cache ch, ch)
+ return (concatMap bindingsOf $ M.elems $ cache ch, ch)
-- Compile a module with the given name.
-- If the module has already been compiled, return the cached result.
compileModuleCached :: Flags -> IdentModule -> StateIO Cache (CModule, Time)
-compileModuleCached flags mn = S.do
+compileModuleCached flags mn = do
ch <- gets cache
case M.lookup mn ch of
- Nothing -> S.do
+ Nothing -> do
ws <- gets working
- S.when (elem mn ws) $
+ when (elem mn ws) $
error $ "recursive module: " ++ showIdent mn
modify $ \ c -> updWorking (mn : working c) c
- S.when (verbose flags > 0) $
+ when (verbose flags > 0) $
liftIO $ putStrLn $ "importing " ++ showIdent mn
(cm, tp, tt, ts) <- compileModule flags mn
- S.when (verbose flags > 0) $
+ when (verbose flags > 0) $
liftIO $ putStrLn $ "importing done " ++ showIdent mn ++ ", " ++ show (tp + tt) ++
"ms (" ++ show tp ++ " + " ++ show tt ++ ")"- S.when (loading flags && mn /= mkIdent "Interactive") $
+ when (loading flags && mn /= mkIdent "Interactive") $
liftIO $ putStrLn $ "import " ++ showIdent mn
c <- get
put $ Cache (tail (working c)) (M.insert mn cm (cache c))
- S.return (cm, tp + tt + ts)
- Just cm -> S.do
- S.when (verbose flags > 0) $
+ return (cm, tp + tt + ts)
+ Just cm -> do
+ when (verbose flags > 0) $
liftIO $ putStrLn $ "importing cached " ++ showIdent mn
- S.return (cm, 0)
+ return (cm, 0)
-- Find and compile a module with the given name.
-- The times are (parsing, typecheck+desugar, imported modules)
compileModule :: Flags -> IdentModule -> StateIO Cache (CModule, Time, Time, Time)
-compileModule flags nm = S.do
+compileModule flags nm = do
t1 <- liftIO getTimeMilli
let
fn = map (\ c -> if c == '.' then '/' else c) (unIdent nm) ++ ".hs"
@@ -125,44 +123,44 @@
let mdl@(EModule nmn _ defs) = parseDie pTop pathfn file
-- liftIO $ putStrLn $ showEModule mdl
-- liftIO $ putStrLn $ showEDefs defs
- S.when (nm /= nmn) $
+ when (nm /= nmn) $
error $ "module name does not agree with file name: " ++ showIdent nm ++ " " ++ showIdent nmn
let
specs = [ s | Import s <- defs ]
t2 <- liftIO getTimeMilli
- (impMdls, ts) <- S.fmap unzip $ S.mapM (compileModuleCached flags) [ m | ImportSpec _ m _ _ <- specs ]
+ (impMdls, ts) <- fmap unzip $ mapM (compileModuleCached flags) [ m | ImportSpec _ m _ _ <- specs ]
t3 <- liftIO getTimeMilli
let
tmdl = typeCheck (zip specs impMdls) mdl
- S.when (verbose flags > 2) $
+ when (verbose flags > 2) $
liftIO $ putStrLn $ "type checked:\n" ++ showTModule showEDefs tmdl ++ "-----\n"
let
dmdl = desugar tmdl
- () <- S.return $ rnf $ bindingsOf dmdl
+ () <- return $ rnf $ bindingsOf dmdl
t4 <- liftIO getTimeMilli
- S.when (verbose flags > 2) $
+ when (verbose flags > 2) $
(liftIO $ putStrLn $ "desugared:\n" ++ showTModule showLDefs dmdl)
- S.return (dmdl, t2-t1, t4-t3, sum ts)
+ return (dmdl, t2-t1, t4-t3, sum ts)
------------------
readFilePath :: [FilePath] -> FilePath -> IO (FilePath, String)
-readFilePath path name = IO.do
+readFilePath path name = do
mh <- openFilePath path name
case mh of
Nothing -> error $ "File not found: " ++ show name ++ "\npath=" ++ show path
- Just (fn, h) -> IO.do
- file <- IO.hGetContents h
- IO.return (fn, file)
+ Just (fn, h) -> do
+ file <- hGetContents h
+ return (fn, file)
openFilePath :: [FilePath] -> FilePath -> IO (Maybe (FilePath, Handle))
openFilePath adirs fileName =
case adirs of
- [] -> IO.return Nothing
- dir:dirs -> IO.do
+ [] -> return Nothing
+ dir:dirs -> do
let
path = dir ++ "/" ++ fileName
- mh <- openFileM path IO.ReadMode
+ mh <- openFileM path ReadMode
case mh of
Nothing -> openFilePath dirs fileName -- If opening failed, try the next directory
- Just hdl -> IO.return (Just (path, hdl))
+ Just hdl -> return (Just (path, hdl))
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -295,16 +295,16 @@
--showArm (ps, _, b) = showListS showExpr ps ++ "," ++ show b
newIdents :: Int -> M [Ident]
-newIdents n = S.do
+newIdents n = do
is <- get
put (drop n is)
- S.return (take n is)
+ return (take n is)
newIdent :: M Ident
-newIdent = S.do
+newIdent = do
is <- get
put (tail is)
- S.return (head is)
+ return (head is)
runS :: SLoc -> [Ident] -> [Exp] -> Matrix -> Exp
runS loc used ss mtrx =
@@ -313,8 +313,8 @@
ds xs aes =
case aes of
[] -> dsMatrix (eMatchErr loc) (reverse xs) mtrx
- e:es -> letBind (S.return e) $ \ x -> ds (x:xs) es
- in S.evalState (ds [] ss) supply
+ e:es -> letBind (return e) $ \ x -> ds (x:xs) es
+ in evalState (ds [] ss) supply
data SPat = SPat Con [Ident] -- simple pattern
--Xderiving(Show, Eq)
@@ -329,11 +329,11 @@
Exp -> [Exp] -> Matrix -> M Exp
dsMatrix dflt iis aarms =
if null aarms then
- S.return dflt
+ return dflt
else
case iis of
- [] -> let { (_, f, _) : _ = aarms } in S.return $ f dflt- i:is -> S.do
+ [] -> let { (_, f, _) : _ = aarms } in return $ f dflt+ i:is -> do
let
(arms, darms, rarms) = splitArms aarms
ndarms = map (\ (EVar x : ps, ed, g) -> (ps, substAlpha x i . ed, g) ) darms
@@ -341,13 +341,13 @@
letBind (dsMatrix dflt iis rarms) $ \ drest ->
letBind (dsMatrix drest is ndarms) $ \ ndflt ->
if null arms then
- S.return ndflt
- else S.do
+ return ndflt
+ else do
let
idOf (p:_, _, _) = pConOf p
idOf _ = impossible
grps = groupEq (on (==) idOf) arms
- oneGroup grp = S.do
+ oneGroup grp = do
let
(pat:_, _, _) : _ = grp
con = pConOf pat
@@ -361,10 +361,10 @@
_ -> (pArgs p ++ ps, e, g)
_ -> impossible
cexp <- dsMatrix ndflt (map Var xs ++ is) (map one grp)
- S.return (SPat con xs, cexp)
+ return (SPat con xs, cexp)
-- traceM $ "grps " ++ show grps
- narms <- S.mapM oneGroup grps
- S.return $ mkCase i narms ndflt
+ narms <- mapM oneGroup grps
+ return $ mkCase i narms ndflt
eMatchErr :: SLoc -> Exp
eMatchErr (SLoc fn l c) =
@@ -373,14 +373,14 @@
-- If the first expression isn't a variable/literal, then use
-- a let binding and pass variable to f.
letBind :: M Exp -> (Exp -> M Exp) -> M Exp
-letBind me f = S.do
+letBind me f = do
e <- me
if cheap e then
f e
- else S.do
+ else do
x <- newIdent
r <- f (Var x)
- S.return $ eLet x e r
+ return $ eLet x e r
cheap :: Exp -> Bool
cheap ae =
@@ -518,15 +518,15 @@
lazier def@(fcn, Lam x (Lam y body)) =
let fcn' = addIdentSuffix fcn "@"
vfcn' = Var fcn'
- repl :: Exp -> S.State Bool Exp
+ repl :: Exp -> State Bool Exp
repl (Lam i e) = Lam i <$> repl e
- repl (App (Var af) (Var ax)) | af == fcn && ax == x = S.do
+ repl (App (Var af) (Var ax)) | af == fcn && ax == x = do
put True
- S.return vfcn'
+ return vfcn'
repl (App f a) = App <$> repl f <*> repl a
- repl e@(Var _) = S.return e
- repl e@(Lit _) = S.return e
- in case S.runState (repl body) False of
+ repl e@(Var _) = return e
+ repl e@(Lit _) = return e
+ in case runState (repl body) False of
(_, False) -> def
(e', True) -> (fcn, Lam x $ letRecE fcn' (Lam y e') vfcn')
--- a/src/MicroHs/Interactive.hs
+++ b/src/MicroHs/Interactive.hs
@@ -3,7 +3,7 @@
--Ximport Data.List
--import Control.DeepSeq
import Control.Exception
-import qualified MicroHs.StateIO as S
+import MicroHs.StateIO
import MicroHs.Compile
import MicroHs.Exp(Exp)
import MicroHs.Ident(Ident, mkIdent)
@@ -17,7 +17,7 @@
type IState = (String, Flags, Cache)
-type I a = S.StateIO IState a
+type I a = StateIO IState a
mainInteractive :: Flags -> IO ()
mainInteractive (Flags a b c d _) = do
@@ -24,7 +24,7 @@
putStrLn "Welcome to interactive MicroHs!"
putStrLn "Type ':quit' to quit, ':help' for help"
let flags' = Flags a b c d True
- _ <- S.runStateIO start (preamble, flags', emptyCache)
+ _ <- runStateIO start (preamble, flags', emptyCache)
return ()
preamble :: String
@@ -32,22 +32,22 @@
") where\nimport Prelude\n"
start :: I ()
-start = S.do
+start = do
reload
repl
repl :: I ()
-repl = S.do
- ms <- S.liftIO $ getInputLineHist ".mhsi" "> "
+repl = do
+ ms <- liftIO $ getInputLineHist ".mhsi" "> "
case ms of
Nothing -> repl
Just s ->
case s of
[] -> repl
- ':':r -> S.do
+ ':':r -> do
c <- command r
- if c then repl else S.liftIO $ putStrLn "Bye"
- _ -> S.do
+ if c then repl else liftIO $ putStrLn "Bye"
+ _ -> do
oneline s
repl
@@ -54,46 +54,46 @@
command :: String -> I Bool
command s =
case words s of
- [] -> S.return True
+ [] -> return True
c : ws ->
case filter (isPrefixOf c . fst) commands of
- [] -> S.do
- S.liftIO $ putStrLn "Unrecognized command"
- S.return True
+ [] -> do
+ liftIO $ putStrLn "Unrecognized command"
+ return True
[(_, cmd)] ->
cmd (unwords ws)
- xs -> S.do
- S.liftIO $ putStrLn $ "Ambiguous command: " ++ unwords (map fst xs)
- S.return True
+ xs -> do
+ liftIO $ putStrLn $ "Ambiguous command: " ++ unwords (map fst xs)
+ return True
commands :: [(String, String -> I Bool)]
commands =
- [ ("quit", const $ S.return False)- , ("clear", const $ S.do+ [ ("quit", const $ return False)+ , ("clear", const $ doupdateLines (const preamble)
- S.modify $ \ (ls, flgs, _) -> (ls, flgs, emptyCache)
- S.return True
+ modify $ \ (ls, flgs, _) -> (ls, flgs, emptyCache)
+ return True
)
- , ("reload", const $ S.do- S.modify $ \ (ls, flgs, _) -> (ls, flgs, emptyCache)
+ , ("reload", const $ do+ modify $ \ (ls, flgs, _) -> (ls, flgs, emptyCache)
reload
- S.return True
+ return True
)
- , ("delete", \ del -> S.do+ , ("delete", \ del -> doupdateLines (unlines . filter (not . isPrefixOf del) . lines)
- S.return True
+ return True
)
- , ("help", \ _ -> S.do- S.liftIO $ putStrLn helpText
- S.return True
+ , ("help", \ _ -> do+ liftIO $ putStrLn helpText
+ return True
)
]
reload :: I ()
-reload = S.do
- (ls, _, _) <- S.get
+reload = do
+ (ls, _, _) <- get
_ <- tryCompile ls -- reload modules right away
- S.return ()
+ return ()
helpText :: String
@@ -100,7 +100,7 @@
helpText = "Commands:\n :quit quit MicroHs\n :reload reload modules\n :clear clear all definitions\n :delete d delete definition(s) d\n :help this text\n expr evaluate expression\n defn add top level definition\n"
updateLines :: (String -> String) -> I ()
-updateLines f = S.modify $ \ (ls, flgs, cache) -> (f ls, flgs, cache)
+updateLines f = modify $ \ (ls, flgs, cache) -> (f ls, flgs, cache)
interactiveName :: String
interactiveName = "Interactive"
@@ -115,45 +115,45 @@
err (Exn s) = putStrLn $ "Error: " ++ s
oneline :: String -> I ()
-oneline line = S.do
- (ls, _, _) <- S.get
+oneline line = do
+ (ls, _, _) <- get
case parse pExprTop "" line of
- Right _ -> S.do
+ Right _ -> do
-- Looks like an expressions, make it a definition
exprTest <- tryCompile (ls ++ "\n" ++ mkIt line)
case exprTest of
Right m -> evalExpr m
- Left e -> S.liftIO $ err e
- Left _ -> S.do
+ Left e -> liftIO $ err e
+ Left _ -> do
-- Not an expression, try adding it as a definition
let lls = ls ++ line ++ "\n"
defTest <- tryCompile lls
case defTest of
Right _ -> updateLines (const lls)
- Left e -> S.liftIO $ err e
+ Left e -> liftIO $ err e
tryCompile :: String -> I (Either Exn [LDef])
-tryCompile file = S.do
- (ls, flgs, cache) <- S.get
+tryCompile file = do
+ (ls, flgs, cache) <- get
let
iid = mkIdent interactiveName
- S.liftIO $ writeFile (interactiveName ++ ".hs") file
- res <- S.liftIO $ try $ compileCacheTop flgs iid cache
+ liftIO $ writeFile (interactiveName ++ ".hs") file
+ res <- liftIO $ try $ compileCacheTop flgs iid cache
case res of
- Left e -> S.return (Left e)
- Right (m, cache') -> S.do
- S.put (ls, flgs, deleteFromCache iid cache')
- S.return (Right m)
+ Left e -> return (Left e)
+ Right (m, cache') -> do
+ put (ls, flgs, deleteFromCache iid cache')
+ return (Right m)
evalExpr :: [LDef] -> I ()
-evalExpr cmdl = S.do
+evalExpr cmdl = do
let ares = translate (mkIdent (interactiveName ++ "." ++ itName), cmdl)
res = unsafeCoerce ares :: IO ()
- mval <- S.liftIO $ try (seq res (return res))
- S.liftIO $
+ mval <- liftIO $ try (seq res (return res))
+ liftIO $
case mval of
Left e -> err e
- Right val -> S.do
+ Right val -> do
mio <- try val
case mio of
Left e -> err e
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -34,9 +34,9 @@
--X ++ unlines (map (show . fst) as)
getLoc :: P Loc
-getLoc = P.do
+getLoc = do
t <- nextToken
- P.pure (tokensLoc [t])
+ pure (tokensLoc [t])
pTop :: P EModule
pTop = pModule <* eof
@@ -50,7 +50,7 @@
(pKeyword "where" *> pBlock pDef)
pQIdent :: P Ident
-pQIdent = P.do
+pQIdent = do
fn <- getFileName
let
is (TIdent loc qs s) | isAlpha_ (head s) = Just (qualName fn loc qs s)
@@ -58,7 +58,7 @@
satisfyM "QIdent" is
pUIdentA :: P Ident
-pUIdentA = P.do
+pUIdentA = do
fn <- getFileName
let
is (TIdent loc [] s) | isUpper (head s) = Just (mkIdentLoc fn loc s)
@@ -74,7 +74,7 @@
pUIdentSym = pUIdent <|< pParens pUSymOper
pUIdentSpecial :: P Ident
-pUIdentSpecial = P.do
+pUIdentSpecial = do
fn <- getFileName
loc <- getLoc
let
@@ -85,7 +85,7 @@
<|< (mk "[]" <$ (pSpec '[' *> pSpec ']')) -- Allow [] as a constructor name
pUQIdentA :: P Ident
-pUQIdentA = P.do
+pUQIdentA = do
fn <- getFileName
let
is (TIdent loc qs s) | isUpper (head s) = Just (qualName fn loc qs s)
@@ -98,7 +98,7 @@
<|< pUIdentSpecial
pLIdent :: P Ident
-pLIdent = P.do
+pLIdent = do
fn <- getFileName
let
is (TIdent loc [] s) | isLower_ (head s) && not (elem s keywords) = Just (mkIdentLoc fn loc s)
@@ -106,7 +106,7 @@
satisfyM "LIdent" is
pLQIdent :: P Ident
-pLQIdent = P.do
+pLQIdent = do
fn <- getFileName
let
is (TIdent loc qs s) | isLower_ (head s) && not (elem s keywords) = Just (qualName fn loc qs s)
@@ -139,7 +139,7 @@
pOper = pQSymOper <|< (pSpec '`' *> pQIdent <* pSpec '`')
pQSymOper :: P Ident
-pQSymOper = P.do
+pQSymOper = do
fn <- getFileName
let
is (TIdent loc qs s) | not (isAlpha_ (head s)) && not (elem s reservedOps) = Just (qualName fn loc qs s)
@@ -147,7 +147,7 @@
satisfyM "QSymOper" is
pSymOper :: P Ident
-pSymOper = P.do
+pSymOper = do
fn <- getFileName
let
is (TIdent loc [] s) | not (isAlpha_ (head s)) && not (elem s reservedOps) = Just (mkIdentLoc fn loc s)
@@ -155,25 +155,25 @@
satisfyM "SymOper" is
pUQSymOper :: P Ident
-pUQSymOper = P.do
+pUQSymOper = do
s <- pQSymOper
guard (isUOper s)
- P.pure s
+ pure s
isUOper :: Ident -> Bool
isUOper = (== ':') . head . unIdent
pUSymOper :: P Ident
-pUSymOper = P.do
+pUSymOper = do
s <- pSymOper
guard (isUOper s)
- P.pure s
+ pure s
pLQSymOper :: P Ident
-pLQSymOper = P.do
+pLQSymOper = do
s <- pQSymOper
guard (not (isUOper s))
- P.pure s
+ pure s
-- Allow -> as well
pLQSymOperArr :: P Ident
@@ -181,7 +181,7 @@
-- Parse ->, possibly qualified
pQArrow :: P Ident
-pQArrow = P.do
+pQArrow = do
fn <- getFileName
let
is (TIdent loc qs s@"->") = Just (qualName fn loc qs s)
@@ -189,10 +189,10 @@
satisfyM "->" is
pLSymOper :: P Ident
-pLSymOper = P.do
+pLSymOper = do
s <- pSymOper
guard (not (isUOper s))
- P.pure s
+ pure s
reservedOps :: [String]
reservedOps = ["=", "|", "::", "<-", "@", "..", "->"]
@@ -210,7 +210,7 @@
pParens p = pSpec '(' *> p <* pSpec ')'pLit :: P Expr
-pLit = P.do
+pLit = do
fn <- getFileName
let
is (TString (l, c) s) = Just (ELit (SLoc fn l c) (LStr s))
@@ -242,7 +242,7 @@
is _ = False
pBlock :: forall a . P a -> P [a]
-pBlock p = P.do
+pBlock p = do
pSpec '{'as <- esepBy p (pSpec ';')
eoptional (pSpec ';')
@@ -252,7 +252,7 @@
pDef :: P EDef
pDef =
Data <$> (pKeyword "data" *> pLHS) <*> ((pSymbol "=" *> esepBy1 (Constr <$> pUIdentSym <*> pFields) (pSymbol "|"))
- <|< P.pure [])
+ <|< pure [])
<|< Newtype <$> (pKeyword "newtype" *> pLHS) <*> (pSymbol "=" *> (Constr <$> pUIdentSym <*> pField))
<|< Type <$> (pKeyword "type" *> pLHS) <*> (pSymbol "=" *> pType)
<|< uncurry Fcn <$> pEqns
@@ -267,16 +267,16 @@
dig (TInt _ i) | -2 <= i && i <= 9 = Just i
dig _ = Nothing
pPrec = satisfyM "digit" dig
- pContext = (pCtx <* pSymbol "=>") <|< P.pure []
+ pContext = (pCtx <* pSymbol "=>") <|< pure []
pCtx = pParens (emany pType) <|< ((:[]) <$> pTypeApp)
pFields = Left <$> emany pAType <|<
Right <$> (pSpec '{' *> esepBy ((,) <$> (pLIdentSym <* pSymbol "::") <*> pType) (pSpec ',') <* pSpec '}')- pField = P.do
+ pField = do
fs <- pFields
guard $ either length length fs == 1
- P.pure fs
- pFunDeps = (pSpec '|' *> esome pFunDep) <|< P.pure []
+ pure fs
+ pFunDeps = (pSpec '|' *> esome pFunDep) <|< pure []
pFunDep = (,) <$> esome pLIdent <*> (pSymbol "->" *> esome pLIdent)
pLHS :: P LHS
@@ -312,7 +312,7 @@
-- Including '->' in pExprOp interacts poorly with '->'
-- in lambda and 'case'.
pType :: P EType
-pType = P.do
+pType = do
vs <- pForall
t <- pTypeOp
pure $ if null vs then t else EForall vs t
@@ -330,7 +330,7 @@
pTypeArg = pTypeApp
pTypeApp :: P EType
-pTypeApp = P.do
+pTypeApp = do
f <- pAType
as <- emany pAType
mt <- eoptional (pSymbol "::" *> pType)
@@ -356,7 +356,7 @@
-- is separate.
pAPat :: P EPat
pAPat =
- (P.do
+ (do
i <- pLIdentSym
(EAt i <$> (pSymbol "@" *> pAPat)) <|< pure (EVar i)
)
@@ -375,7 +375,7 @@
pPatArg = pPatApp
pPatApp :: P EPat
-pPatApp = P.do
+pPatApp = do
f <- pAPat
as <- emany pAPat
guard (null as || isPConApp f)
@@ -382,7 +382,7 @@
pure $ foldl EApp f as
pPatNotVar :: P EPat
-pPatNotVar = P.do
+pPatNotVar = do
p <- pPat
guard (not (isPVar p))
pure p
@@ -390,22 +390,22 @@
-------------
pEqns :: P (Ident, [Eqn])
-pEqns = P.do
+pEqns = do
(name, eqn@(Eqn ps alts)) <- pEqn (\ _ _ -> True)
case (ps, alts) of
([], EAlts [_] []) ->
-- don't collect equations when of the form 'i = e'
- P.pure (name, [eqn])
- _ -> P.do
+ pure (name, [eqn])
+ _ -> do
neqns <- emany (pSpec ';' *> pEqn (\ n l -> n == name && l == length ps))
- P.pure (name, eqn : map snd neqns)
+ pure (name, eqn : map snd neqns)
pEqn :: (Ident -> Int -> Bool) -> P (Ident, Eqn)
-pEqn test = P.do
+pEqn test = do
(name, pats) <- pEqnLHS
alts <- pAlts (pSymbol "=")
guard (test name (length pats))
- P.pure (name, Eqn pats alts)
+ pure (name, Eqn pats alts)
pEqnLHS :: P (Ident, [EPat])
pEqnLHS =
@@ -416,16 +416,16 @@
((\ (i, ps1) ps2 -> (i, ps1 ++ ps2)) <$> pParens pOpLHS <*> emany pAPat)
where
pOpLHS = (\ p1 i p2 -> (i, [p1,p2])) <$> pPatApp <*> pLOper <*> pPatApp
- pLOper = P.do
+ pLOper = do
i <- pOper
guard (not (isConIdent i))
- P.pure i
+ pure i
pAlts :: P () -> P EAlts
-pAlts sep = P.do
+pAlts sep = do
alts <- pAltsL sep
bs <- pWhere pBind
- P.pure (EAlts alts bs)
+ pure (EAlts alts bs)
pAltsL :: P () -> P [EAlt]
pAltsL sep =
@@ -435,7 +435,7 @@
pWhere :: P EBind -> P [EBind]
pWhere pb =
(pKeyword "where" *> pBlock pb)
- <|< P.pure []
+ <|< pure []
-------------
-- Statements
@@ -456,7 +456,7 @@
pExprArg = pExprApp <|< pLam <|< pCase <|< pLet <|< pIf <|< pDo
pExprApp :: P Expr
-pExprApp = P.do
+pExprApp = do
f <- pAExpr
as <- emany pAExpr
mt <- eoptional (pSymbol "::" *> pType)
@@ -483,7 +483,7 @@
pIf = EIf <$> (pKeyword "if" *> pExpr) <*> (pKeyword "then" *> pExpr) <*> (pKeyword "else" *> pExpr)
pQualDo :: P Ident
-pQualDo = P.do
+pQualDo = do
fn <- getFileName
let
is (TIdent loc qs@(_:_) "do") = Just (mkIdentLoc fn loc (intercalate "." qs))
@@ -510,20 +510,20 @@
-- <?> "aexpr"
pListish :: P Listish
-pListish = P.do
+pListish = do
e1 <- pExpr
let
- pMore = P.do
+ pMore = do
e2 <- pExpr
((\ es -> LList (e1:e2:es)) <$> esome (pSpec ',' *> pExpr))
<|< (LFromThenTo e1 e2 <$> (pSymbol ".." *> pExpr))
<|< (LFromThen e1 e2 <$ pSymbol "..")
- <|< P.pure (LList [e1,e2])
+ <|< pure (LList [e1,e2])
(pSpec ',' *> pMore)
<|< (LCompr e1 <$> (pSymbol "|" *> esepBy1 pStmt (pSpec ',')))
<|< (LFromTo e1 <$> (pSymbol ".." *> pExpr))
<|< (LFrom e1 <$ pSymbol "..")
- <|< P.pure (LList [e1])
+ <|< pure (LList [e1])
pExprOp :: P Expr
pExprOp = pOperators pOper pExprArg
--- a/src/MicroHs/StateIO.hs
+++ b/src/MicroHs/StateIO.hs
@@ -24,10 +24,10 @@
{-execStateIO :: forall s a . StateIO s a -> s -> IO s
-execStateIO sa s = IO.do
+execStateIO sa s = do
as <- runStateIO sa s
case as of
- (_, ss) -> IO.return ss
+ (_, ss) -> return ss
-}
instance forall s . Functor (StateIO s) where
@@ -50,33 +50,6 @@
instance forall s . MonadFail (StateIO s) where
fail = error
-
-{--(>>=) :: forall s a b . StateIO s a -> (a -> StateIO s b) -> StateIO s b
-(>>=) m k = S $ \ s -> IO.do
- (a, ss) <- runStateIO m s
- runStateIO (k a) ss
-
-(>>) :: forall s a b . StateIO s a -> StateIO s b -> StateIO s b
-(>>) m k = S $ \ s -> IO.do
- (_, ss) <- runStateIO m s
- runStateIO k ss
-
-return :: forall s a . a -> StateIO s a
-return a = S $ \ s -> IO.return (a, s)
-
-fmap :: forall s a b . (a -> b) -> StateIO s a -> StateIO s b
-fmap f sa = S $ \ s -> IO.do
- (a, ss) <- runStateIO sa s
- IO.return (f a, ss)
-
-fail :: forall s a . String -> StateIO s a
-fail = error
-
-when :: forall s . Bool -> StateIO s () -> StateIO s ()
-when b s = if b then s else return ()
-
--}
gets :: forall s a . (s -> a) -> StateIO s a
gets f = S $ \ s -> return (f s, s)
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -397,51 +397,51 @@
constraints (TC _ _ _ _ _ _ _ _ _ _ _ e) = e
putValueTable :: ValueTable -> T ()
-putValueTable venv = T.do
+putValueTable venv = do
TC mn n fx tenv senv _ ast sub m cs is es <- get
put (TC mn n fx tenv senv venv ast sub m cs is es)
putTypeTable :: TypeTable -> T ()
-putTypeTable tenv = T.do
+putTypeTable tenv = do
TC mn n fx _ senv venv ast sub m cs is es <- get
put (TC mn n fx tenv senv venv ast sub m cs is es)
putSynTable :: SynTable -> T ()
-putSynTable senv = T.do
+putSynTable senv = do
TC mn n fx tenv _ venv ast sub m cs is es <- get
put (TC mn n fx tenv senv venv ast sub m cs is es)
putUvarSubst :: IM.IntMap EType -> T ()
-putUvarSubst sub = T.do
+putUvarSubst sub = do
TC mn n fx tenv senv venv ast _ m cs is es <- get
put (TC mn n fx tenv senv venv ast sub m cs is es)
putTCMode :: TCMode -> T ()
-putTCMode m = T.do
+putTCMode m = do
TC mn n fx tenv senv venv ast sub _ cs is es <- get
put (TC mn n fx tenv senv venv ast sub m cs is es)
putInstTable :: InstTable -> T ()
-putInstTable is = T.do
+putInstTable is = do
TC mn n fx tenv senv venv ast sub m cs _ es <- get
put (TC mn n fx tenv senv venv ast sub m cs is es)
putConstraints :: Constraints -> T ()
-putConstraints es = T.do
+putConstraints es = do
TC mn n fx tenv senv venv ast sub m cs is _ <- get
put (TC mn n fx tenv senv venv ast sub m cs is es)
withTCMode :: forall a . TCMode -> T a -> T a
-withTCMode m ta = T.do
+withTCMode m ta = do
om <- gets tcMode
putTCMode m
a <- ta
putTCMode om
- T.return a
+ return a
-- Use the type table as the value table, and the primKind table as the type table.
withTypeTable :: forall a . T a -> T a
-withTypeTable ta = T.do
+withTypeTable ta = do
TC mn n fx tt st vt ast sub m cs is es <- get
put (TC mn n fx primKindTable st tt ast sub m cs is es)
a <- ta
@@ -450,20 +450,20 @@
-- Keep everyting, except that the returned value table
-- becomes the type tables, and the old type table is restored.
put (TC mnr nr fxr ttr str vt astr subr mr csr isr esr)
- T.return a
+ return a
addAssocTable :: Ident -> [Ident] -> T ()
-addAssocTable i ids = T.do
+addAssocTable i ids = do
TC mn n fx tt st vt ast sub m cs is es <- get
put $ TC mn n fx tt st vt (M.insert i ids ast) sub m cs is es
addClassTable :: Ident -> ClassInfo -> T ()
-addClassTable i x = T.do
+addClassTable i x = do
TC mn n fx tt st vt ast sub m cs is es <- get
put $ TC mn n fx tt st vt ast sub m (M.insert i x cs) is es
addInstTable :: [InstDictC] -> T ()
-addInstTable ics = T.do
+addInstTable ics = do
let
-- Change type variable to unique unification variables.
-- These unification variables will never leak, but as an extra caution
@@ -472,20 +472,20 @@
zipWith (\ ik j -> (idKindIdent ik, EUVar j)) iks [-1, -2 ..]
mkInstInfo :: InstDictC -> T (Ident, InstInfo)
- mkInstInfo (e, iks, ctx, ct) = T.do
+ mkInstInfo (e, iks, ctx, ct) = do
ct' <- expandSyn ct
case (iks, ctx, getApp ct') of
- ([], [], (c, [EVar i])) -> T.return $ (c, InstInfo (M.singleton i e) [])
- (_, _, (c, ts )) -> T.return $ (c, InstInfo M.empty [(e, ctx', ts')])
+ ([], [], (c, [EVar i])) -> return $ (c, InstInfo (M.singleton i e) [])
+ (_, _, (c, ts )) -> return $ (c, InstInfo M.empty [(e, ctx', ts')])
where ctx' = map (subst s) ctx
ts' = map (subst s) ts
s = freshSubst iks
- iis <- T.mapM mkInstInfo ics
+ iis <- mapM mkInstInfo ics
it <- gets instTable
putInstTable $ foldr (uncurry $ M.insertWith mergeInstInfo) it iis
addConstraint :: Ident -> EConstraint -> T ()
-addConstraint d ctx = T.do
+addConstraint d ctx = do
-- traceM $ "addConstraint: " ++ msg ++ " " ++ showIdent d ++ " :: " ++ showEType ctx
ctx' <- expandSyn ctx
TC mn n fx tt st vt ast sub m cs is es <- get
@@ -492,13 +492,13 @@
put $ TC mn n fx tt st vt ast sub m cs is ((d, ctx') : es)
withDict :: forall a . Ident -> EConstraint -> T a -> T a
-withDict i c ta = T.do
+withDict i c ta = do
is <- gets instTable
ics <- expandDict (EVar i) c
addInstTable ics
a <- ta
putInstTable is
- T.return a
+ return a
initTC :: IdentModule -> FixTable -> TypeTable -> SynTable -> ClassTable -> InstTable -> ValueTable -> AssocTable -> TCState
initTC mn fs ts ss cs is vs as =
@@ -628,7 +628,7 @@
-}
setUVar :: TRef -> EType -> T ()
-setUVar i t = T.do
+setUVar i t = do
TC mn n fx tenv senv venv ast sub m cs is es <- get
put (TC mn n fx tenv senv venv ast (IM.insert i t sub) m cs is es)
@@ -646,19 +646,19 @@
let
syn ts t =
case t of
- EApp f a -> T.do
+ EApp f a -> do
aa <- expandSyn a
syn (aa:ts) f
- EVar i -> T.do
+ EVar i -> do
syns <- gets synTable
case M.lookup i syns of
- Nothing -> T.return $ foldl tApp t ts
+ Nothing -> return $ foldl tApp t ts
Just (EForall vks tt) ->
if length vks /= length ts then tcError (getSLocIdent i) $ "bad synonym use"
--X ++ "\nXX " ++ show (i, vks, ts)
else expandSyn $ subst (zip (map idKindIdent vks) ts) tt
Just _ -> impossible
- EUVar _ -> T.return $ foldl tApp t ts
+ EUVar _ -> return $ foldl tApp t ts
ESign a _ -> expandSyn a -- Throw away signatures, they don't affect unification
EForall iks tt | null ts -> EForall iks <$> expandSyn tt
_ -> impossible
@@ -667,19 +667,19 @@
derefUVar :: EType -> T EType
derefUVar at =
case at of
- EApp f a -> T.do
+ EApp f a -> do
fx <- derefUVar f
ax <- derefUVar a
- T.return $ EApp fx ax
- EUVar i -> T.do
+ return $ EApp fx ax
+ EUVar i -> do
mt <- getUVar i
case mt of
- Nothing -> T.return at
- Just t -> T.do
+ Nothing -> return at
+ Just t -> do
t' <- derefUVar t
setUVar i t'
- T.return t'
- EVar _ -> T.return at
+ return t'
+ EVar _ -> return at
ESign t k -> flip ESign k <$> derefUVar t
EForall iks t -> EForall iks <$> derefUVar t
_ -> impossible
@@ -686,7 +686,7 @@
tcErrorTK :: --XHasCallStack =>
SLoc -> String -> T ()
-tcErrorTK loc msg = T.do
+tcErrorTK loc msg = do
tcm <- gets tcMode
let s = case tcm of
TCType -> "kind"
@@ -695,7 +695,7 @@
unify :: --XHasCallStack =>
SLoc -> EType -> EType -> T ()
-unify loc a b = T.do
+unify loc a b = do
aa <- expandSyn a
bb <- expandSyn b
unifyR loc aa bb
@@ -703,9 +703,9 @@
-- XXX should do occur check
unifyR :: --XHasCallStack =>
SLoc -> EType -> EType -> T ()
-unifyR _ (EVar x1) (EVar x2) | x1 == x2 = T.return ()
-unifyR loc (EApp f1 a1) (EApp f2 a2) = T.do { unifyR loc f1 f2; unifyR loc a1 a2 }-unifyR _ (EUVar r1) (EUVar r2) | r1 == r2 = T.return ()
+unifyR _ (EVar x1) (EVar x2) | x1 == x2 = return ()
+unifyR loc (EApp f1 a1) (EApp f2 a2) = do { unifyR loc f1 f2; unifyR loc a1 a2 }+unifyR _ (EUVar r1) (EUVar r2) | r1 == r2 = return ()
unifyR loc (EUVar r1) t2 = unifyVar loc r1 t2
unifyR loc t1 (EUVar r2) = unifyVar loc r2 t1
unifyR loc t1 t2 =
@@ -713,7 +713,7 @@
unifyVar :: --XHasCallStack =>
SLoc -> TRef -> EType -> T ()
-unifyVar loc r t = T.do
+unifyVar loc r t = do
mt <- getUVar r
case mt of
Nothing -> unifyUnboundVar loc r t
@@ -721,13 +721,13 @@
unifyUnboundVar :: --XHasCallStack =>
SLoc -> TRef -> EType -> T ()
-unifyUnboundVar loc r1 at2@(EUVar r2) = T.do
+unifyUnboundVar loc r1 at2@(EUVar r2) = do
-- We know r1 /= r2
mt2 <- getUVar r2
case mt2 of
Nothing -> setUVar r1 at2
Just t2 -> unify loc (EUVar r1) t2
-unifyUnboundVar loc r1 t2 = T.do
+unifyUnboundVar loc r1 t2 = do
vs <- getMetaTyVars [t2]
if elemBy (==) r1 vs then
tcErrorTK loc $ "cyclic " ++ showExpr (EUVar r1) ++ " = " ++ showExpr t2
@@ -736,7 +736,7 @@
-- Reset unification map
tcReset :: T ()
-tcReset = T.do
+tcReset = do
TC mn u fx tenv senv venv ast _ m cs is es <- get
put (TC mn u fx tenv senv venv ast IM.empty m cs is es)
@@ -746,28 +746,28 @@
type TRef = Int
newUniq :: T TRef
-newUniq = T.do
+newUniq = do
TC mn n fx tenv senv venv ast sub m cs is es <- get
let n' = n+1
put (seq n' $ TC mn n' fx tenv senv venv ast sub m cs is es)
- T.return n
+ return n
newIdent :: SLoc -> String -> T Ident
-newIdent loc s = T.do
+newIdent loc s = do
u <- newUniq
- T.return $ mkIdentSLoc loc $ s ++ "$" ++ show u
+ return $ mkIdentSLoc loc $ s ++ "$" ++ show u
tLookup :: --XHasCallStack =>
String -> Ident -> T (Expr, EType)
-tLookup msg i = T.do
+tLookup msg i = do
env <- gets valueTable
case stLookup msg i env of
- Right (Entry e s) -> T.return (setSLocExpr (getSLocIdent i) e, s)
+ Right (Entry e s) -> return (setSLocExpr (getSLocIdent i) e, s)
Left e -> tcError (getSLocIdent i) e
tLookupV :: --XHasCallStack =>
Ident -> T (Expr, EType)
-tLookupV i = T.do
+tLookupV i = do
tcm <- gets tcMode
let s = case tcm of
TCType -> "type"
@@ -776,21 +776,21 @@
-- Maybe iterate these?
tInst :: (Expr, EType) -> T (Expr, EType)
-tInst t = tInst' t T.>>= tDict T.>>= tInst'
+tInst t = tInst' t >>= tDict >>= tInst'
tInst' :: (Expr, EType) -> T (Expr, EType)
tInst' (ae, EForall vks t) =
if null vks then
- T.return (ae, t)
- else T.do
+ return (ae, t)
+ else do
let vs = map idKindIdent vks
- us <- T.mapM (const newUVar) vks
+ us <- mapM (const newUVar) vks
-- tInst' (ae, subst (zip vs us) t)
- T.return (ae, subst (zip vs us) t)
-tInst' et = T.return et
+ return (ae, subst (zip vs us) t)
+tInst' et = return et
tDict :: (Expr, EType) -> T (Expr, EType)
-tDict (ae, at) | Just (ctx, t) <- getImplies at = T.do
+tDict (ae, at) | Just (ctx, t) <- getImplies at = do
u <- newUniq
let d = mkIdentSLoc loc ("dict$" ++ show u)loc = getSLocExpr ae
@@ -797,11 +797,11 @@
--traceM $ "addConstraint: " ++ showIdent d ++ " :: " ++ showEType ctx ++ " " ++ showSLoc loc
addConstraint d ctx
tDict (EApp ae (EVar d), t)
-tDict at = T.return at
+tDict at = return at
extValE :: --XHasCallStack =>
Ident -> EType -> Expr -> T ()
-extValE i t e = T.do
+extValE i t e = do
venv <- gets valueTable
putValueTable (stInsertLcl i (Entry e t) venv)
@@ -809,7 +809,7 @@
-- Add both qualified and unqualified versions of i.
extValETop :: --XHasCallStack =>
Ident -> EType -> Expr -> T ()
-extValETop i t e = T.do
+extValETop i t e = do
mn <- gets moduleName
venv <- gets valueTable
let qi = qualIdent mn i
@@ -822,7 +822,7 @@
-- Add both qualified and unqualified versions of i.
extValQTop :: --XHasCallStack =>
Ident -> EType -> T ()
-extValQTop i t = T.do
+extValQTop i t = do
mn <- gets moduleName
extValETop i t (EVar (qualIdent mn i))
@@ -832,108 +832,108 @@
extVals :: --XHasCallStack =>
[(Ident, EType)] -> T ()
-extVals = T.mapM_ (uncurry extVal)
+extVals = mapM_ (uncurry extVal)
extTyp :: Ident -> EType -> T ()
-extTyp i t = T.do
+extTyp i t = do
tenv <- gets typeTable
putTypeTable (stInsertLcl i (Entry (EVar i) t) tenv)
extTyps :: [(Ident, EType)] -> T ()
-extTyps = T.mapM_ (uncurry extTyp)
+extTyps = mapM_ (uncurry extTyp)
extSyn :: Ident -> EType -> T ()
-extSyn i t = T.do
+extSyn i t = do
senv <- gets synTable
putSynTable (M.insert i t senv)
extFix :: Ident -> Fixity -> T ()
-extFix i fx = T.do
+extFix i fx = do
TC mn n fenv tenv senv venv ast sub m cs is es <- get
put $ TC mn n (M.insert i fx fenv) tenv senv venv ast sub m cs is es
- T.return ()
+ return ()
withExtVal :: forall a . --XHasCallStack =>
Ident -> EType -> T a -> T a
-withExtVal i t ta = T.do
+withExtVal i t ta = do
venv <- gets valueTable
extVal i t
a <- ta
putValueTable venv
- T.return a
+ return a
withExtVals :: forall a . --XHasCallStack =>
[(Ident, EType)] -> T a -> T a
-withExtVals env ta = T.do
+withExtVals env ta = do
venv <- gets valueTable
extVals env
a <- ta
putValueTable venv
- T.return a
+ return a
withExtTyps :: forall a . [IdKind] -> T a -> T a
-withExtTyps iks ta = T.do
+withExtTyps iks ta = do
let env = map (\ (IdKind v k) -> (v, k)) iks
venv <- gets typeTable
extTyps env
a <- ta
putTypeTable venv
- T.return a
+ return a
tcDefs :: [EDef] -> T [EDef]
-tcDefs ds = T.do
- T.mapM_ tcAddInfix ds
+tcDefs ds = do
+ mapM_ tcAddInfix ds
dst <- tcDefsType ds
- T.mapM_ addTypeSyn dst
+ mapM_ addTypeSyn dst
dst' <- tcExpand dst
-- traceM (showEDefs dst')
tcDefsValue dst'
tcAddInfix :: EDef -> T ()
-tcAddInfix (Infix fx is) = T.do
+tcAddInfix (Infix fx is) = do
mn <- gets moduleName
- T.mapM_ (\ i -> extFix (qualIdent mn i) fx) is
-tcAddInfix _ = T.return ()
+ mapM_ (\ i -> extFix (qualIdent mn i) fx) is
+tcAddInfix _ = return ()
-- Check type definitions
tcDefsType :: [EDef] -> T [EDef]
-tcDefsType ds = withTypeTable $ T.do
- dsk <- T.mapM tcDefKind ds -- Check&rename kinds in all type definitions
- T.mapM_ addTypeKind dsk -- Add the kind of each type to the environment
- T.mapM tcDefType dsk -- Kind check all type expressions (except local signatures)
+tcDefsType ds = withTypeTable $ do
+ dsk <- mapM tcDefKind ds -- Check&rename kinds in all type definitions
+ mapM_ addTypeKind dsk -- Add the kind of each type to the environment
+ mapM tcDefType dsk -- Kind check all type expressions (except local signatures)
-- Expand class and instance definitions (must be done after type synonym processing)
tcExpand :: [EDef] -> T [EDef]
-tcExpand dst = withTypeTable $ T.do
- dsc <- T.mapM expandClass dst -- Expand all class definitions
- dsi <- T.mapM expandInst (concat dsc) -- Expand all instance definitions
- T.return (concat dsi)
+tcExpand dst = withTypeTable $ do
+ dsc <- mapM expandClass dst -- Expand all class definitions
+ dsi <- mapM expandInst (concat dsc) -- Expand all instance definitions
+ return (concat dsi)
-- Make sure that the kind expressions are well formed.
tcDefKind :: EDef -> T EDef
-tcDefKind adef = T.do
+tcDefKind adef = do
tcReset
case adef of
- Data (i, vks) cs -> withVks vks kType $ \ vvks _ -> T.return $ Data (i, vvks) cs
- Newtype (i, vks) c -> withVks vks kType $ \ vvks _ -> T.return $ Newtype (i, vvks) c
+ Data (i, vks) cs -> withVks vks kType $ \ vvks _ -> return $ Data (i, vvks) cs
+ Newtype (i, vks) c -> withVks vks kType $ \ vvks _ -> return $ Newtype (i, vvks) c
Type (i, vks) at ->
case at of
- ESign t k -> withVks vks k $ \ vvks kr -> T.return $ Type (i, vvks) (ESign t kr)
- _ -> withVks vks kType $ \ vvks _ -> T.return $ Type (i, vvks) at
- Class ctx (i, vks) fds ms-> withVks vks kConstraint $ \ vvks _ -> T.return $ Class ctx (i, vvks) fds ms
- Instance vks ctx t d -> withVks vks kConstraint $ \ vvks _ -> T.return $ Instance vvks ctx t d
- _ -> T.return adef
+ ESign t k -> withVks vks k $ \ vvks kr -> return $ Type (i, vvks) (ESign t kr)
+ _ -> withVks vks kType $ \ vvks _ -> return $ Type (i, vvks) at
+ Class ctx (i, vks) fds ms-> withVks vks kConstraint $ \ vvks _ -> return $ Class ctx (i, vvks) fds ms
+ Instance vks ctx t d -> withVks vks kConstraint $ \ vvks _ -> return $ Instance vvks ctx t d
+ _ -> return adef
-- Check&rename the given kinds, apply reconstruction at the end
withVks :: forall a . [IdKind] -> EKind -> ([IdKind] -> EKind -> T a) -> T a
-withVks vks kr fun = T.do
+withVks vks kr fun = do
(nvks, nkr) <-
- withTypeTable $ T.do
+ withTypeTable $ do
let
- loop r [] = T.do
+ loop r [] = do
kkr <- tInferTypeT kr
- T.return (reverse r, kkr)
- loop r (IdKind i k : iks) = T.do
+ return (reverse r, kkr)
+ loop r (IdKind i k : iks) = do
kk <- tInferTypeT k
withExtVal i kk $ loop (IdKind i kk : r) iks
loop [] vks
@@ -941,25 +941,25 @@
-- Add symbol table entries (with kind) for all top level typeish definitions
addTypeKind :: EDef -> T ()
-addTypeKind adef = T.do
+addTypeKind adef = do
let
- addAssoc i is = T.do
+ addAssoc i is = do
mn <- gets moduleName
addAssocTable (qualIdent mn i) (map (qualIdent mn) is)
assocData (Constr c (Left _)) = [c]
assocData (Constr c (Right its)) = c : map fst its
case adef of
- Data lhs@(i, _) cs -> T.do
+ Data lhs@(i, _) cs -> do
addLHSKind lhs kType
addAssoc i (nub $ concatMap assocData cs)
- Newtype lhs@(i, _) c -> T.do
+ Newtype lhs@(i, _) c -> do
addLHSKind lhs kType
addAssoc i (assocData c)
Type lhs t -> addLHSKind lhs (getTypeKind t)
- Class _ lhs@(i, _) _ ms -> T.do
+ Class _ lhs@(i, _) _ ms -> do
addLHSKind lhs kConstraint
addAssoc i [ m | BSign m _ <- ms ]
- _ -> T.return ()
+ _ -> return ()
getTypeKind :: EType -> EKind
getTypeKind (ESign _ k) = k
@@ -977,44 +977,44 @@
addTypeSyn :: EDef -> T ()
addTypeSyn adef =
case adef of
- Type (i, vs) t -> T.do
+ Type (i, vs) t -> do
let t' = EForall vs t
extSyn i t'
mn <- gets moduleName
extSyn (qualIdent mn i) t'
- _ -> T.return ()
+ _ -> return ()
-- Do kind checking of all typeish definitions.
tcDefType :: EDef -> T EDef
-tcDefType d = T.do
+tcDefType d = do
tcReset
case d of
- Data lhs@(_, iks) cs -> withVars iks $ Data lhs <$> T.mapM tcConstr cs
+ Data lhs@(_, iks) cs -> withVars iks $ Data lhs <$> mapM tcConstr cs
Newtype lhs@(_, iks) c -> withVars iks $ Newtype lhs <$> tcConstr c
Type lhs@(_, iks) t -> withVars iks $ Type lhs <$> tInferTypeT t
Sign i t -> Sign i <$> tCheckTypeT kType t
ForImp ie i t -> ForImp ie i <$> tCheckTypeT kType t
- Class ctx lhs@(_, iks) fds ms -> withVars iks $ Class <$> tcCtx ctx T.<*> T.return lhs <*> mapM tcFD fds T.<*> T.mapM tcMethod ms
- Instance iks ctx c m -> withVars iks $ Instance iks <$> tcCtx ctx T.<*> tCheckTypeT kConstraint c T.<*> T.return m
- _ -> T.return d
+ Class ctx lhs@(_, iks) fds ms -> withVars iks $ Class <$> tcCtx ctx <*> return lhs <*> mapM tcFD fds <*> mapM tcMethod ms
+ Instance iks ctx c m -> withVars iks $ Instance iks <$> tcCtx ctx <*> tCheckTypeT kConstraint c <*> return m
+ _ -> return d
where
- tcCtx = T.mapM (tCheckTypeT kConstraint)
+ tcCtx = mapM (tCheckTypeT kConstraint)
tcMethod (BSign i t) = BSign i <$> tcTypeT (Check kType) t
- tcMethod m = T.return m
+ tcMethod m = return m
tcFD (is, os) = (,) <$> mapM tcV is <*> mapM tcV os
- where tcV i = T.do { _ <- tLookup "fundep" i; T.return i }+ where tcV i = do { _ <- tLookup "fundep" i; return i }withVars :: forall a . [IdKind] -> T a -> T a
withVars aiks ta =
case aiks of
[] -> ta
- IdKind i k : iks -> T.do
+ IdKind i k : iks -> do
withExtVal i k $ withVars iks ta
tcConstr :: Constr -> T Constr
tcConstr (Constr c ets) =
- Constr c <$> either (\ x -> Left T.<$> T.mapM (\ t -> tcTypeT (Check kType) t) x)
- (\ x -> Right T.<$> T.mapM (\ (i,t) -> (i,) <$> tcTypeT (Check kType) t) x) ets
+ Constr c <$> either (\ x -> Left <$> mapM (\ t -> tcTypeT (Check kType) t) x)
+ (\ x -> Right <$> mapM (\ (i,t) -> (i,) <$> tcTypeT (Check kType) t) x) ets
-- Expand a class defintion to
@@ -1067,7 +1067,7 @@
-- The constructor and methods are added to the symbol table in addValueType.
-- XXX FunDep
expandClass :: EDef -> T [EDef]
-expandClass dcls@(Class ctx (iCls, vks) _fds ms) = T.do
+expandClass dcls@(Class ctx (iCls, vks) _fds ms) = do
mn <- gets moduleName
let
meths = [ b | b@(BSign _ _) <- ms ]
@@ -1083,8 +1083,8 @@
mkDflt _ = impossible
dDflts = concatMap mkDflt meths
addClassTable (qualIdent mn iCls) (vks, ctx, EUVar 0, methIds) -- Initial entry, no type needed.
- T.return $ dcls : dDflts
-expandClass d = T.return [d]
+ return $ dcls : dDflts
+expandClass d = return [d]
noDefaultE :: Expr
noDefaultE = ELit noSLoc $ LPrim "noDefault"
@@ -1095,9 +1095,9 @@
{-clsToDict :: EType -> T EType
-clsToDict = T.do
+clsToDict = do
-- XXX for now, only allow contexts of the form (C t1 ... tn)
- let usup as (EVar c) | isConIdent c = T.return (tApps c as)
+ let usup as (EVar c) | isConIdent c = return (tApps c as)
usup as (EApp f a) = usup (a:as) f
usup _ t = tcError (getSLocExpr t) ("bad context " ++ showEType t)usup []
@@ -1113,7 +1113,7 @@
tupleConstraints cs = tApps (tupleConstr noSLoc (length cs)) cs
expandInst :: EDef -> T [EDef]
-expandInst dinst@(Instance vks ctx cc bs) = T.do
+expandInst dinst@(Instance vks ctx cc bs) = do
let loc = getSLocExpr cc
qiCls = getAppCon cc
iInst <- newIdent loc "inst"
@@ -1124,7 +1124,7 @@
(_, supers, _, mis) <-
case M.lookup qiCls ct of
Nothing -> tcError loc $ "not a class " ++ showIdent qiCls
- Just x -> T.return x
+ Just x -> return x
-- XXX this ignores type signatures and other bindings
-- XXX should tack on signatures with ESign
let ies = [(i, ELam qs) | BFcn i qs <- bs]
@@ -1135,8 +1135,8 @@
let bind = Fcn iInst $ eEqns [] $ foldl EApp (EVar $ mkClassConstructor qiCls) args
mn <- gets moduleName
addInstTable [(EVar $ qualIdent mn iInst, vks, ctx, cc)]
- T.return [dinst, sign, bind]
-expandInst d = T.return [d]
+ return [dinst, sign, bind]
+expandInst d = return [d]
eForall :: [IdKind] -> EType -> EType
eForall [] t = t
@@ -1145,24 +1145,24 @@
---------------------
tcDefsValue :: [EDef] -> T [EDef]
-tcDefsValue ds = T.do
- T.mapM_ addValueType ds
- T.mapM (\ d -> T.do { tcReset; tcDefValue d}) ds+tcDefsValue ds = do
+ mapM_ addValueType ds
+ mapM (\ d -> do { tcReset; tcDefValue d}) dsaddValueType :: EDef -> T ()
-addValueType adef = T.do
+addValueType adef = do
mn <- gets moduleName
case adef of
Sign i t -> extValQTop i t
- Data (i, vks) cs -> T.do
+ Data (i, vks) cs -> do
let
cti = [ (qualIdent mn c, either length length ets) | Constr c ets <- cs ]
tret = foldl tApp (tCon (qualIdent mn i)) (map tVarK vks)
- addCon (Constr c ets) = T.do
+ addCon (Constr c ets) = do
let ts = either id (map snd) ets
extValETop c (EForall vks $ foldr tArrow tret ts) (ECon $ ConData cti (qualIdent mn c))
- T.mapM_ addCon cs
- Newtype (i, vks) (Constr c fs) -> T.do
+ mapM_ addCon cs
+ Newtype (i, vks) (Constr c fs) -> do
let
t = head $ either id (map snd) fs
tret = foldl tApp (tCon (qualIdent mn i)) (map tVarK vks)
@@ -1169,11 +1169,11 @@
extValETop c (EForall vks $ tArrow t tret) (ECon $ ConNew (qualIdent mn c))
ForImp _ i t -> extValQTop i t
Class ctx (i, vks) fds ms -> addValueClass ctx i vks fds ms
- _ -> T.return ()
+ _ -> return ()
-- XXX FunDep
addValueClass :: [EConstraint] -> Ident -> [IdKind] -> [FunDep] -> [EBind] -> T ()
-addValueClass ctx iCls vks _fds ms = T.do
+addValueClass ctx iCls vks _fds ms = do
mn <- gets moduleName
let
meths = [ b | b@(BSign _ _) <- ms ]
@@ -1190,7 +1190,7 @@
let addMethod (BSign i t) = extValETop i (EForall vks $ tApps qiCls (map (EVar . idKindIdent) vks) `tImplies` t) (EVar $ qualIdent mn i)
addMethod _ = impossible
-- traceM ("addValueClass " ++ showEType (ETuple ctx))- T.mapM_ addMethod meths
+ mapM_ addMethod meths
-- Update class table, now with actual constructor type.
addClassTable qiCls (vks, ctx, iConTy, methIds)
@@ -1214,7 +1214,7 @@
EDef -> T EDef
tcDefValue adef =
case adef of
- Fcn i eqns -> T.do
+ Fcn i eqns -> do
(_, tt) <- tLookup "type signature" i
-- traceM $ "tcDefValue: " ++ showIdent i ++ " :: " ++ showExpr tt
-- traceM $ "tcDefValue: def=" ++ showEDefs [adef]
@@ -1222,11 +1222,11 @@
teqns <- tcEqns tt eqns
-- traceM ("tcDefValue: after " ++ showEDefs [adef, Fcn i teqns])checkConstraints
- T.return $ Fcn (qualIdent mn i) teqns
- ForImp ie i t -> T.do
+ return $ Fcn (qualIdent mn i) teqns
+ ForImp ie i t -> do
mn <- gets moduleName
- T.return (ForImp ie (qualIdent mn i) t)
- _ -> T.return adef
+ return (ForImp ie (qualIdent mn i) t)
+ _ -> return adef
tCheckTypeT :: EType -> EType -> T EType
tCheckTypeT = tCheck tcTypeT
@@ -1260,11 +1260,11 @@
tInfer :: forall a . --XHasCallStack =>
(Expected -> a -> T a) -> a -> T (Typed a)
-tInfer tc a = T.do
+tInfer tc a = do
ref <- newUniq
a' <- tc (Infer ref) a
t <- tGetRefType ref
- T.return (a', t)
+ return (a', t)
tCheck :: forall a . (Expected -> a -> T a) -> EType -> a -> T a
tCheck tc t = tc (Check t)
@@ -1275,26 +1275,26 @@
tCheckExpr :: --XHasCallStack =>
EType -> Expr -> T Expr
-tCheckExpr t e | Just (ctx, t') <- getImplies t = T.do
+tCheckExpr t e | Just (ctx, t') <- getImplies t = do
_ <- undefined -- XXX
u <- newUniq
let d = mkIdentSLoc (getSLocExpr e) ("adict$" ++ show u)e' <- withDict d ctx $ tCheckExpr t' e
- T.return $ eLam [EVar d] e'
+ return $ eLam [EVar d] e'
tCheckExpr t e = tCheck tcExpr t e
tGetRefType :: --XHasCallStack =>
TRef -> T EType
-tGetRefType ref = T.do
+tGetRefType ref = do
m <- gets uvarSubst
case IM.lookup ref m of
- Nothing -> T.return (EUVar ref) -- error "tGetRefType"
- Just t -> T.return t
+ Nothing -> return (EUVar ref) -- error "tGetRefType"
+ Just t -> return t
-- Set the type for an Infer
tSetRefType :: --XHasCallStack =>
SLoc -> TRef -> EType -> T ()
-tSetRefType loc ref t = T.do
+tSetRefType loc ref t = do
m <- gets uvarSubst
case IM.lookup ref m of
Nothing -> putUvarSubst (IM.insert ref t m)
@@ -1302,48 +1302,48 @@
-- Get the type of an already set Expected
tGetExpType :: Expected -> T EType
-tGetExpType (Check t) = T.return t
+tGetExpType (Check t) = return t
tGetExpType (Infer r) = tGetRefType r
{--- Get the type of a possibly unset Expected
tGetExpTypeSet :: SLoc -> Expected -> T EType
-tGetExpTypeSet _ (Check t) = T.return t
-tGetExpTypeSet loc (Infer r) = tGetRefType r {-T.do+tGetExpTypeSet _ (Check t) = return t
+tGetExpTypeSet loc (Infer r) = tGetRefType r {-dot <- newUVar
tSetRefType loc r t
- T.return t-}
+ return t-}
-}
tcExpr :: --XHasCallStack =>
Expected -> Expr -> T Expr
-tcExpr mt ae = T.do
+tcExpr mt ae = do
-- traceM ("tcExpr enter: " ++ showExpr ae)r <- tcExprR mt ae
-- traceM ("tcExpr exit: " ++ showExpr r)- T.return r
+ return r
tcExprR :: --XHasCallStack =>
Expected -> Expr -> T Expr
tcExprR mt ae =
let { loc = getSLocExpr ae } incase ae of
- EVar i -> T.do
+ EVar i -> do
tcm <- gets tcMode
case tcm of
- TCPat | isDummyIdent i -> T.do
+ TCPat | isDummyIdent i -> do
-- _ can be anything, so just ignore it
_ <- tGetExpType mt
- T.return ae
+ return ae
- | isConIdent i -> T.do
+ | isConIdent i -> do
ipt <- tLookupV i
(p, pt) <- tInst' ipt -- XXX
-- We will only have an expected type for a non-nullary constructor
case mt of
Check ext -> subsCheck loc p ext pt
- Infer r -> T.do { tSetRefType loc r pt; T.return p }+ Infer r -> do { tSetRefType loc r pt; return p }- | otherwise -> T.do
+ | otherwise -> do
-- All pattern variables are in the environment as
-- type references. Assign the reference the given type.
ext <- tGetExpType mt
@@ -1351,19 +1351,19 @@
case t of
EUVar r -> tSetRefType loc r ext
_ -> impossible
- T.return p
+ return p
- _ | isIdent "dict$" i -> T.do
+ _ | isIdent "dict$" i -> do
-- Magic variable that just becomes the dictionary
d <- newIdent (getSLocIdent i) "dict$"
case mt of
Infer _ -> impossible
Check t -> addConstraint d t
- T.return (EVar d)
+ return (EVar d)
- _ -> T.do
+ _ -> do
-- Type checking an expression (or type)
- T.when (isDummyIdent i) impossible
+ when (isDummyIdent i) impossible
(e, t) <- tLookupV i
-- Variables bound in patterns start out with an (EUVar ref) type,
-- which can be instantiated to a polytype.
@@ -1370,12 +1370,12 @@
-- Dereference such a ref.
t' <-
case t of
- EUVar r -> T.fmap (fromMaybe t) (getUVar r)
- _ -> T.return t
+ EUVar r -> fmap (fromMaybe t) (getUVar r)
+ _ -> return t
-- traceM ("EVar " ++ showIdent i ++ " :: " ++ showExpr t ++ " = " ++ showExpr t')instSigma loc e t' mt
- EApp f a -> T.do
+ EApp f a -> do
(f', ft) <- tInferExpr f
-- traceM $ "EApp f=" ++ showExpr f ++ "; e'=" ++ showExpr f' ++ " :: " ++ showEType ft
(at, rt) <- unArrow loc ft
@@ -1382,32 +1382,32 @@
tcm <- gets tcMode
-- traceM ("tcExpr EApp: " ++ showExpr f ++ " :: " ++ showEType ft)case tcm of
- TCPat -> T.do
+ TCPat -> do
a' <- tCheckExpr at a
instPatSigma loc rt mt
- T.return (EApp f' a')
- _ -> T.do
+ return (EApp f' a')
+ _ -> do
a' <- checkSigma a at
instSigma loc (EApp f' a') rt mt
- EOper e ies -> T.do e' <- tcOper e ies; tcExpr mt e'
+ EOper e ies -> do e' <- tcOper e ies; tcExpr mt e'
ELam qs -> tcExprLam mt qs
ELit loc' l -> tcLit mt loc' l
- ECase a arms -> T.do
+ ECase a arms -> do
(ea, ta) <- tInferExpr a
tt <- tGetExpType mt
- earms <- T.mapM (tcArm tt ta) arms
- T.return (ECase ea earms)
- ELet bs a -> tcBinds bs $ \ ebs -> T.do { ea <- tcExpr mt a; T.return (ELet ebs ea) }- ETuple es -> T.do
+ earms <- mapM (tcArm tt ta) arms
+ return (ECase ea earms)
+ ELet bs a -> tcBinds bs $ \ ebs -> do { ea <- tcExpr mt a; return (ELet ebs ea) }+ ETuple es -> do
let
n = length es
- (ees, tes) <- T.fmap unzip (T.mapM tInferExpr es)
+ (ees, tes) <- fmap unzip (mapM tInferExpr es)
let
ttup = tApps (tupleConstr loc n) tes
munify loc mt ttup
- T.return (ETuple ees)
- EDo mmn ass -> T.do
+ return (ETuple ees)
+ EDo mmn ass -> do
case ass of
[] -> impossible
[as] ->
@@ -1414,14 +1414,14 @@
case as of
SThen a -> tcExpr mt a
_ -> tcError loc $ "bad final do statement"
- as : ss -> T.do
+ as : ss -> do
case as of
- SBind p a -> T.do
+ SBind p a -> do
let
sbind = maybe (mkIdentSLoc loc ">>=") (\ mn -> qualIdent mn (mkIdentSLoc loc ">>=")) mmn
tcExpr mt (EApp (EApp (EVar sbind) a)
(eLam [eVarI loc "$x"] (ECase (eVarI loc "$x") [(p, EAlts [([], EDo mmn ss)] [])])))
- SThen a -> T.do
+ SThen a -> do
let
sthen = maybe (mkIdentSLoc loc ">>") (\ mn -> qualIdent mn (mkIdentSLoc loc ">>") ) mmn
tcExpr mt (EApp (EApp (EVar sthen) a) (EDo mmn ss))
@@ -1430,44 +1430,44 @@
tcExpr mt (ELet bs (EDo mmn ss))
ESectL e i -> tcExpr mt (EApp (EVar i) e)
- ESectR i e -> T.do
+ ESectR i e -> do
let x = eVarI loc "$x"
tcExpr mt (eLam [x] (EApp (EApp (EVar i) x) e))
- EIf e1 e2 e3 -> T.do
+ EIf e1 e2 e3 -> do
e1' <- tCheckExpr (tBool (getSLocExpr e1)) e1
case mt of
- Check t -> T.do
+ Check t -> do
e2' <- checkSigma e2 t
e3' <- checkSigma e3 t
- T.return (EIf e1' e2' e3')
- Infer ref -> T.do
+ return (EIf e1' e2' e3')
+ Infer ref -> do
(e2', t2) <- tInferExpr e2
(e3', t3) <- tInferExpr e3
e2'' <- subsCheck loc e2' t2 t3
e3'' <- subsCheck loc e3' t3 t2
tSetRefType loc ref t2
- T.return (EIf e1' e2'' e3'')
+ return (EIf e1' e2'' e3'')
- EListish (LList es) -> T.do
+ EListish (LList es) -> do
te <- newUVar
munify loc mt (tApp (tList loc) te)
- es' <- T.mapM (tCheckExpr te) es
- T.return (EListish (LList es'))
- EListish (LCompr eret ass) -> T.do
+ es' <- mapM (tCheckExpr te) es
+ return (EListish (LList es'))
+ EListish (LCompr eret ass) -> do
let
doStmts :: [EStmt] -> [EStmt] -> T ([EStmt], Typed Expr)
doStmts rss xs =
case xs of
- [] -> T.do
+ [] -> do
r <- tInferExpr eret
- T.return (reverse rss, r)
+ return (reverse rss, r)
as : ss ->
case as of
- SBind p a -> T.do
+ SBind p a -> do
v <- newUVar
ea <- tCheckExpr (tApp (tList loc) v) a
tCheckPat v p $ \ ep -> doStmts (SBind ep ea : rss) ss
- SThen a -> T.do
+ SThen a -> do
ea <- tCheckExpr (tBool (getSLocExpr a)) a
doStmts (SThen ea : rss) ss
SLet bs ->
@@ -1477,22 +1477,22 @@
let
tr = tApp (tList loc) ta
munify loc mt tr
- T.return (EListish (LCompr ea rss))
+ return (EListish (LCompr ea rss))
EListish (LFrom e) -> tcExpr mt (enum loc "From" [e])
EListish (LFromTo e1 e2) -> tcExpr mt (enum loc "FromTo" [e1, e2])
EListish (LFromThen e1 e2) -> tcExpr mt (enum loc "FromThen" [e1,e2])
EListish (LFromThenTo e1 e2 e3) -> tcExpr mt (enum loc "FromThenTo" [e1,e2,e3])
- ESign e t -> T.do
+ ESign e t -> do
t' <- tcType (Check kType) t
tcm <- gets tcMode
case tcm of
- TCPat -> T.do
+ TCPat -> do
instPatSigma loc t' mt
tCheckExpr t' e
- _ -> T.do
+ _ -> do
e' <- instSigma loc e t' mt
checkSigma e' t'
- EAt i e -> T.do
+ EAt i e -> do
(_, ti) <- tLookupV i
e' <- tcExpr mt e
tt <- tGetExpType mt
@@ -1499,11 +1499,11 @@
case ti of
EUVar r -> tSetRefType loc r tt
_ -> impossible
- T.return (EAt i e')
+ return (EAt i e')
EForall vks t ->
- withVks vks kType $ \ vvks _ -> T.do
+ withVks vks kType $ \ vvks _ -> do
tt <- withVars vvks (tcExpr mt t)
- T.return (EForall vvks tt)
+ return (EForall vvks tt)
_ -> impossible
enum :: SLoc -> String -> [Expr] -> Expr
@@ -1510,7 +1510,7 @@
enum loc f = foldl EApp (EVar (mkIdentSLoc loc ("enum" ++ f)))tcLit :: Expected -> SLoc -> Lit -> T Expr
-tcLit mt loc l = T.do
+tcLit mt loc l = do
let lit t = instSigma loc (ELit loc l) t mt
case l of
LInt _ -> lit (tConI loc "Primitives.Int")
@@ -1517,12 +1517,12 @@
LDouble _ -> lit (tConI loc "Primitives.Double")
LChar _ -> lit (tConI loc "Primitives.Char")
LStr _ -> lit (tApp (tList loc) (tConI loc "Primitives.Char"))
- LPrim _ -> newUVar T.>>= lit -- pretend it is anything
+ LPrim _ -> newUVar >>= lit -- pretend it is anything
LForImp _ -> impossible
tcOper :: --XHasCallStack =>
Expr -> [(Ident, Expr)] -> T Expr
-tcOper ae aies = T.do
+tcOper ae aies = do
let
doOp (e1:e2:es) o os ies =
let e = EApp (EApp o e2) e1
@@ -1545,26 +1545,26 @@
calc _ _ _ = impossible
opfix :: FixTable -> (Ident, Expr) -> T ((Expr, Fixity), Expr)
- opfix fixs (i, e) = T.do
+ opfix fixs (i, e) = do
(ei, _) <- tLookupV i
let fx = getFixity fixs (getIdent ei)
- T.return ((EVar i, fx), e)
+ return ((EVar i, fx), e)
fixs <- gets fixTable
-- traceM $ unlines $ map show [(unIdent i, fx) | (i, fx) <- M.toList fixs]
- ites <- T.mapM (opfix fixs) aies
- T.return $ calc [ae] [] ites
+ ites <- mapM (opfix fixs) aies
+ return $ calc [ae] [] ites
unArrow :: --XHasCallStack =>
SLoc -> EType -> T (EType, EType)
-unArrow loc t = T.do
+unArrow loc t = do
case getArrow t of
- Just ar -> T.return ar
- Nothing -> T.do
+ Just ar -> return ar
+ Nothing -> do
a <- newUVar
r <- newUVar
unify loc t (tArrow a r)
- T.return (a, r)
+ return (a, r)
getFixity :: FixTable -> Ident -> Fixity
getFixity fixs i = fromMaybe (AssocLeft, 9) $ M.lookup i fixs
@@ -1571,12 +1571,12 @@
tcPats :: forall a . EType -> [EPat] -> (EType -> [EPat] -> T a) -> T a
tcPats t [] ta = ta t []
-tcPats t (p:ps) ta = T.do
+tcPats t (p:ps) ta = do
(tp, tr) <- unArrow (getSLocExpr p) t
tCheckPat tp p $ \ pp -> tcPats tr ps $ \ tt pps -> ta tt (pp : pps)
tcExprLam :: Expected -> [Eqn] -> T Expr
-tcExprLam mt qs = T.do
+tcExprLam mt qs = do
t <- tGetExpType mt
ELam <$> tcEqns t qs
@@ -1583,48 +1583,48 @@
tcEqns :: EType -> [Eqn] -> T [Eqn]
--tcEqns t eqns | trace ("tcEqns: " ++ showEBind (BFcn dummyIdent eqns) ++ " :: " ++ showEType t) False = undefinedtcEqns (EForall iks t) eqns = withExtTyps iks $ tcEqns t eqns
-tcEqns t eqns | Just (ctx, t') <- getImplies t = T.do
+tcEqns t eqns | Just (ctx, t') <- getImplies t = do
let loc = getSLocEqns eqns
d <- newIdent loc "adict"
f <- newIdent loc "fcnD"
- withDict d ctx $ T.do
+ withDict d ctx $ do
eqns' <- tcEqns t' eqns
let eqn =
case eqns' of
[Eqn [] alts] -> Eqn [EVar d] alts
_ -> Eqn [EVar d] $ EAlts [([], EVar f)] [BFcn f eqns']
- T.return [eqn]
-tcEqns t eqns = T.do
+ return [eqn]
+tcEqns t eqns = do
let loc = getSLocEqns eqns
f <- newIdent loc "fcnS"
- (eqns', ds) <- solveLocalConstraints $ T.mapM (tcEqn t) eqns
+ (eqns', ds) <- solveLocalConstraints $ mapM (tcEqn t) eqns
case ds of
- [] -> T.return eqns'
- _ -> T.do
+ [] -> return eqns'
+ _ -> do
let
bs = eBinds ds
eqn = Eqn [] $ EAlts [([], EVar f)] (bs ++ [BFcn f eqns'])
- T.return [eqn]
+ return [eqn]
tcEqn :: EType -> Eqn -> T Eqn
--tcEqn t _eqn | trace ("tcEqn: " ++ showEType t) False = undefinedtcEqn t eqn =
case eqn of
- Eqn ps alts -> tcPats t ps $ \ tt ps' -> T.do
+ Eqn ps alts -> tcPats t ps $ \ tt ps' -> do
aalts <- tcAlts tt alts
- T.return (Eqn ps' aalts)
+ return (Eqn ps' aalts)
tcAlts :: EType -> EAlts -> T EAlts
tcAlts tt (EAlts alts bs) =
-- trace ("tcAlts: bs in " ++ showEBinds bs) $- tcBinds bs $ \ bbs -> T.do
+ tcBinds bs $ \ bbs -> do
-- traceM ("tcAlts: bs out " ++ showEBinds bbs)- aalts <- T.mapM (tcAlt tt) alts
- T.return (EAlts aalts bbs)
+ aalts <- mapM (tcAlt tt) alts
+ return (EAlts aalts bbs)
tcAlt :: EType -> EAlt -> T EAlt
--tcAlt t (_, rhs) | trace ("tcAlt: " ++ showExpr rhs ++ " :: " ++ showEType t) False = undefined-tcAlt t (ss, rhs) = tcGuards ss $ \ sss -> T.do { rrhs <- tCheckExpr t rhs; T.return (sss, rrhs) }+tcAlt t (ss, rhs) = tcGuards ss $ \ sss -> do { rrhs <- tCheckExpr t rhs; return (sss, rrhs) }tcGuards :: forall a . [EStmt] -> ([EStmt] -> T a) -> T a
tcGuards [] ta = ta []
@@ -1631,10 +1631,10 @@
tcGuards (s:ss) ta = tcGuard s $ \ rs -> tcGuards ss $ \ rss -> ta (rs:rss)
tcGuard :: forall a . EStmt -> (EStmt -> T a) -> T a
-tcGuard (SBind p e) ta = T.do
+tcGuard (SBind p e) ta = do
(ee, tt) <- tInferExpr e
tCheckPat tt p $ \ pp -> ta (SBind pp ee)
-tcGuard (SThen e) ta = T.do
+tcGuard (SThen e) ta = do
ee <- tCheckExpr (tBool (getSLocExpr e)) e
ta (SThen ee)
tcGuard (SLet bs) ta = tcBinds bs $ \ bbs -> ta (SLet bbs)
@@ -1642,9 +1642,9 @@
tcArm :: EType -> EType -> ECaseArm -> T ECaseArm
tcArm t tpat arm =
case arm of
- (p, alts) -> tCheckPat tpat p $ \ pp -> T.do
+ (p, alts) -> tCheckPat tpat p $ \ pp -> do
aalts <- tcAlts t alts
- T.return (pp, aalts)
+ return (pp, aalts)
eBinds :: [(Ident, Expr)] -> [EBind]
eBinds ds = [BFcn i [Eqn [] (EAlts [([], e)] [])] | (i, e) <- ds]
@@ -1652,30 +1652,30 @@
instPatSigma :: --XHasCallStack =>
SLoc -> Sigma -> Expected -> T ()
instPatSigma loc pt (Infer r) = tSetRefType loc r pt
-instPatSigma loc pt (Check t) = T.do { _ <- subsCheck loc undefined t pt; T.return () } -- XXX really?+instPatSigma loc pt (Check t) = do { _ <- subsCheck loc undefined t pt; return () } -- XXX really?subsCheck :: --XHasCallStack =>
SLoc -> Expr -> Sigma -> Sigma -> T Expr
-- (subsCheck args off exp) checks that
-- 'off' is at least as polymorphic as 'args -> exp'
-subsCheck loc exp1 sigma1 sigma2 = T.do -- Rule DEEP-SKOL
+subsCheck loc exp1 sigma1 sigma2 = do -- Rule DEEP-SKOL
(skol_tvs, rho2) <- skolemise sigma2
exp1' <- subsCheckRho loc exp1 sigma1 rho2
esc_tvs <- getFreeTyVars [sigma1,sigma2]
let bad_tvs = filter (\ i -> elem i esc_tvs) skol_tvs
- T.when (not (null bad_tvs)) $
+ when (not (null bad_tvs)) $
tcErrorTK loc "Subsumption check failed"
- T.return exp1'
+ return exp1'
tCheckPat :: forall a . EType -> EPat -> (EPat -> T a) -> T a
-tCheckPat t p@(EVar v) ta | not (isConIdent v) = T.do -- simple special case
+tCheckPat t p@(EVar v) ta | not (isConIdent v) = do -- simple special case
withExtVals [(v, t)] $ ta p
-tCheckPat t ap ta = T.do
+tCheckPat t ap ta = do
-- traceM $ "tcPat: " ++ show ap
let vs = patVars ap
multCheck vs
- env <- T.mapM (\ v -> (v,) <$> newUVar) vs
- withExtVals env $ T.do
+ env <- mapM (\ v -> (v,) <$> newUVar) vs
+ withExtVals env $ do
pp <- withTCMode TCPat $ tCheckExpr t ap
() <- checkArity 0 pp
ta pp
@@ -1682,12 +1682,12 @@
multCheck :: [Ident] -> T ()
multCheck vs =
- T.when (anySame vs) $ T.do
+ when (anySame vs) $ do
let v = head vs
tcError (getSLocIdent v) $ "Multiply defined: " ++ showIdent v
checkArity :: Int -> EPat -> T ()
-checkArity n (EApp f a) = T.do
+checkArity n (EApp f a) = do
checkArity (n+1) f
checkArity 0 a
checkArity n (ECon c) =
@@ -1697,7 +1697,7 @@
else if n > a then
tcError (getSLocCon c) "too many arguments"
else
- T.return ()
+ return ()
checkArity n (EAt _ p) = checkArity n p
checkArity n (ESign p _) = checkArity n p
checkArity n p =
@@ -1710,41 +1710,41 @@
--Xerror (show p)
impossible
where
- check0 = if n /= 0 then tcError (getSLocExpr p) "Bad pattern" else T.return ()
+ check0 = if n /= 0 then tcError (getSLocExpr p) "Bad pattern" else return ()
tcBinds :: forall a . [EBind] -> ([EBind] -> T a) -> T a
-tcBinds xbs ta = T.do
+tcBinds xbs ta = do
let
tmap = M.fromList [ (i, t) | BSign i t <- xbs ]
xs = getBindsVars xbs
multCheck xs
- xts <- T.mapM (tcBindVarT tmap) xs
- withExtVals xts $ T.do
- nbs <- T.mapM tcBind xbs
+ xts <- mapM (tcBindVarT tmap) xs
+ withExtVals xts $ do
+ nbs <- mapM tcBind xbs
ta nbs
tcBindVarT :: M.Map EType -> Ident -> T (Ident, EType)
-tcBindVarT tmap x = T.do
+tcBindVarT tmap x = do
case M.lookup x tmap of
- Nothing -> T.do
+ Nothing -> do
t <- newUVar
- T.return (x, t)
- Just t -> T.do
+ return (x, t)
+ Just t -> do
tt <- withTypeTable $ tcTypeT (Check kType) t
- T.return (x, tt)
+ return (x, tt)
tcBind :: EBind -> T EBind
tcBind abind =
case abind of
- BFcn i eqns -> T.do
+ BFcn i eqns -> do
(_, tt) <- tLookupV i
teqns <- tcEqns tt eqns
- T.return $ BFcn i teqns
- BPat p a -> T.do
+ return $ BFcn i teqns
+ BPat p a -> do
(ep, tp) <- withTCMode TCPat $ tInferExpr p -- pattern variables already bound
ea <- tCheckExpr tp a
- T.return $ BPat ep ea
- BSign _ _ -> T.return abind
+ return $ BPat ep ea
+ BSign _ _ -> return abind
-- Desugar [T] and (T,T,...)
dsType :: EType -> EType
@@ -1789,14 +1789,14 @@
-----------------------------------------------------
getFreeTyVars :: [EType] -> T [TyVar]
-getFreeTyVars tys = T.do
- tys' <- T.mapM derefUVar tys
- T.return (freeTyVars tys')
+getFreeTyVars tys = do
+ tys' <- mapM derefUVar tys
+ return (freeTyVars tys')
getMetaTyVars :: [EType] -> T [TRef]
-getMetaTyVars tys = T.do
- tys' <- T.mapM derefUVar tys
- T.return (metaTvs tys')
+getMetaTyVars tys = do
+ tys' <- mapM derefUVar tys
+ return (metaTvs tys')
getEnvTypes :: T [EType]
getEnvTypes = gets (map entryType . stElemsLcl . valueTable)
@@ -1804,10 +1804,10 @@
{-quantify :: [MetaTv] -> Rho -> T Sigma
-- Quantify over the specified type variables (all flexible)
-quantify tvs ty = T.do
- T.mapM_ bind (tvs `zip` new_bndrs) -- 'bind' is just a cunning way
+quantify tvs ty = do
+ mapM_ bind (tvs `zip` new_bndrs) -- 'bind' is just a cunning way
ty' <- zonkType ty -- of doing the substitution
- T.return (EForall new_bndrs_kind ty')
+ return (EForall new_bndrs_kind ty')
where
used_bndrs = tyVarBndrs ty -- Avoid quantified type variables in use
new_bndrs = allBinders \\ used_bndrs
@@ -1823,25 +1823,25 @@
Sigma -> T ([TyVar], Rho)
-- Performs deep skolemisation, returning the
-- skolem constants and the skolemised type
-skolemise (EForall tvs ty) = T.do -- Rule PRPOLY
- sks1 <- T.mapM (newSkolemTyVar . idKindIdent) tvs
+skolemise (EForall tvs ty) = do -- Rule PRPOLY
+ sks1 <- mapM (newSkolemTyVar . idKindIdent) tvs
(sks2, ty') <- skolemise (subst (zip (map idKindIdent tvs) (map EVar sks1)) ty)
- T.return (sks1 ++ sks2, ty')
-skolemise t@(EApp _ _) | Just (arg_ty, res_ty) <- getArrow t = T.do -- Rule PRFUN
+ return (sks1 ++ sks2, ty')
+skolemise t@(EApp _ _) | Just (arg_ty, res_ty) <- getArrow t = do -- Rule PRFUN
(sks, res_ty') <- skolemise res_ty
- T.return (sks, arg_ty `tArrow` res_ty')
-skolemise (EApp f a) = T.do
+ return (sks, arg_ty `tArrow` res_ty')
+skolemise (EApp f a) = do
(sks1, f') <- skolemise f
(sks2, a') <- skolemise a
- T.return (sks1 ++ sks2, EApp f' a')
+ return (sks1 ++ sks2, EApp f' a')
skolemise ty =
- T.return ([], ty) -- Rule PRMONO
+ return ([], ty) -- Rule PRMONO
-- Skolem tyvars are just identifiers that start with a uniq
newSkolemTyVar :: Ident -> T Ident
-newSkolemTyVar tv = T.do
+newSkolemTyVar tv = do
uniq <- newUniq
- T.return (mkIdentSLoc (getSLocIdent tv) (unIdent tv ++ "#" ++ show uniq))
+ return (mkIdentSLoc (getSLocIdent tv) (unIdent tv ++ "#" ++ show uniq))
freeTyVars :: [EType] -> [TyVar]
-- Get the free TyVars from a type; no duplicates in result
@@ -1885,7 +1885,7 @@
bndrs _ = undefined
inferSigma :: Expr -> T (Expr, Sigma)
-inferSigma e = T.do
+inferSigma e = do
(e', exp_ty) <- inferRho e
env_tys <- getEnvTypes
env_tvs <- getMetaTyVars env_tys
@@ -1896,52 +1896,52 @@
checkSigma :: --XHasCallStack =>
Expr -> Sigma -> T Expr
-checkSigma expr sigma = T.do
+checkSigma expr sigma = do
(skol_tvs, rho) <- skolemise sigma
expr' <- tCheckExpr rho expr
if null skol_tvs then
-- Fast special case
- T.return expr'
- else T.do
+ return expr'
+ else do
env_tys <- getEnvTypes
esc_tvs <- getFreeTyVars (sigma : env_tys)
let bad_tvs = filter (\ i -> elem i esc_tvs) skol_tvs
- T.when (not (null bad_tvs)) $
+ when (not (null bad_tvs)) $
tcErrorTK (getSLocExpr expr) $ "not polymorphic enough: " ++ unwords (map showIdent bad_tvs)
- T.return expr'
+ return expr'
subsCheckRho :: --XHasCallStack =>
SLoc -> Expr -> Sigma -> Rho -> T Expr
--subsCheckRho _ e1 t1 t2 | trace ("subsCheckRho: " ++ {-showExpr e1 ++ " :: " ++ -} showEType t1 ++ " = " ++ showEType t2) False = undefined-subsCheckRho loc exp1 sigma1@(EForall _ _) rho2 = T.do -- Rule SPEC
+subsCheckRho loc exp1 sigma1@(EForall _ _) rho2 = do -- Rule SPEC
(exp1', rho1) <- tInst (exp1, sigma1)
subsCheckRho loc exp1' rho1 rho2
-subsCheckRho loc exp1 rho1 rho2 | Just (a2, r2) <- getArrow rho2 = T.do -- Rule FUN
+subsCheckRho loc exp1 rho1 rho2 | Just (a2, r2) <- getArrow rho2 = do -- Rule FUN
(a1, r1) <- unArrow loc rho1
subsCheckFun loc exp1 a1 r1 a2 r2
-subsCheckRho loc exp1 rho1 rho2 | Just (a1, r1) <- getArrow rho1 = T.do -- Rule FUN
+subsCheckRho loc exp1 rho1 rho2 | Just (a1, r1) <- getArrow rho1 = do -- Rule FUN
(a2,r2) <- unArrow loc rho2
subsCheckFun loc exp1 a1 r1 a2 r2
-subsCheckRho loc exp1 tau1 tau2 = T.do -- Rule MONO
+subsCheckRho loc exp1 tau1 tau2 = do -- Rule MONO
unify loc tau1 tau2 -- Revert to ordinary unification
- T.return exp1
+ return exp1
subsCheckFun :: --XHasCallStack =>
SLoc -> Expr -> Sigma -> Rho -> Sigma -> Rho -> T Expr
-subsCheckFun loc e1 a1 r1 a2 r2 = T.do
+subsCheckFun loc e1 a1 r1 a2 r2 = do
_ <- subsCheck loc undefined a2 a1 -- XXX
subsCheckRho loc e1 r1 r2
instSigma :: --XHasCallStack =>
SLoc -> Expr -> Sigma -> Expected -> T Expr
-instSigma loc e1 t1 (Check t2) = T.do
+instSigma loc e1 t1 (Check t2) = do
-- traceM ("instSigma: Check " ++ showEType t1 ++ " = " ++ showEType t2)subsCheckRho loc e1 t1 t2
-instSigma loc e1 t1 (Infer r) = T.do
+instSigma loc e1 t1 (Infer r) = do
(e1', t1') <- tInst (e1, t1)
-- traceM ("instSigma: Infer " ++ showEType t1 ++ " ==> " ++ showEType t1')tSetRefType loc r t1'
- T.return e1'
+ return e1'
-----
@@ -1949,20 +1949,20 @@
-- * name components of a tupled constraint
-- * name superclasses of a constraint
expandDict :: Expr -> EConstraint -> T [InstDictC]
-expandDict edict acn = T.do
+expandDict edict acn = do
cn <- expandSyn acn
let
(iCls, args) = getApp cn
case getTupleConstr iCls of
- Just _ -> concat <$> T.mapM (\ (i, a) -> expandDict (mkTupleSel i (length args) `EApp` edict) a) (zip [0..] args)
- Nothing -> T.do
+ Just _ -> concat <$> mapM (\ (i, a) -> expandDict (mkTupleSel i (length args) `EApp` edict) a) (zip [0..] args)
+ Nothing -> do
ct <- gets classTable
let (iks, sups, _, _) = fromMaybe impossible $ M.lookup iCls ct
sub = zip (map idKindIdent iks) args
sups' = map (subst sub) sups
-- mn <- gets moduleName
- insts <- concat <$> T.mapM (\ (i, sup) -> expandDict (EVar (expectQualified $ mkSuperSel iCls i) `EApp` edict) sup) (zip [1 ..] sups')
- T.return $ (edict, [], [], cn) : insts
+ insts <- concat <$> mapM (\ (i, sup) -> expandDict (EVar (expectQualified $ mkSuperSel iCls i) `EApp` edict) sup) (zip [1 ..] sups')
+ return $ (edict, [], [], cn) : insts
mkSuperSel :: --XHasCallStack =>
Ident -> Int -> Ident
@@ -1973,7 +1973,7 @@
-- Solve constraints generated locally in 'ta'.
-- Keep any unsolved ones for later.
solveLocalConstraints :: forall a . T a -> T (a, [(Ident, Expr)])
-solveLocalConstraints ta = T.do
+solveLocalConstraints ta = do
cs <- gets constraints -- old constraints
putConstraints [] -- start empty
a <- ta -- compute, generating constraints
@@ -1980,7 +1980,7 @@
ds <- solveConstraints -- solve those
un <- gets constraints -- get remaining unsolved
putConstraints (un ++ cs) -- put back unsolved and old constraints
- T.return (a, ds)
+ return (a, ds)
{-showInstInfo :: InstInfo -> String
@@ -2005,35 +2005,35 @@
-- Unimplemented:
-- instances with a context
solveConstraints :: T [(Ident, Expr)]
-solveConstraints = T.do
+solveConstraints = do
cs <- gets constraints
if null cs then
- T.return []
- else T.do
+ return []
+ else do
-- traceM "------------------------------------------\nsolveConstraints"
- cs' <- T.mapM (\ (i,t) -> T.do { t' <- derefUVar t; T.return (i,t') }) cs+ cs' <- mapM (\ (i,t) -> do { t' <- derefUVar t; return (i,t') }) cs -- traceM ("constraints:\n" ++ unlines (map showConstraint cs'))it <- gets instTable
-- traceM ("instances:\n" ++ unlines (map showInstDef (M.toList it)))let solve :: [(Ident, EType)] -> [(Ident, EType)] -> [(Ident, Expr)] -> T ([(Ident, EType)], [(Ident, Expr)])
- solve [] uns sol = T.return (uns, sol)
- solve (cns@(di, ct) : cnss) uns sol = T.do
+ solve [] uns sol = return (uns, sol)
+ solve (cns@(di, ct) : cnss) uns sol = do
-- traceM ("trying " ++ showEType ct)let loc = getSLocIdent di
(iCls, cts) = getApp ct
case getTupleConstr iCls of
- Just _ -> T.do
- goals <- T.mapM (\ c -> T.do { d <- newIdent loc "dict"; T.return (d, c) }) cts+ Just _ -> do
+ goals <- mapM (\ c -> do { d <- newIdent loc "dict"; return (d, c) }) cts -- traceM ("split tuple " ++ showListS showConstraint goals)solve (goals ++ cnss) uns ((di, ETuple (map (EVar . fst) goals)) : sol)
Nothing ->
case M.lookup iCls it of
- Nothing -> T.do
+ Nothing -> do
-- traceM ("class missing " ++ showIdent iCls)solve cnss (cns : uns) sol -- no instances, so no chance
Just (InstInfo atomMap insts) ->
case cts of
- [EVar i] -> T.do
+ [EVar i] -> do
-- traceM ("solveSimple " ++ showIdent i ++ " -> " ++ showMaybe showExpr (M.lookup i atomMap))solveSimple (M.lookup i atomMap) cns cnss uns sol
_ -> solveGen loc insts cns cnss uns sol
@@ -2042,7 +2042,7 @@
solveSimple Nothing cns cnss uns sol = solve cnss (cns : uns) sol -- no instance
solveSimple (Just e) (di, _) cnss uns sol = solve cnss uns ((di, e) : sol) -- e is the dictionary expression
- solveGen loc insts cns@(di, ct) cnss uns sol = T.do
+ solveGen loc insts cns@(di, ct) cnss uns sol = do
-- traceM ("solveGen " ++ showEType ct)let (_, ts) = getApp ct
matches = getBestMatches $ findMatches insts ts
@@ -2052,7 +2052,7 @@
[(de, ctx)] ->
if null ctx then
solve cnss uns ((di, de) : sol)
- else T.do
+ else do
d <- newIdent loc "dict"
-- traceM ("constraint " ++ showIdent di ++ " :: " ++ showEType ct ++ "\n" ++-- " turns into " ++ showIdent d ++ " :: " ++ showEType (tupleConstraints ctx) ++ ", " ++
@@ -2064,7 +2064,7 @@
putConstraints unsolved
-- traceM ("solved:\n" ++ unlines [ showIdent i ++ " = " ++ showExpr e | (i, e) <- solved ]) -- traceM ("unsolved:\n" ++ unlines [ showIdent i ++ " :: " ++ showEType t | (i, t) <- unsolved ])- T.return solved
+ return solved
type TySubst = [(TRef, EType)]
@@ -2121,11 +2121,11 @@
-- Check that there are no unsolved constraints.
checkConstraints :: T ()
-checkConstraints = T.do
+checkConstraints = do
cs <- gets constraints
case cs of
- [] -> T.return ()
- (i, t) : _ -> T.do
+ [] -> return ()
+ (i, t) : _ -> do
t' <- derefUVar t
--is <- gets instTable
--traceM $ "Cannot satisfy constraint: " ++ unlines (map (\ (i, ii) -> showIdent i ++ ":\n" ++ showInstInfo ii) (M.toList is))
--
⑨