Commit 94bf0d36 authored by Simon Marlow's avatar Simon Marlow

Refactoring and tidyup of HscMain and related things (also fix #1666)

While trying to fix #1666 (-Werror aborts too early) I decided to some
tidyup in GHC/DriverPipeline/HscMain.

 - The GhcMonad overloading is gone from DriverPipeline and HscMain
   now.  GhcMonad is now defined in a module of its own, and only
   used in the top-level GHC layer.  DriverPipeline and HscMain
   use the plain IO monad and take HscEnv as an argument.

 - WarnLogMonad is gone.  printExceptionAndWarnings is now called
   printException (the old name is deprecated).  Session no longer
   contains warnings.

 - HscMain has its own little monad that collects warnings, and also
   plumbs HscEnv around.  The idea here is that warnings are collected
   while we're in HscMain, but on exit from HscMain (any function) we
   check for warnings and either print them (via log_action, so IDEs
   can still override the printing), or turn them into an error if
   -Werror is on.

 - GhcApiCallbacks is gone, along with GHC.loadWithLogger.  Thomas
   Schilling told me he wasn't using these, and I don't see a good
   reason to have them.

 - there's a new pure API to the parser (suggestion from Neil Mitchell):
      parser :: String
             -> DynFlags
             -> FilePath
             -> Either ErrorMessages (WarningMessages, 
                                      Located (HsModule RdrName))
parent 2493b180
......@@ -165,11 +165,11 @@ instance Ord SrcLoc where
cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering
cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2
cmpSrcLoc (UnhelpfulLoc _) _other = LT
cmpSrcLoc (UnhelpfulLoc _) (SrcLoc _ _ _) = GT
cmpSrcLoc (SrcLoc _ _ _) (UnhelpfulLoc _) = LT
cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2)
= (s1 `compare` s2) `thenCmp` (l1 `compare` l2) `thenCmp` (c1 `compare` c2)
cmpSrcLoc (SrcLoc _ _ _) _other = GT
instance Outputable SrcLoc where
ppr (SrcLoc src_path src_line src_col)
......
......@@ -152,6 +152,7 @@ Library
DataCon
Demand
Exception
GhcMonad
Id
IdInfo
Literal
......
......@@ -15,23 +15,20 @@ module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
import Linker
import RtClosureInspect
import GhcMonad
import HscTypes
import Id
import Name
import Var hiding ( varName )
import VarSet
-- import Name
import UniqSupply
import TcType
import GHC
-- import DynFlags
import InteractiveEval
import Outputable
-- import SrcLoc
import PprTyThing
import MonadUtils
-- import Exception
import Control.Monad
import Data.List
import Data.Maybe
......
......@@ -17,6 +17,7 @@ module DriverMkDepend (
import qualified GHC
-- import GHC ( ModSummary(..), GhcMonad )
import GhcMonad
import HsSyn ( ImportDecl(..) )
import DynFlags
import Util
......
This diff is collapsed.
......@@ -13,7 +13,7 @@ module ErrUtils (
errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
Messages, errorsFound, emptyMessages,
mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
printBagOfErrors, printBagOfWarnings,
warnIsErrorMsg, mkLongWarnMsg,
ghcExit,
......@@ -39,7 +39,6 @@ import SrcLoc
import DynFlags ( DynFlags(..), DynFlag(..), dopt )
import StaticFlags ( opt_ErrorSpans )
import Control.Monad
import System.Exit ( ExitCode(..), exitWith )
import Data.List
import System.IO
......@@ -126,56 +125,29 @@ emptyMessages :: Messages
emptyMessages = (emptyBag, emptyBag)
warnIsErrorMsg :: ErrMsg
warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.\n")
warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.")
errorsFound :: DynFlags -> Messages -> Bool
-- The dyn-flags are used to see if the user has specified
-- -Werror, which says that warnings should be fatal
errorsFound dflags (warns, errs)
| dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns)
| otherwise = not (isEmptyBag errs)
printErrorsAndWarnings :: DynFlags -> Messages -> IO ()
printErrorsAndWarnings dflags (warns, errs)
| no_errs && no_warns = return ()
| no_errs = do printBagOfWarnings dflags warns
when (dopt Opt_WarnIsError dflags) $
errorMsg dflags $
text "\nFailing due to -Werror.\n"
-- Don't print any warnings if there are errors
| otherwise = printBagOfErrors dflags errs
where
no_warns = isEmptyBag warns
no_errs = isEmptyBag errs
errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfErrors dflags bag_of_errors
= sequence_ [ let style = mkErrStyle unqual
in log_action dflags SevError s style (d $$ e)
| ErrMsg { errMsgSpans = s:_,
errMsgShortDoc = d,
errMsgExtraInfo = e,
errMsgContext = unqual } <- sorted_errs ]
where
bag_ls = bagToList bag_of_errors
sorted_errs = sortLe occ'ed_before bag_ls
printBagOfErrors dflags bag_of_errors =
printMsgBag dflags bag_of_errors SevError
occ'ed_before err1 err2 =
case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
LT -> True
EQ -> True
GT -> False
printBagOfWarnings :: DynFlags -> Bag WarnMsg -> IO ()
printBagOfWarnings dflags bag_of_warns =
printMsgBag dflags bag_of_warns SevWarning
printBagOfWarnings :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfWarnings dflags bag_of_warns
printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO ()
printMsgBag dflags bag sev
= sequence_ [ let style = mkErrStyle unqual
in log_action dflags SevWarning s style (d $$ e)
in log_action dflags sev s style (d $$ e)
| ErrMsg { errMsgSpans = s:_,
errMsgShortDoc = d,
errMsgExtraInfo = e,
errMsgContext = unqual } <- sorted_errs ]
where
bag_ls = bagToList bag_of_warns
bag_ls = bagToList bag
sorted_errs = sortLe occ'ed_before bag_ls
occ'ed_before err1 err2 =
......
This diff is collapsed.
{-# OPTIONS_GHC -funbox-strict-fields #-}
-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 2010
--
-- The Session type and related functionality
--
-- -----------------------------------------------------------------------------
module GhcMonad (
-- * 'Ghc' monad stuff
GhcMonad(..),
Ghc(..),
GhcT(..), liftGhcT,
reflectGhc, reifyGhc,
getSessionDynFlags,
liftIO,
Session(..), withSession, modifySession, withTempSession,
-- ** Warnings
logWarnings
) where
import MonadUtils
import HscTypes
import DynFlags
import Exception
import ErrUtils
import Data.IORef
-- -----------------------------------------------------------------------------
-- | A monad that has all the features needed by GHC API calls.
--
-- In short, a GHC monad
--
-- - allows embedding of IO actions,
--
-- - can log warnings,
--
-- - allows handling of (extensible) exceptions, and
--
-- - maintains a current session.
--
-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad'
-- before any call to the GHC API functions can occur.
--
class (Functor m, MonadIO m, ExceptionMonad m) => GhcMonad m where
getSession :: m HscEnv
setSession :: HscEnv -> m ()
-- | Call the argument with the current session.
withSession :: GhcMonad m => (HscEnv -> m a) -> m a
withSession f = getSession >>= f
-- | Grabs the DynFlags from the Session
getSessionDynFlags :: GhcMonad m => m DynFlags
getSessionDynFlags = withSession (return . hsc_dflags)
-- | Set the current session to the result of applying the current session to
-- the argument.
modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession f = do h <- getSession
setSession $! f h
withSavedSession :: GhcMonad m => m a -> m a
withSavedSession m = do
saved_session <- getSession
m `gfinally` setSession saved_session
-- | Call an action with a temporarily modified Session.
withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a
withTempSession f m =
withSavedSession $ modifySession f >> m
-- -----------------------------------------------------------------------------
-- | A monad that allows logging of warnings.
logWarnings :: GhcMonad m => WarningMessages -> m ()
logWarnings warns = do
dflags <- getSessionDynFlags
liftIO $ printOrThrowWarnings dflags warns
-- -----------------------------------------------------------------------------
-- | A minimal implementation of a 'GhcMonad'. If you need a custom monad,
-- e.g., to maintain additional state consider wrapping this monad or using
-- 'GhcT'.
newtype Ghc a = Ghc { unGhc :: Session -> IO a }
-- | The Session is a handle to the complete state of a compilation
-- session. A compilation session consists of a set of modules
-- constituting the current program or library, the context for
-- interactive evaluation, and various caches.
data Session = Session !(IORef HscEnv)
instance Functor Ghc where
fmap f m = Ghc $ \s -> f `fmap` unGhc m s
instance Monad Ghc where
return a = Ghc $ \_ -> return a
m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s
instance MonadIO Ghc where
liftIO ioA = Ghc $ \_ -> ioA
instance ExceptionMonad Ghc where
gcatch act handle =
Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s
gblock (Ghc m) = Ghc $ \s -> gblock (m s)
gunblock (Ghc m) = Ghc $ \s -> gunblock (m s)
gmask f =
Ghc $ \s -> gmask $ \io_restore ->
let
g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)
in
unGhc (f g_restore) s
instance GhcMonad Ghc where
getSession = Ghc $ \(Session r) -> readIORef r
setSession s' = Ghc $ \(Session r) -> writeIORef r s'
-- | Reflect a computation in the 'Ghc' monad into the 'IO' monad.
--
-- You can use this to call functions returning an action in the 'Ghc' monad
-- inside an 'IO' action. This is needed for some (too restrictive) callback
-- arguments of some library functions:
--
-- > libFunc :: String -> (Int -> IO a) -> IO a
-- > ghcFunc :: Int -> Ghc a
-- >
-- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a
-- > ghcFuncUsingLibFunc str =
-- > reifyGhc $ \s ->
-- > libFunc $ \i -> do
-- > reflectGhc (ghcFunc i) s
--
reflectGhc :: Ghc a -> Session -> IO a
reflectGhc m = unGhc m
-- > Dual to 'reflectGhc'. See its documentation.
reifyGhc :: (Session -> IO a) -> Ghc a
reifyGhc act = Ghc $ act
-- -----------------------------------------------------------------------------
-- | A monad transformer to add GHC specific features to another monad.
--
-- Note that the wrapped monad must support IO and handling of exceptions.
newtype GhcT m a = GhcT { unGhcT :: Session -> m a }
liftGhcT :: Monad m => m a -> GhcT m a
liftGhcT m = GhcT $ \_ -> m
instance Functor m => Functor (GhcT m) where
fmap f m = GhcT $ \s -> f `fmap` unGhcT m s
instance Monad m => Monad (GhcT m) where
return x = GhcT $ \_ -> return x
m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s
instance MonadIO m => MonadIO (GhcT m) where
liftIO ioA = GhcT $ \_ -> liftIO ioA
instance ExceptionMonad m => ExceptionMonad (GhcT m) where
gcatch act handle =
GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s
gblock (GhcT m) = GhcT $ \s -> gblock (m s)
gunblock (GhcT m) = GhcT $ \s -> gunblock (m s)
gmask f =
GhcT $ \s -> gmask $ \io_restore ->
let
g_restore (GhcT m) = GhcT $ \s -> io_restore (m s)
in
unGhcT (f g_restore) s
instance (Functor m, ExceptionMonad m, MonadIO m) => GhcMonad (GhcT m) where
getSession = GhcT $ \(Session r) -> liftIO $ readIORef r
setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s'
......@@ -33,9 +33,9 @@ import Outputable
import Pretty ()
import Maybes
import Bag ( emptyBag, listToBag, unitBag )
import MonadUtils ( MonadIO )
import MonadUtils
import Exception
import Control.Monad
import System.IO
import System.IO.Unsafe
......@@ -46,14 +46,13 @@ import Data.List
-- | Parse the imports of a source file.
--
-- Throws a 'SourceError' if parsing fails.
getImports :: GhcMonad m =>
DynFlags
getImports :: DynFlags
-> StringBuffer -- ^ Parse this.
-> FilePath -- ^ Filename the buffer came from. Used for
-- reporting parse error locations.
-> FilePath -- ^ The original source filename (used for locations
-- in the function result)
-> m ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
-> IO ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
-- ^ The source imports, normal imports, and the module name.
getImports dflags buf filename source_filename = do
let loc = mkSrcLoc (mkFastString filename) 1 1
......@@ -66,7 +65,7 @@ getImports dflags buf filename source_filename = do
ms = (emptyBag, errs)
-- logWarnings warns
if errorsFound dflags ms
then liftIO $ throwIO $ mkSrcErr errs
then throwIO $ mkSrcErr errs
else
case rdr_module of
L _ (HsModule mb_mod _ imps _ _ _) ->
......@@ -114,7 +113,7 @@ mkPrelImports this_mod implicit_prelude import_decls
loc = mkGeneralSrcSpan (fsLit "Implicit import declaration")
parseError :: GhcMonad m => SrcSpan -> Message -> m a
parseError :: SrcSpan -> Message -> IO a
parseError span err = throwOneError $ mkPlainErrMsg span err
--------------------------------------------------------------
......
This diff is collapsed.
This diff is collapsed.
......@@ -37,12 +37,12 @@ module InteractiveEval (
#include "HsVersions.h"
import HscMain hiding (compileExpr)
import GhcMonad
import HscMain
import HsSyn (ImportDecl)
import HscTypes
import TcRnDriver
import TcRnMonad (initTc)
import RnNames (gresFromAvails, rnImports)
import RnNames (gresFromAvails)
import InstEnv
import Type
import TcType hiding( typeKind )
......@@ -201,20 +201,12 @@ runStmt expr step =
let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
hsc_env' = hsc_env{ hsc_dflags = dflags' }
r <- hscStmt hsc_env' expr
r <- liftIO $ hscStmt hsc_env' expr
case r of
Nothing -> return RunFailed -- empty statement / comment
Just (ids, hval) -> do
-- XXX: This is the only place we can print warnings before the
-- result. Is this really the right thing to do? It's fine for
-- GHCi, but what's correct for other GHC API clients? We could
-- introduce a callback argument.
warns <- getWarnings
liftIO $ printBagOfWarnings dflags' warns
clearWarnings
status <-
withVirtualCWD $
withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
......@@ -254,7 +246,7 @@ withVirtualCWD m = do
gbracket set_cwd reset_cwd $ \_ -> m
parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName)
parseImportDecl expr = withSession $ \hsc_env -> hscImport hsc_env expr
parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
emptyHistory :: BoundedList History
emptyHistory = nilBL 50 -- keep a log of length 50
......@@ -790,11 +782,9 @@ setContext toplev_mods other_mods = do
export_env <- liftIO $ mkExportEnv hsc_env export_mods
import_env <-
if null imprt_decls then return emptyGlobalRdrEnv else do
let imports = rnImports imprt_decls
this_mod = if null toplev_mods then pRELUDE else head toplev_mods
(_, env, _,_) <-
ioMsgMaybe $ liftIO $ initTc hsc_env HsSrcFile False this_mod imports
return env
let this_mod | null toplev_mods = pRELUDE
| otherwise = head toplev_mods
liftIO $ hscRnImportDecls hsc_env this_mod imprt_decls
toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs
modifySession $ \_ ->
......@@ -859,7 +849,7 @@ moduleIsInterpreted modl = withSession $ \h ->
getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
getInfo name
= withSession $ \hsc_env ->
do mb_stuff <- ioMsg $ tcRnGetInfo hsc_env name
do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name
case mb_stuff of
Nothing -> return Nothing
Just (thing, fixity, ispecs) -> do
......@@ -911,8 +901,8 @@ greToRdrNames GRE{ gre_name = name, gre_prov = prov }
-- the identifier can refer to in the current interactive context.
parseName :: GhcMonad m => String -> m [Name]
parseName str = withSession $ \hsc_env -> do
(L _ rdr_name) <- hscParseIdentifier (hsc_dflags hsc_env) str
ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
(L _ rdr_name) <- liftIO $ hscParseIdentifier hsc_env str
liftIO $ hscTcRnLookupRdrName hsc_env rdr_name
-- -----------------------------------------------------------------------------
-- Getting the type of an expression
......@@ -920,7 +910,7 @@ parseName str = withSession $ \hsc_env -> do
-- | Get the type of an expression
exprType :: GhcMonad m => String -> m Type
exprType expr = withSession $ \hsc_env -> do
ty <- hscTcExpr hsc_env expr
ty <- liftIO $ hscTcExpr hsc_env expr
return $ tidyType emptyTidyEnv ty
-- -----------------------------------------------------------------------------
......@@ -929,14 +919,14 @@ exprType expr = withSession $ \hsc_env -> do
-- | Get the kind of a type
typeKind :: GhcMonad m => String -> m Kind
typeKind str = withSession $ \hsc_env -> do
hscKcType hsc_env str
liftIO $ hscKcType hsc_env str
-----------------------------------------------------------------------------
-- cmCompileExpr: compile an expression and deliver an HValue
compileExpr :: GhcMonad m => String -> m HValue
compileExpr expr = withSession $ \hsc_env -> do
Just (ids, hval) <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr)
-- Run it!
hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])
......@@ -955,7 +945,8 @@ dynCompileExpr expr = do
(stringToPackageId "base") (mkModuleName "Data.Dynamic")
,Nothing):exports
let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
Just (ids, hvals) <- withSession (flip hscStmt stmt)
Just (ids, hvals) <- withSession $ \hsc_env ->
liftIO $ hscStmt hsc_env stmt
setContext full exports
vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
case (ids,vals) of
......
......@@ -1499,11 +1499,23 @@ exportClashErr global_env name1 name2 ie1 ie2
= case lookupGRE_Name global_env name of
(gre:_) -> gre
[] -> pprPanic "exportClashErr" (ppr name)
get_loc name = nameSrcLoc $ gre_name $ get_gre name
get_loc name = greSrcSpan (get_gre name)
(name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2
then (name1, ie1, name2, ie2)
else (name2, ie2, name1, ie1)
-- the SrcSpan that pprNameProvenance prints out depends on whether
-- the Name is defined locally or not: for a local definition the
-- definition site is used, otherwise the location of the import
-- declaration. We want to sort the export locations in
-- exportClashErr by this SrcSpan, we need to extract it:
greSrcSpan :: GlobalRdrElt -> SrcSpan
greSrcSpan gre
| Imported (is:_) <- gre_prov gre = is_dloc (is_decl is)
| otherwise = name_span
where
name_span = nameSrcSpan (gre_name gre)
addDupDeclErr :: [Name] -> TcRn ()
addDupDeclErr []
= panic "addDupDeclErr: empty list"
......
......@@ -79,6 +79,7 @@ import Bag
import Maybes
import UniqSupply
import UniqFM ( UniqFM, mapUFM, filterUFM )
import MonadUtils
import Util ( split )
import Data.List ( intersperse )
......
......@@ -168,9 +168,8 @@ initTcPrintErrors -- Used from the interactive loop only
-> Module
-> TcM r
-> IO (Messages, Maybe r)
initTcPrintErrors env mod todo = do
(msgs, res) <- initTc env HsSrcFile False mod todo
return (msgs, res)
initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo
\end{code}
%************************************************************************
......
......@@ -787,7 +787,7 @@ runMeta show_code run_and_convert expr
; hsc_env <- getTopEnv
; src_span <- getSrcSpanM
; either_hval <- tryM $ liftIO $
HscMain.compileExpr hsc_env src_span ds_expr
HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
; case either_hval of {
Left exn -> failWithTc (mk_msg "compile and link" exn) ;
Right hval -> do
......
......@@ -27,16 +27,16 @@ module MonadUtils
import Outputable
----------------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- Detection of available libraries
----------------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- we don't depend on MTL for now
#define HAVE_MTL 0
----------------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- Imports
----------------------------------------------------------------------------------------
-------------------------------------------------------------------------------
import Maybes
......@@ -47,9 +47,9 @@ import Control.Monad.Trans
import Control.Monad
import Control.Monad.Fix
----------------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- The ID monad
----------------------------------------------------------------------------------------
-------------------------------------------------------------------------------
newtype ID a = ID a
instance Monad ID where
......@@ -61,9 +61,9 @@ instance Monad ID where
runID :: ID a -> a
runID (ID x) = x
----------------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- MTL
----------------------------------------------------------------------------------------
-------------------------------------------------------------------------------
#if !HAVE_MTL
......@@ -73,10 +73,10 @@ class Monad m => MonadIO m where
instance MonadIO IO where liftIO = id
#endif
----------------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- Lift combinators
-- These are used throughout the compiler
----------------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- | Lift an 'IO' operation with 1 argument into another monad
liftIO1 :: MonadIO m => (a -> IO b) -> a -> m b
......@@ -94,10 +94,10 @@ liftIO3 = ((.).((.).(.))) liftIO
liftIO4 :: MonadIO m => (a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> m e
liftIO4 = (((.).(.)).((.).(.))) liftIO
----------------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- Common functions
-- These are used throughout the compiler
----------------------------------------------------------------------------------------
-------------------------------------------------------------------------------
zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
zipWith3M _ [] _ _ = return []
......
......@@ -138,8 +138,9 @@ appendStringBuffers sb1 sb2
calcLen sb = len sb - cur sb
size = sb1_len + sb2_len
stringToStringBuffer :: String -> IO StringBuffer
stringToStringBuffer str = do
stringToStringBuffer :: String -> StringBuffer
stringToStringBuffer str =
unsafePerformIO $ do
let size = utf8EncodedLength str
buf <- mallocForeignPtrArray (size+3)
withForeignPtr buf $ \ptr -> do
......
......@@ -25,6 +25,8 @@ import OccName
import BasicTypes ( isLoopBreaker )
import Outputable
import Util ( zipLazy )
import MonadUtils
import Control.Monad
debug = False
......
......@@ -31,6 +31,7 @@ import Vectorise.Builtins
import Vectorise.Env
import HscTypes hiding ( MonadThings(..) )
import MonadUtils (liftIO)
import Module
import TyCon
import Var
......