summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChrisDone <>2016-05-12 13:07:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-05-12 13:07:00 (GMT)
commit57a6c5fa4ed16a64a9d60496647733f0ad11bb10 (patch)
treedc156a502b82253b4382b48a2dbe24357b0f33f8
version 0.0.00.0.0
-rw-r--r--LICENSE27
-rw-r--r--Setup.hs2
-rw-r--r--cbits/HsVersions.h8
-rw-r--r--cbits/PosixSource.h42
-rw-r--r--cbits/hschooks.c59
-rw-r--r--intero.cabal80
-rw-r--r--src/GhciFind.hs266
-rw-r--r--src/GhciInfo.hs211
-rw-r--r--src/GhciMonad.hs413
-rw-r--r--src/GhciTags.hs206
-rw-r--r--src/GhciTypes.hs57
-rw-r--r--src/InteractiveUI.hs3435
-rw-r--r--src/Main.hs889
13 files changed, 5695 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..3501553
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,27 @@
+Copyright (c) 2016, Chris Done
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+ list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+* Neither the name of intero nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/cbits/HsVersions.h b/cbits/HsVersions.h
new file mode 100644
index 0000000..6b4ee14
--- /dev/null
+++ b/cbits/HsVersions.h
@@ -0,0 +1,8 @@
+/* Hack needed because of http://hackage.haskell.org/trac/ghc/ticket/8040 */
+
+#define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else
+
+#define GLOBAL_VAR(name,value,ty) \
+{-# NOINLINE name #-}; \
+name :: IORef (ty); \
+name = Util.global (value);
diff --git a/cbits/PosixSource.h b/cbits/PosixSource.h
new file mode 100644
index 0000000..da7b69e
--- /dev/null
+++ b/cbits/PosixSource.h
@@ -0,0 +1,42 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2005
+ *
+ * Include this file into sources which should not need any non-Posix services.
+ * That includes most RTS C sources.
+ * ---------------------------------------------------------------------------*/
+
+#ifndef POSIXSOURCE_H
+#define POSIXSOURCE_H
+
+#include <ghcplatform.h>
+
+#if defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS)
+#define _POSIX_C_SOURCE 200112L
+#define _XOPEN_SOURCE 600
+#else
+#define _POSIX_SOURCE 1
+#define _POSIX_C_SOURCE 199506L
+#define _XOPEN_SOURCE 500
+// FreeBSD takes a different approach to _ISOC99_SOURCE: on FreeBSD it
+// means "I want *just* C99 things", whereas on GNU libc and Solaris
+// it means "I also want C99 things".
+//
+// On both GNU libc and FreeBSD, _ISOC99_SOURCE is implied by
+// _XOPEN_SOURCE==600, but on Solaris it is an error to omit it.
+#define _ISOC99_SOURCE
+// Defining __USE_MINGW_ANSI_STDIO is the most portable way to tell
+// mingw that we want to use the standard %lld style format specifiers,
+// rather than the Windows %I64d style
+#define __USE_MINGW_ANSI_STDIO 1
+#endif
+
+#if defined(darwin_HOST_OS)
+/* If we don't define this the including sysctl breaks with things like
+ /usr/include/bsm/audit.h:224:0:
+ error: syntax error before 'u_char'
+*/
+#define _DARWIN_C_SOURCE 1
+#endif
+
+#endif /* POSIXSOURCE_H */
diff --git a/cbits/hschooks.c b/cbits/hschooks.c
new file mode 100644
index 0000000..7a36965
--- /dev/null
+++ b/cbits/hschooks.c
@@ -0,0 +1,59 @@
+/*
+These routines customise the error messages
+for various bits of the RTS. They are linked
+in instead of the defaults.
+*/
+
+#include "PosixSource.h"
+#include "Rts.h"
+
+#include "HsFFI.h"
+
+#include <string.h>
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+void
+initGCStatistics(void)
+{
+ /* Workaround for #8754: if the GC stats aren't enabled because the
+ compiler couldn't use -Bsymbolic to link the default hooks, then
+ initialize them sensibly. See Note [-Bsymbolic and hooks] in
+ Main.hs. */
+ if (RtsFlags.GcFlags.giveStats == NO_GC_STATS) {
+ RtsFlags.GcFlags.giveStats = COLLECT_GC_STATS;
+ }
+}
+
+void
+defaultsHook (void)
+{
+#if __GLASGOW_HASKELL__ >= 707
+ // This helps particularly with large compiles, but didn't work
+ // very well with earlier GHCs because it caused large amounts of
+ // fragmentation. See rts/sm/BlockAlloc.c:allocLargeChunk().
+ RtsFlags.GcFlags.heapSizeSuggestionAuto = rtsTrue;
+#else
+ RtsFlags.GcFlags.heapSizeSuggestion = 6*1024*1024 / BLOCK_SIZE;
+#endif
+
+ RtsFlags.GcFlags.maxStkSize = 512*1024*1024 / sizeof(W_);
+
+ initGCStatistics();
+
+ // See #3408: the default idle GC time of 0.3s is too short on
+ // Windows where we receive console events once per second or so.
+#if __GLASGOW_HASKELL__ >= 703
+ RtsFlags.GcFlags.idleGCDelayTime = SecondsToTime(5);
+#else
+ RtsFlags.GcFlags.idleGCDelayTime = 5*1000;
+#endif
+}
+
+void
+StackOverflowHook (StgWord stack_size) /* in bytes */
+{
+ fprintf(stderr, "GHC stack-space overflow: current limit is %zu bytes.\nUse the `-K<size>' option to increase it.\n", (size_t)stack_size);
+}
diff --git a/intero.cabal b/intero.cabal
new file mode 100644
index 0000000..484d119
--- /dev/null
+++ b/intero.cabal
@@ -0,0 +1,80 @@
+name:
+ intero
+version:
+ 0.0.0
+synopsis:
+ Complete interactive development program for Haskell
+license:
+ BSD3
+homepage:
+ https://github.com/chrisdone/intero
+license-file:
+ LICENSE
+author:
+ Chris Done, The University of Glasgow
+maintainer:
+ chrisdone@gmail.com
+copyright:
+ 2016 Chris Done,
+ 2012 Kazu Yamamoto,
+ 2008 Claus Reinke,
+ 2005 The University of Glasgow
+category:
+ Development
+build-type:
+ Simple
+cabal-version:
+ >= 1.14
+stability:
+ Stable
+extra-source-files:
+ cbits/HsVersions.h
+ cbits/PosixSource.h
+source-repository head
+ type:
+ git
+ location:
+ git://github.com/chrisdone/intero.git
+
+executable intero
+ default-language:
+ Haskell2010
+ main-is:
+ Main.hs
+ ghc-options:
+ -Wall -O2 -threaded -dynamic
+ include-dirs:
+ cbits/
+ hs-source-dirs:
+ src/
+ c-sources:
+ cbits/hschooks.c
+ cpp-options:
+ -DGHCI
+ other-modules:
+ InteractiveUI
+ GhciMonad
+ GhciTags
+ GhciTypes
+ GhciInfo
+ GhciFind
+ build-depends:
+ base < 5,
+ array,
+ bytestring,
+ directory,
+ filepath,
+ ghc >= 7.8,
+ ghc-paths,
+ haskeline,
+ process,
+ transformers,
+ syb,
+ containers,
+ time
+ if os(windows)
+ build-depends:
+ Win32
+ else
+ build-depends:
+ unix
diff --git a/src/GhciFind.hs b/src/GhciFind.hs
new file mode 100644
index 0000000..b0b56fc
--- /dev/null
+++ b/src/GhciFind.hs
@@ -0,0 +1,266 @@
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+
+-- | Find type/location information.
+
+module GhciFind
+ (findType,findLoc,findNameUses)
+ where
+
+import Control.Monad
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe
+
+import FastString
+import GHC
+import GhcMonad
+import GhciInfo (showppr)
+import GhciTypes
+import Name
+import SrcLoc
+import System.Directory
+import Var
+
+-- | Find any uses of the given identifier in the codebase.
+findNameUses :: (GhcMonad m)
+ => Map ModuleName ModInfo
+ -> FilePath
+ -> String
+ -> Int
+ -> Int
+ -> Int
+ -> Int
+ -> m (Either String [SrcSpan])
+findNameUses infos fp string sl sc el ec =
+ do mname <- guessModule infos fp
+ case mname of
+ Nothing ->
+ return (Left "Couldn't guess that module name. Does it exist?")
+ Just name ->
+ case M.lookup name infos of
+ Nothing ->
+ return (Left ("No module info for the current file! Try loading it?"))
+ Just info ->
+ do mname' <- findName infos info string sl sc el ec
+ case mname' of
+ Left e -> return (Left e)
+ Right name' ->
+ case getSrcSpan name' of
+ UnhelpfulSpan{} ->
+ do d <- getSessionDynFlags
+ return (Left ("Found a name, but no location information. The module is: " ++
+ maybe "<unknown>"
+ (showppr d . moduleName)
+ (nameModule_maybe name')))
+ span' ->
+ return (Right (stripSurrounding
+ (span' :
+ map makeSrcSpan
+ (filter ((== Just name') .
+ fmap getName .
+ spaninfoVar)
+ (modinfoSpans info)))))
+ where makeSrcSpan (SpanInfo sl' sc' el' ec' _ _) =
+ RealSrcSpan
+ (mkRealSrcSpan
+ (mkRealSrcLoc (mkFastString fp)
+ sl'
+ (1 + sc'))
+ (mkRealSrcLoc (mkFastString fp)
+ el'
+ (1 + ec')))
+
+-- | Strip out spans which surrounding other spans in a parent->child
+-- fashion. Those are useless.
+stripSurrounding :: [SrcSpan] -> [SrcSpan]
+stripSurrounding xs =
+ mapMaybe (\x -> if any (\y -> overlaps x y && x /= y) xs
+ then Nothing
+ else Just x)
+ xs
+
+-- | Does x overlap y in x `overlaps` y?
+overlaps :: SrcSpan -> SrcSpan -> Bool
+overlaps y x =
+ case (x,y) of
+ (RealSrcSpan x',RealSrcSpan y') ->
+ realSrcSpanStart y' <= realSrcSpanStart x' &&
+ realSrcSpanEnd y' >= realSrcSpanEnd x'
+ _ -> False
+
+-- | Try to find the location of the given identifier at the given
+-- position in the module.
+findLoc :: (GhcMonad m)
+ => Map ModuleName ModInfo
+ -> FilePath
+ -> String
+ -> Int
+ -> Int
+ -> Int
+ -> Int
+ -> m (Either String SrcSpan)
+findLoc infos fp string sl sc el ec =
+ do mname <- guessModule infos fp
+ case mname of
+ Nothing ->
+ return (Left "Couldn't guess that module name. Does it exist?")
+ Just name ->
+ case M.lookup name infos of
+ Nothing ->
+ return (Left ("No module info for the current file! Try loading it?"))
+ Just info ->
+ do mname' <- findName infos info string sl sc el ec
+ d <- getSessionDynFlags
+ case mname' of
+ Left reason ->
+ return (Left reason)
+ Right name' ->
+ case getSrcSpan name' of
+ UnhelpfulSpan{} ->
+ return (Left ("Found a name, but no location information. The module is: " ++
+ maybe "<unknown>"
+ (showppr d . moduleName)
+ (nameModule_maybe name')))
+ span' ->
+ return (Right span')
+
+-- | Try to resolve the name located at the given position, or
+-- otherwise resolve based on the current module's scope.
+findName :: GhcMonad m
+ => Map ModuleName ModInfo
+ -> ModInfo
+ -> String
+ -> Int
+ -> Int
+ -> Int
+ -> Int
+ -> m (Either String Name)
+findName infos mi string sl sc el ec =
+ case resolveName (modinfoSpans mi)
+ sl
+ sc
+ el
+ ec of
+ Nothing -> tryExternalModuleResolution
+ Just name ->
+ case getSrcSpan name of
+ UnhelpfulSpan{} -> tryExternalModuleResolution
+ _ -> return (Right (getName name))
+ where tryExternalModuleResolution =
+ case find (matchName string)
+ (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of
+ Nothing ->
+ return (Left "Couldn't resolve to any modules.")
+ Just imported -> resolveNameFromModule infos imported
+ matchName :: String -> Name -> Bool
+ matchName str name =
+ str ==
+ occNameString (getOccName name)
+
+-- | Try to resolve the name from another (loaded) module's exports.
+resolveNameFromModule :: GhcMonad m
+ => Map ModuleName ModInfo
+ -> Name
+ -> m (Either String Name)
+resolveNameFromModule infos name =
+ do d <- getSessionDynFlags
+ case nameModule_maybe name of
+ Nothing ->
+ return (Left ("No module for " ++
+ showppr d name))
+ Just modL ->
+ do case M.lookup (moduleName modL) infos of
+ Nothing ->
+#if __GLASGOW_HASKELL__ >= 709
+ do (return (Left (showppr d (modulePackageKey modL) ++ ":" ++
+#else
+ do (return (Left (showppr d (modulePackageId modL) ++ ":" ++
+#endif
+ showppr d modL)))
+ Just info ->
+ case find (matchName name)
+ (modInfoExports (modinfoInfo info)) of
+ Just name' ->
+ return (Right name')
+ Nothing ->
+ return (Left "No matching export in any local modules.")
+ where matchName :: Name -> Name -> Bool
+ matchName x y =
+ occNameString (getOccName x) ==
+ occNameString (getOccName y)
+
+-- | Try to resolve the type display from the given span.
+resolveName :: [SpanInfo] -> Int -> Int -> Int -> Int -> Maybe Var
+resolveName spans' sl sc el ec =
+ listToMaybe (mapMaybe spaninfoVar (filter inside (reverse spans')))
+ where inside (SpanInfo sl' sc' el' ec' _ _) =
+ ((sl' == sl && sc' >= sc) || (sl' > sl)) &&
+ ((el' == el && ec' <= ec) || (el' < el))
+
+-- | Try to find the type of the given span.
+findType :: GhcMonad m
+ => Map ModuleName ModInfo
+ -> FilePath
+ -> String
+ -> Int
+ -> Int
+ -> Int
+ -> Int
+ -> m (Either String (ModInfo, Type))
+findType infos fp string sl sc el ec =
+ do mname <- guessModule infos fp
+ case mname of
+ Nothing ->
+ return (Left "Couldn't guess that module name. Does it exist?")
+ Just name ->
+ case M.lookup name infos of
+ Nothing ->
+ return (Left ("Couldn't guess the module nameIs this module loaded?"))
+ Just info ->
+ do let !mty =
+ resolveType (modinfoSpans info)
+ sl
+ sc
+ el
+ ec
+ case mty of
+ Just ty -> return (Right (info, ty))
+ Nothing ->
+ fmap (Right . (,) info) (exprType string)
+
+-- | Try to resolve the type display from the given span.
+resolveType :: [SpanInfo] -> Int -> Int -> Int -> Int -> Maybe Type
+resolveType spans' sl sc el ec =
+ join (fmap spaninfoType (find inside (reverse spans')))
+ where inside (SpanInfo sl' sc' el' ec' _ _) =
+ ((sl' == sl && sc' >= sc) || (sl' > sl)) &&
+ ((el' == el && ec' <= ec) || (el' < el))
+
+-- | Guess a module name from a file path.
+guessModule :: GhcMonad m
+ => Map ModuleName ModInfo -> FilePath -> m (Maybe ModuleName)
+guessModule infos fp =
+ do target <- guessTarget fp Nothing
+ case targetId target of
+ TargetModule mn -> return (Just mn)
+ TargetFile fp' _ ->
+ case find ((Just fp' ==) .
+ ml_hs_file . ms_location . modinfoSummary . snd)
+ (M.toList infos) of
+ Just (mn,_) -> return (Just mn)
+ Nothing ->
+ do fp'' <- liftIO (makeRelativeToCurrentDirectory fp')
+ target' <- guessTarget fp'' Nothing
+ case targetId target' of
+ TargetModule mn ->
+ return (Just mn)
+ _ ->
+ case find ((Just fp'' ==) .
+ ml_hs_file . ms_location . modinfoSummary . snd)
+ (M.toList infos) of
+ Just (mn,_) ->
+ return (Just mn)
+ Nothing -> return Nothing
diff --git a/src/GhciInfo.hs b/src/GhciInfo.hs
new file mode 100644
index 0000000..4ae2ec0
--- /dev/null
+++ b/src/GhciInfo.hs
@@ -0,0 +1,211 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+
+-- | Get information on modules, identifiers, etc.
+
+module GhciInfo (collectInfo,getModInfo,showppr) where
+
+import Control.Exception
+import Control.Monad
+import qualified CoreUtils
+import Data.Data
+import Data.Generics (GenericQ, mkQ, extQ)
+import Data.List
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Maybe
+import Data.Time
+import Desugar
+import GHC
+import GhcMonad
+import GhciTypes
+import NameSet
+import Outputable
+import Prelude hiding (mod)
+import System.Directory
+import TcHsSyn
+import Var
+
+#if MIN_VERSION_ghc(7,8,3)
+#else
+import Bag
+#endif
+
+-- | Collect type info data for the loaded modules.
+collectInfo :: (GhcMonad m)
+ => Map ModuleName ModInfo -> [ModuleName] -> m (Map ModuleName ModInfo)
+collectInfo ms loaded =
+ do df <- getSessionDynFlags
+ invalidated <- liftIO (filterM cacheInvalid loaded)
+ if null invalidated
+ then return ms
+ else do liftIO (putStrLn ("Collecting type info for " ++
+ show (length invalidated) ++
+ " module(s) ... "))
+ foldM (\m name ->
+ gcatch (do info <- getModInfo name
+ return (M.insert name info m))
+ (\(e :: SomeException) ->
+ do liftIO (putStrLn ("Error while getting type info from " ++
+ showppr df name ++
+ ": " ++ show e))
+ return m))
+ ms
+ invalidated
+ where cacheInvalid name =
+ case M.lookup name ms of
+ Nothing -> return True
+ Just mi ->
+ do let fp =
+ ml_obj_file (ms_location (modinfoSummary mi))
+ last' = modinfoLastUpdate mi
+ exists <- doesFileExist fp
+ if exists
+ then do mod <- getModificationTime fp
+ return (mod > last')
+ else return True
+
+-- | Get info about the module: summary, types, etc.
+getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo
+getModInfo name =
+ do m <- getModSummary name
+ p <- parseModule m
+ typechecked <- typecheckModule p
+ allTypes <- processAllTypeCheckedModule typechecked
+ let i = tm_checked_module_info typechecked
+ now <- liftIO getCurrentTime
+ return (ModInfo m allTypes i now)
+
+-- | Get ALL source spans in the module.
+processAllTypeCheckedModule :: GhcMonad m
+ => TypecheckedModule -> m [SpanInfo]
+processAllTypeCheckedModule tcm =
+ do let tcs = tm_typechecked_source tcm
+ bs = listifyAllSpans tcs :: [LHsBind Id]
+ es = listifyAllSpans tcs :: [LHsExpr Id]
+ ps = listifyAllSpans tcs :: [LPat Id]
+ bts <- mapM (getTypeLHsBind tcm) bs
+ ets <- mapM (getTypeLHsExpr tcm) es
+ pts <- mapM (getTypeLPat tcm) ps
+ return (mapMaybe toSpanInfo (sortBy cmp (concat bts ++ catMaybes (concat [ets,pts]))))
+ where cmp (_,a,_) (_,b,_)
+ | a `isSubspanOf` b = LT
+ | b `isSubspanOf` a = GT
+ | otherwise = EQ
+
+getTypeLHsBind :: (GhcMonad m)
+ => TypecheckedModule
+ -> LHsBind Id
+ -> m [(Maybe Id,SrcSpan,Type)]
+#if MIN_VERSION_ghc(7,8,3)
+getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ _}) =
+ return (return (Just (unLoc pid),getLoc pid,varType (unLoc pid)))
+#else
+getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ}) =
+ return (return (Just (unLoc pid),getLoc pid,varType (unLoc pid)))
+#endif
+#if MIN_VERSION_ghc(7,8,3)
+#else
+getTypeLHsBind m (L _spn AbsBinds{abs_binds = binds}) =
+ fmap concat
+ (mapM (getTypeLHsBind m)
+ (map snd (bagToList binds)))
+#endif
+getTypeLHsBind _ _ = return []
+-- getTypeLHsBind _ x =
+-- do df <- getSessionDynFlags
+-- error ("getTypeLHsBind: unhandled case: " ++
+-- showppr df x)
+
+getTypeLHsExpr :: (GhcMonad m)
+ => TypecheckedModule
+ -> LHsExpr Id
+ -> m (Maybe (Maybe Id,SrcSpan,Type))
+getTypeLHsExpr _ e =
+ do hs_env <- getSession
+ (_,mbe) <- liftIO (deSugarExpr hs_env e)
+ case mbe of
+ Nothing -> return Nothing
+ Just expr ->
+ return (Just (case unwrapVar (unLoc e) of
+ HsVar i -> Just i
+ _ -> Nothing
+ ,getLoc e
+ ,CoreUtils.exprType expr))
+ where unwrapVar (HsWrap _ var) = var
+ unwrapVar e' = e'
+
+-- | Get id and type for patterns.
+getTypeLPat :: (GhcMonad m)
+ => TypecheckedModule -> LPat Id -> m (Maybe (Maybe Id,SrcSpan,Type))
+getTypeLPat _ (L spn pat) =
+ return (Just (getMaybeId pat,spn,hsPatType pat))
+ where getMaybeId (VarPat vid) = Just vid
+ getMaybeId _ = Nothing
+
+-- | Get ALL source spans in the source.
+listifyAllSpans :: Typeable a
+ => TypecheckedSource -> [Located a]
+listifyAllSpans tcs =
+ listifyStaged TypeChecker p tcs
+ where p (L spn _) = isGoodSrcSpan spn
+
+listifyStaged :: Typeable r
+ => Stage -> (r -> Bool) -> GenericQ [r]
+listifyStaged s p =
+ everythingStaged
+ s
+ (++)
+ []
+ ([] `mkQ`
+ (\x -> [x | p x]))
+
+------------------------------------------------------------------------------
+-- The following was taken from 'ghc-syb-utils'
+--
+-- ghc-syb-utils:
+-- https://github.com/nominolo/ghc-syb
+
+-- | Ghc Ast types tend to have undefined holes, to be filled
+-- by later compiler phases. We tag Asts with their source,
+-- so that we can avoid such holes based on who generated the Asts.
+data Stage
+ = Parser
+ | Renamer
+ | TypeChecker
+ deriving (Eq,Ord,Show)
+
+-- | Like 'everything', but avoid known potholes, based on the 'Stage' that
+-- generated the Ast.
+everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r
+everythingStaged stage k z f x
+ | (const False `extQ` postTcType `extQ` fixity `extQ` nameSet) x = z
+ | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x)
+ where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool
+#if __GLASGOW_HASKELL__ >= 709
+ postTcType = const (stage<TypeChecker) :: PostTc Id Type -> Bool
+#else
+ postTcType = const (stage<TypeChecker) :: PostTcType -> Bool
+#endif
+ fixity = const (stage<Renamer) :: GHC.Fixity -> Bool
+
+-- | Pretty print the types into a 'SpanInfo'.
+toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo
+toSpanInfo (n,mspan,typ) =
+ case mspan of
+ RealSrcSpan spn ->
+ Just (SpanInfo (srcSpanStartLine spn)
+ (srcSpanStartCol spn - 1)
+ (srcSpanEndLine spn)
+ (srcSpanEndCol spn - 1)
+ (Just typ)
+ n)
+ _ -> Nothing
+
+-- | Pretty print something to string.
+showppr :: Outputable a
+ => DynFlags -> a -> String
+showppr dflags =
+ showSDocForUser dflags neverQualify .
+ ppr
diff --git a/src/GhciMonad.hs b/src/GhciMonad.hs
new file mode 100644
index 0000000..02834b2
--- /dev/null
+++ b/src/GhciMonad.hs
@@ -0,0 +1,413 @@
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
+
+-----------------------------------------------------------------------------
+--
+-- Monadery code used in InteractiveUI
+--
+-- (c) The GHC Team 2005-2006
+--
+-----------------------------------------------------------------------------
+
+module GhciMonad (
+ GHCi(..), startGHCi,
+ GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState,
+ GHCiOption(..), isOptionSet, setOption, unsetOption,
+ Command,
+ BreakLocation(..),
+ TickArray,
+ getDynFlags,
+
+ runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,
+ printForUserNeverQualify, printForUserModInfo,
+
+ printForUser, printForUserPartWay, prettyLocations,
+ initInterpBuffering, turnOffBuffering, flushInterpBuffers,
+ ) where
+
+#include "HsVersions.h"
+
+-- ghci-ng
+import GhciTypes
+import Data.Map.Strict (Map)
+
+import qualified GHC
+import GhcMonad hiding (liftIO)
+import Outputable hiding (printForUser, printForUserPartWay)
+import qualified Outputable
+import Util
+import DynFlags
+import HscTypes
+import SrcLoc
+import Module
+import ObjLink
+import Linker
+
+import Exception
+import Numeric
+import Data.Array
+import Data.Int ( Int64 )
+import Data.IORef
+import System.CPUTime
+import System.Environment
+import System.IO
+#if __GLASGOW_HASKELL__ < 709
+import Control.Applicative (Applicative(..))
+#endif
+import Control.Monad
+import GHC.Exts
+
+import System.Console.Haskeline (CompletionFunc, InputT)
+import qualified System.Console.Haskeline as Haskeline
+import Control.Monad.Trans.Class
+import Control.Monad.IO.Class
+
+-----------------------------------------------------------------------------
+-- GHCi monad
+
+type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi)
+
+data GHCiState = GHCiState
+ {
+ progname :: String,
+ args :: [String],
+ prompt :: String,
+ prompt2 :: String,
+ editor :: String,
+ stop :: String,
+ options :: [GHCiOption],
+ line_number :: !Int, -- input line
+ break_ctr :: !Int,
+ breaks :: ![(Int, BreakLocation)],
+ tickarrays :: ModuleEnv TickArray,
+ -- tickarrays caches the TickArray for loaded modules,
+ -- so that we don't rebuild it each time the user sets
+ -- a breakpoint.
+ -- available ghci commands
+ ghci_commands :: [Command],
+ -- ":" at the GHCi prompt repeats the last command, so we
+ -- remember is here:
+ last_command :: Maybe Command,
+ cmdqueue :: [String],
+
+ remembered_ctx :: [InteractiveImport],
+ -- the imports that the user has asked for, via import
+ -- declarations and :module commands. This list is
+ -- persistent over :reloads (but any imports for modules
+ -- that are not loaded are temporarily ignored). After a
+ -- :load, all the home-package imports are stripped from
+ -- this list.
+
+ -- See bugs #2049, #1873, #1360
+
+ transient_ctx :: [InteractiveImport],
+ -- An import added automatically after a :load, usually of
+ -- the most recently compiled module. May be empty if
+ -- there are no modules loaded. This list is replaced by
+ -- :load, :reload, and :add. In between it may be modified
+ -- by :module.
+
+ ghc_e :: Bool, -- True if this is 'ghc -e' (or runghc)
+
+ -- help text to display to a user
+ short_help :: String,
+ long_help :: String,
+ mod_infos :: !(Map ModuleName ModInfo)
+ }
+
+type TickArray = Array Int [(BreakIndex,SrcSpan)]
+
+data GHCiOption
+ = ShowTiming -- show time/allocs after evaluation
+ | ShowType -- show the type of expressions
+ | RevertCAFs -- revert CAFs after every evaluation
+ | Multiline -- use multiline commands
+ | CollectInfo -- collect and cache information about modules after load
+ deriving Eq
+
+data BreakLocation
+ = BreakLocation
+ { breakModule :: !GHC.Module
+ , breakLoc :: !SrcSpan
+ , breakTick :: {-# UNPACK #-} !Int
+ , onBreakCmd :: String
+ }
+
+instance Eq BreakLocation where
+ loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
+ breakTick loc1 == breakTick loc2
+
+prettyLocations :: [(Int, BreakLocation)] -> SDoc
+prettyLocations [] = text "No active breakpoints."
+prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
+
+instance Outputable BreakLocation where
+ ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
+ if null (onBreakCmd loc)
+ then empty
+ else doubleQuotes (text (onBreakCmd loc))
+
+recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
+recordBreak brkLoc = do
+ st <- getGHCiState
+ let oldActiveBreaks = breaks st
+ -- don't store the same break point twice
+ case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
+ (nm:_) -> return (True, nm)
+ [] -> do
+ let oldCounter = break_ctr st
+ newCounter = oldCounter + 1
+ setGHCiState $ st { break_ctr = newCounter,
+ breaks = (oldCounter, brkLoc) : oldActiveBreaks
+ }
+ return (False, oldCounter)
+
+newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
+
+reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
+reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
+
+reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
+reifyGHCi f = GHCi f'
+ where
+ -- f' :: IORef GHCiState -> Ghc a
+ f' gs = reifyGhc (f'' gs)
+ -- f'' :: IORef GHCiState -> Session -> IO a
+ f'' gs s = f (s, gs)
+
+startGHCi :: GHCi a -> GHCiState -> Ghc a
+startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
+
+instance Functor GHCi where
+ fmap = liftM
+
+instance Applicative GHCi where
+ pure = return
+ (<*>) = ap
+
+instance Monad GHCi where
+ (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
+ return a = GHCi $ \_ -> return a
+
+getGHCiState :: GHCi GHCiState
+getGHCiState = GHCi $ \r -> liftIO $ readIORef r
+setGHCiState :: GHCiState -> GHCi ()
+setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
+modifyGHCiState :: (GHCiState -> GHCiState) -> GHCi ()
+modifyGHCiState f = GHCi $ \r -> liftIO $ readIORef r >>= writeIORef r . f
+
+liftGhc :: Ghc a -> GHCi a
+liftGhc m = GHCi $ \_ -> m
+
+instance MonadIO GHCi where
+ liftIO = liftGhc . liftIO
+
+instance HasDynFlags GHCi where
+ getDynFlags = getSessionDynFlags
+
+instance GhcMonad GHCi where
+ setSession s' = liftGhc $ setSession s'
+ getSession = liftGhc $ getSession
+
+instance HasDynFlags (InputT GHCi) where
+ getDynFlags = lift getDynFlags
+
+instance GhcMonad (InputT GHCi) where
+ setSession = lift . setSession
+ getSession = lift getSession
+
+instance ExceptionMonad GHCi where
+ gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
+ gmask f =
+ GHCi $ \s -> gmask $ \io_restore ->
+ let
+ g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
+ in
+ unGHCi (f g_restore) s
+
+instance Haskeline.MonadException Ghc where
+ controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
+ run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)
+ in fmap (flip unGhc s) $ f run'
+
+instance Haskeline.MonadException GHCi where
+ controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
+ run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)
+ in fmap (flip unGHCi s) $ f run'
+
+instance ExceptionMonad (InputT GHCi) where
+ gcatch = Haskeline.catch
+ gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)
+
+isOptionSet :: GHCiOption -> GHCi Bool
+isOptionSet opt
+ = do st <- getGHCiState
+ return (opt `elem` options st)
+
+setOption :: GHCiOption -> GHCi ()
+setOption opt
+ = do st <- getGHCiState
+ setGHCiState (st{ options = opt : filter (/= opt) (options st) })
+
+unsetOption :: GHCiOption -> GHCi ()
+unsetOption opt
+ = do st <- getGHCiState
+ setGHCiState (st{ options = filter (/= opt) (options st) })
+
+printForUserNeverQualify :: GhcMonad m => SDoc -> m ()
+printForUserNeverQualify doc = do
+ dflags <- getDynFlags
+ liftIO $ Outputable.printForUser dflags stdout neverQualify doc
+
+printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()
+printForUserModInfo info doc = do
+ dflags <- getDynFlags
+ mUnqual <- GHC.mkPrintUnqualifiedForModule info
+ unqual <- maybe GHC.getPrintUnqual return mUnqual
+ liftIO $ Outputable.printForUser dflags stdout unqual doc
+
+printForUser :: GhcMonad m => SDoc -> m ()
+printForUser doc = do
+ unqual <- GHC.getPrintUnqual
+ dflags <- getDynFlags
+ liftIO $ Outputable.printForUser dflags stdout unqual doc
+
+printForUserPartWay :: SDoc -> GHCi ()
+printForUserPartWay doc = do
+ unqual <- GHC.getPrintUnqual
+ dflags <- getDynFlags
+ liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
+
+-- | Run a single Haskell expression
+runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.RunResult)
+runStmt expr step = do
+ st <- getGHCiState
+ reifyGHCi $ \x ->
+ withProgName (progname st) $
+ withArgs (args st) $
+ reflectGHCi x $ do
+ GHC.handleSourceError (\e -> do GHC.printException e;
+ return Nothing) $ do
+ r <- GHC.runStmtWithLocation (progname st) (line_number st) expr step
+ return (Just r)
+
+runDecls :: String -> GHCi [GHC.Name]
+runDecls decls = do
+ st <- getGHCiState
+ reifyGHCi $ \x ->
+ withProgName (progname st) $
+ withArgs (args st) $
+ reflectGHCi x $ do
+ GHC.handleSourceError (\e -> do GHC.printException e; return []) $ do
+ GHC.runDeclsWithLocation (progname st) (line_number st) decls
+
+resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
+resume canLogSpan step = do
+ st <- getGHCiState
+ reifyGHCi $ \x ->
+ withProgName (progname st) $
+ withArgs (args st) $
+ reflectGHCi x $ do
+ GHC.resume canLogSpan step
+
+-- --------------------------------------------------------------------------
+-- timing & statistics
+
+timeIt :: InputT GHCi a -> InputT GHCi a
+timeIt action
+ = do b <- lift $ isOptionSet ShowTiming
+ if not b
+ then action
+ else do allocs1 <- liftIO $ getAllocations
+ time1 <- liftIO $ getCPUTime
+ a <- action
+ allocs2 <- liftIO $ getAllocations
+ time2 <- liftIO $ getCPUTime
+ dflags <- getDynFlags
+ liftIO $ printTimes dflags (fromIntegral (allocs2 - allocs1))
+ (time2 - time1)
+ return a
+
+foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
+ -- defined in ghc/rts/Stats.c
+
+printTimes :: DynFlags -> Integer -> Integer -> IO ()
+printTimes dflags allocs psecs
+ = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
+ secs_str = showFFloat (Just 2) secs
+ putStrLn (showSDoc dflags (
+ parens (text (secs_str "") <+> text "secs" <> comma <+>
+ text (show allocs) <+> text "bytes")))
+
+-----------------------------------------------------------------------------
+-- reverting CAFs
+
+revertCAFs :: GHCi ()
+revertCAFs = do
+ liftIO rts_revertCAFs
+ s <- getGHCiState
+ when (not (ghc_e s)) $ liftIO turnOffBuffering
+ -- Have to turn off buffering again, because we just
+ -- reverted stdout, stderr & stdin to their defaults.
+
+foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
+ -- Make it "safe", just in case
+
+-----------------------------------------------------------------------------
+-- To flush buffers for the *interpreted* computation we need
+-- to refer to *its* stdout/stderr handles
+
+GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ())
+GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
+GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
+
+-- After various attempts, I believe this is the least bad way to do
+-- what we want. We know look up the address of the static stdin,
+-- stdout, and stderr closures in the loaded base package, and each
+-- time we need to refer to them we cast the pointer to a Handle.
+-- This avoids any problems with the CAF having been reverted, because
+-- we'll always get the current value.
+--
+-- The previous attempt that didn't work was to compile an expression
+-- like "hSetBuffering stdout NoBuffering" into an expression of type
+-- IO () and run this expression each time we needed it, but the
+-- problem is that evaluating the expression might cache the contents
+-- of the Handle rather than referring to it from its static address
+-- each time. There's no safe workaround for this.
+
+initInterpBuffering :: Ghc ()
+initInterpBuffering = do -- make sure these are linked
+ dflags <- GHC.getSessionDynFlags
+ liftIO $ do
+ initDynLinker dflags
+
+ -- ToDo: we should really look up these names properly, but
+ -- it's a fiddle and not all the bits are exposed via the GHC
+ -- interface.
+ mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdin_closure"
+ mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure"
+ mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stderr_closure"
+
+ let f ref (Just ptr) = writeIORef ref ptr
+ f _ Nothing = panic "interactiveUI:setBuffering2"
+ zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr]
+ [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
+
+flushInterpBuffers :: GHCi ()
+flushInterpBuffers
+ = liftIO $ do getHandle stdout_ptr >>= hFlush
+ getHandle stderr_ptr >>= hFlush
+
+turnOffBuffering :: IO ()
+turnOffBuffering
+ = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
+ mapM_ (\h -> hSetBuffering h NoBuffering) hdls
+
+getHandle :: IORef (Ptr ()) -> IO Handle
+getHandle ref = do
+ (Ptr addr) <- readIORef ref
+ case addrToAny# addr of (# hval #) -> return (unsafeCoerce# hval)
diff --git a/src/GhciTags.hs b/src/GhciTags.hs
new file mode 100644
index 0000000..b250637
--- /dev/null
+++ b/src/GhciTags.hs
@@ -0,0 +1,206 @@
+-----------------------------------------------------------------------------
+--
+-- GHCi's :ctags and :etags commands
+--
+-- (c) The GHC Team 2005-2007
+--
+-----------------------------------------------------------------------------
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+module GhciTags (
+ createCTagsWithLineNumbersCmd,
+ createCTagsWithRegExesCmd,
+ createETagsFileCmd
+) where
+
+import Exception
+import GHC
+import GhciMonad
+import Outputable
+
+-- ToDo: figure out whether we need these, and put something appropriate
+-- into the GHC API instead
+import Name (nameOccName)
+import OccName (pprOccName)
+import ConLike
+import MonadUtils
+
+import Data.Function
+import Data.Maybe
+import Data.Ord
+import Panic
+import Data.List
+import Control.Monad
+import System.IO
+import System.IO.Error
+
+-----------------------------------------------------------------------------
+-- create tags file for currently loaded modules.
+
+createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,
+ createETagsFileCmd :: String -> GHCi ()
+
+createCTagsWithLineNumbersCmd "" =
+ ghciCreateTagsFile CTagsWithLineNumbers "tags"
+createCTagsWithLineNumbersCmd file =
+ ghciCreateTagsFile CTagsWithLineNumbers file
+
+createCTagsWithRegExesCmd "" =
+ ghciCreateTagsFile CTagsWithRegExes "tags"
+createCTagsWithRegExesCmd file =
+ ghciCreateTagsFile CTagsWithRegExes file
+
+createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
+createETagsFileCmd file = ghciCreateTagsFile ETags file
+
+data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes
+
+ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
+ghciCreateTagsFile kind file = do
+ createTagsFile kind file
+
+-- ToDo:
+-- - remove restriction that all modules must be interpreted
+-- (problem: we don't know source locations for entities unless
+-- we compiled the module.
+--
+-- - extract createTagsFile so it can be used from the command-line
+-- (probably need to fix first problem before this is useful).
+--
+createTagsFile :: TagsKind -> FilePath -> GHCi ()
+createTagsFile tagskind tagsFile = do
+ graph <- GHC.getModuleGraph
+ mtags <- mapM listModuleTags (map GHC.ms_mod graph)
+ either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags
+ case either_res of
+ Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e
+ Right _ -> return ()
+
+
+listModuleTags :: GHC.Module -> GHCi [TagInfo]
+listModuleTags m = do
+ is_interpreted <- GHC.moduleIsInterpreted m
+ -- should we just skip these?
+ when (not is_interpreted) $
+ let mName = GHC.moduleNameString (GHC.moduleName m) in
+ throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))
+ mbModInfo <- GHC.getModuleInfo m
+ case mbModInfo of
+ Nothing -> return []
+ Just mInfo -> do
+ dflags <- getDynFlags
+ mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo
+ let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual
+ let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo
+ let localNames = filter ((m==) . nameModule) names
+ mbTyThings <- mapM GHC.lookupName localNames
+ return $! [ tagInfo dflags unqual exported kind name realLoc
+ | tyThing <- catMaybes mbTyThings
+ , let name = getName tyThing
+ , let exported = GHC.modInfoIsExportedName mInfo name
+ , let kind = tyThing2TagKind tyThing
+ , let loc = srcSpanStart (nameSrcSpan name)
+ , RealSrcLoc realLoc <- [loc]
+ ]
+
+ where
+ tyThing2TagKind (AnId _) = 'v'
+ tyThing2TagKind (AConLike RealDataCon{}) = 'd'
+ tyThing2TagKind (AConLike PatSynCon{}) = 'p'
+ tyThing2TagKind (ATyCon _) = 't'
+ tyThing2TagKind (ACoAxiom _) = 'x'
+
+
+data TagInfo = TagInfo
+ { tagExported :: Bool -- is tag exported
+ , tagKind :: Char -- tag kind
+ , tagName :: String -- tag name
+ , tagFile :: String -- file name
+ , tagLine :: Int -- line number
+ , tagCol :: Int -- column number
+ , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset
+ }
+
+
+-- get tag info, for later translation into Vim or Emacs style
+tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc
+ -> TagInfo
+tagInfo dflags unqual exported kind name loc
+ = TagInfo exported kind
+ (showSDocForUser dflags unqual $ pprOccName (nameOccName name))
+ (showSDocForUser dflags unqual $ ftext (srcLocFile loc))
+ (srcLocLine loc) (srcLocCol loc) Nothing
+
+
+collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
+-- ctags style with the Ex exresion being just the line number, Vim et al
+collateAndWriteTags CTagsWithLineNumbers file tagInfos = do
+ let tags = unlines $ sort $ map showCTag tagInfos
+ tryIO (writeFile file tags)
+
+-- ctags style with the Ex exresion being a regex searching the line, Vim et al
+collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al
+ tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos
+ let tags = unlines $ sort $ map showCTag $concat tagInfoGroups
+ tryIO (writeFile file tags)
+
+collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
+ tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos
+ let tagGroups = map processGroup tagInfoGroups
+ tryIO (writeFile file $ concat tagGroups)
+
+ where
+ processGroup [] = throwGhcException (CmdLineError "empty tag file group??")
+ processGroup group@(tagInfo:_) =
+ let tags = unlines $ map showETag group in
+ "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags
+
+
+makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]
+makeTagGroupsWithSrcInfo tagInfos = do
+ let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos
+ mapM addTagSrcInfo groups
+
+ where
+ addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")
+ addTagSrcInfo group@(tagInfo:_) = do
+ file <- readFile $tagFile tagInfo
+ let sortedGroup = sortBy (comparing tagLine) group
+ return $ perFile sortedGroup 1 0 $ lines file
+
+ perFile allTags@(tag:tags) cnt pos allLs@(l:ls)
+ | tagLine tag > cnt =
+ perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls
+ | tagLine tag == cnt =
+ tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs
+ perFile _ _ _ _ = []
+
+
+-- ctags format, for Vim et al
+showCTag :: TagInfo -> String
+showCTag ti =
+ tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" ++
+ tagKind ti : ( if tagExported ti then "" else "\tfile:" )
+
+ where
+ tagCmd =
+ case tagSrcInfo ti of
+ Nothing -> show $tagLine ti
+ Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"
+
+ where
+ escapeSlashes '/' r = '\\' : '/' : r
+ escapeSlashes '\\' r = '\\' : '\\' : r
+ escapeSlashes c r = c : r
+
+
+-- etags format, for Emacs/XEmacs
+showETag :: TagInfo -> String
+showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,
+ tagSrcInfo = Just (srcLine,charPos) }
+ = take (colNo - 1) srcLine ++ tag
+ ++ "\x7f" ++ tag
+ ++ "\x01" ++ show lineNo
+ ++ "," ++ show charPos
+showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")
+
diff --git a/src/GhciTypes.hs b/src/GhciTypes.hs
new file mode 100644
index 0000000..00f20ae
--- /dev/null
+++ b/src/GhciTypes.hs
@@ -0,0 +1,57 @@
+-- | Types used separate to GHCi vanilla.
+
+module GhciTypes where
+
+import Data.Time
+import GHC
+import Outputable
+
+-- | Info about a module. This information is generated every time a
+-- module is loaded.
+data ModInfo =
+ ModInfo {modinfoSummary :: !ModSummary
+ -- ^ Summary generated by GHC. Can be used to access more
+ -- information about the module.
+ ,modinfoSpans :: ![SpanInfo]
+ -- ^ Generated set of information about all spans in the
+ -- module that correspond to some kind of identifier for
+ -- which there will be type info and/or location info.
+ ,modinfoInfo :: !ModuleInfo
+ -- ^ Again, useful from GHC for accessing information
+ -- (exports, instances, scope) from a module.
+ ,modinfoLastUpdate :: !UTCTime
+ }
+
+-- | Type of some span of source code. Most of these fields are
+-- unboxed but Haddock doesn't show that.
+data SpanInfo =
+ SpanInfo {spaninfoStartLine :: {-# UNPACK #-} !Int
+ -- ^ Start line of the span.
+ ,spaninfoStartCol :: {-# UNPACK #-} !Int
+ -- ^ Start column of the span.
+ ,spaninfoEndLine :: {-# UNPACK #-} !Int
+ -- ^ End line of the span (absolute).
+ ,spaninfoEndCol :: {-# UNPACK #-} !Int
+ -- ^ End column of the span (absolute).
+ ,spaninfoType :: !(Maybe Type)
+ -- ^ A pretty-printed representation fo the type.
+ ,spaninfoVar :: !(Maybe Id)
+ -- ^ The actual 'Var' associated with the span, if
+ -- any. This can be useful for accessing a variety of
+ -- information about the identifier such as module,
+ -- locality, definition location, etc.
+ }
+
+instance Outputable SpanInfo where
+ ppr (SpanInfo sl sc el ec ty v) =
+ (int sl <>
+ text ":" <>
+ int sc <>
+ text "-") <>
+ (int el <>
+ text ":" <>
+ int ec <>
+ text ": ") <>
+ (ppr v <>
+ text " :: " <>
+ ppr ty)
diff --git a/src/InteractiveUI.hs b/src/InteractiveUI.hs
new file mode 100644
index 0000000..fa60b38
--- /dev/null
+++ b/src/InteractiveUI.hs
@@ -0,0 +1,3435 @@
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# OPTIONS -fno-cse #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
+
+-----------------------------------------------------------------------------
+--
+-- GHC Interactive User Interface
+--
+-- (c) The GHC Team 2005-2006
+--
+-----------------------------------------------------------------------------
+
+module InteractiveUI (
+ interactiveUI,
+ GhciSettings(..),
+ defaultGhciSettings,
+ ghciCommands,
+ ghciWelcomeMsg
+ ) where
+
+#include "HsVersions.h"
+
+-- Intero
+import qualified Paths_intero
+import Data.Version (showVersion)
+import qualified Data.Map as M
+import GhciInfo
+import GhciTypes
+import GhciFind
+import GHC (getModuleGraph)
+
+-- GHCi
+import qualified GhciMonad ( args, runStmt )
+import GhciMonad hiding ( args, runStmt )
+import GhciTags
+import Debugger
+
+-- The GHC interface
+import DynFlags
+import GhcMonad ( modifySession )
+import qualified GHC
+import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),
+ TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
+ handleSourceError )
+import HsImpExp
+import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
+ setInteractivePrintName )
+import Module
+import Name
+#if __GLASGOW_HASKELL__ < 709
+import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap )
+#else
+import Packages ( trusted, getPackageDetails, listVisibleModuleNames )
+#endif
+import PprTyThing
+import RdrName ( getGRE_NameQualifier_maybes )
+import SrcLoc
+import qualified Lexer
+
+import StringBuffer
+#if __GLASGOW_HASKELL__ < 709
+import UniqFM ( eltsUFM )
+#endif
+import Outputable hiding ( printForUser, printForUserPartWay, bold )
+
+-- Other random utilities
+import BasicTypes hiding ( isTopLevel )
+import Config
+import Digraph
+import Encoding
+import FastString
+import Linker
+import Maybes ( orElse, expectJust )
+import NameSet
+import Panic hiding ( showException )
+import Util
+
+-- Haskell Libraries
+import System.Console.Haskeline as Haskeline
+
+import Control.Applicative hiding (empty)
+import Control.Monad as Monad
+import Control.Monad.Trans.Class
+import Control.Monad.IO.Class
+
+import Data.Array
+import qualified Data.ByteString.Char8 as BS
+import Data.Char
+import Data.Function
+import Data.IORef ( IORef, readIORef, writeIORef )
+import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
+ partition, sort, sortBy )
+import Data.Maybe
+
+import Exception hiding (catch)
+
+import Foreign.C
+#if __GLASGOW_HASKELL__ < 709
+import Foreign.Safe
+#else
+import Foreign
+#endif
+
+import System.Directory
+import System.Environment
+import System.Exit ( exitWith, ExitCode(..) )
+import System.FilePath
+import System.IO
+import System.IO.Error
+import System.IO.Unsafe ( unsafePerformIO )
+import System.Process
+import Text.Printf
+import Text.Read ( readMaybe )
+
+#ifndef mingw32_HOST_OS
+import System.Posix hiding ( getEnv )
+#else
+import qualified System.Win32
+#endif
+
+import GHC.Exts ( unsafeCoerce# )
+import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
+import GHC.IO.Handle ( hFlushAll )
+import GHC.TopHandler ( topHandler )
+
+#if __GLASGOW_HASKELL__ < 709
+packageString :: PackageId -> String
+packageString = packageIdString
+modulePackage :: Module -> PackageId
+modulePackage = modulePackageId
+#else
+packageString :: PackageKey -> String
+packageString = packageKeyString
+modulePackage :: Module -> PackageKey
+modulePackage = modulePackageKey
+#endif
+
+-----------------------------------------------------------------------------
+
+data GhciSettings = GhciSettings {
+ availableCommands :: [Command],
+ shortHelpText :: String,
+ fullHelpText :: String,
+ defPrompt :: String,
+ defPrompt2 :: String
+ }
+
+defaultGhciSettings :: GhciSettings
+defaultGhciSettings =
+ GhciSettings {
+ availableCommands = ghciCommands,
+ shortHelpText = defShortHelpText,
+ fullHelpText = defFullHelpText,
+ defPrompt = default_prompt,
+ defPrompt2 = default_prompt2
+ }
+
+ghciWelcomeMsg :: String
+ghciWelcomeMsg =
+ unlines [versionString
+ ,"Type :intro and press enter for an introduction of the standard commands."]
+
+versionString =
+ "Intero " ++
+ showVersion Paths_intero.version ++
+ " (GHC " ++
+ cProjectVersion ++
+ ")"
+
+cmdName :: Command -> String
+cmdName (n,_,_) = n
+
+GLOBAL_VAR(macros_ref, [], [Command])
+
+ghciCommands :: [Command]
+ghciCommands = [
+ -- Hugs users are accustomed to :e, so make sure it doesn't overlap
+ ("?", keepGoing help, noCompletion),
+ ("add", keepGoingPaths addModule, completeFilename),
+ ("intro", keepGoing intro, noCompletion),
+ ("abandon", keepGoing abandonCmd, noCompletion),
+ ("break", keepGoing breakCmd, completeIdentifier),
+ ("back", keepGoing backCmd, noCompletion),
+ ("browse", keepGoing' (browseCmd False), completeModule),
+ ("browse!", keepGoing' (browseCmd True), completeModule),
+ ("cd", keepGoing' changeDirectory, completeFilename),
+ ("check", keepGoing' checkModule, completeHomeModule),
+ ("continue", keepGoing continueCmd, noCompletion),
+ ("complete", keepGoing completeCmd, noCompletion),
+ ("cmd", keepGoing cmdCmd, completeExpression),
+ ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),
+ ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),
+ ("def", keepGoing (defineMacro False), completeExpression),
+ ("def!", keepGoing (defineMacro True), completeExpression),
+ ("delete", keepGoing deleteCmd, noCompletion),
+ ("edit", keepGoing' editFile, completeFilename),
+ ("etags", keepGoing createETagsFileCmd, completeFilename),
+ ("force", keepGoing forceCmd, completeExpression),
+ ("forward", keepGoing forwardCmd, noCompletion),
+ ("help", keepGoing help, noCompletion),
+ ("history", keepGoing historyCmd, noCompletion),
+ ("info", keepGoing' (info False), completeIdentifier),
+ ("info!", keepGoing' (info True), completeIdentifier),
+ ("issafe", keepGoing' isSafeCmd, completeModule),
+ ("kind", keepGoing' (kindOfType False), completeIdentifier),
+ ("kind!", keepGoing' (kindOfType True), completeIdentifier),
+ ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
+ ("list", keepGoing' listCmd, noCompletion),
+ ("module", keepGoing moduleCmd, completeSetModule),
+ ("main", keepGoing runMain, completeFilename),
+ ("print", keepGoing printCmd, completeExpression),
+ ("quit", quit, noCompletion),
+ ("reload", keepGoing' reloadModule, noCompletion),
+ ("run", keepGoing runRun, completeFilename),
+ ("script", keepGoing' scriptCmd, completeFilename),
+ ("set", keepGoing setCmd, completeSetOptions),
+ ("seti", keepGoing setiCmd, completeSeti),
+ ("show", keepGoing showCmd, completeShowOptions),
+ ("showi", keepGoing showiCmd, completeShowiOptions),
+ ("sprint", keepGoing sprintCmd, completeExpression),
+ ("step", keepGoing stepCmd, completeIdentifier),
+ ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
+ ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
+ ("type", keepGoing' typeOfExpr, completeExpression),
+ ("type-at", keepGoing' typeAt, completeExpression),
+ ("all-types", keepGoing' allTypes, completeExpression),
+ ("uses", keepGoing' findAllUses, completeExpression),
+ ("loc-at", keepGoing' locationAt, completeExpression),
+ ("trace", keepGoing traceCmd, completeExpression),
+ ("undef", keepGoing undefineMacro, completeMacro),
+ ("unset", keepGoing unsetOptions, completeSetOptions)
+ ]
+
+
+-- We initialize readline (in the interactiveUI function) to use
+-- word_break_chars as the default set of completion word break characters.
+-- This can be overridden for a particular command (for example, filename
+-- expansion shouldn't consider '/' to be a word break) by setting the third
+-- entry in the Command tuple above.
+--
+-- NOTE: in order for us to override the default correctly, any custom entry
+-- must be a SUBSET of word_break_chars.
+word_break_chars :: String
+word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
+ specials = "(),;[]`{}"
+ spaces = " \t\n"
+ in spaces ++ specials ++ symbols
+
+flagWordBreakChars :: String
+flagWordBreakChars = " \t\n"
+
+
+keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
+keepGoing a str = keepGoing' (lift . a) str
+
+keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
+keepGoing' a str = a str >> return False
+
+keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
+keepGoingPaths a str
+ = do case toArgs str of
+ Left err -> liftIO $ hPutStrLn stderr err
+ Right args -> a args
+ return False
+
+defShortHelpText :: String
+defShortHelpText = "use :? for help.\n"
+
+defFullHelpText :: String
+defFullHelpText =
+ " Commands available from the prompt:\n" ++
+ "\n" ++
+ " <statement> evaluate/run <statement>\n" ++
+ " : repeat last command\n" ++
+ " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
+ " :add [*]<module> ... add module(s) to the current target set\n" ++
+ " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
+ " (!: more details; *: all top-level names)\n" ++
+ " :cd <dir> change directory to <dir>\n" ++
+ " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
+ " :complete <dom> [<rng>] <s> list completions for partial input string\n" ++
+ " :ctags[!] [<file>] create tags file for Vi (default: \"tags\")\n" ++
+ " (!: use regex instead of line number)\n" ++
+ " :def <cmd> <expr> define command :<cmd> (later defined command has\n" ++
+ " precedence, ::<cmd> is always a builtin command)\n" ++
+ " :edit <file> edit file\n" ++
+ " :edit edit last module\n" ++
+ " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
+ " :help, :? display this list of commands\n" ++
+ " :info[!] [<name> ...] display information about the given names\n" ++
+ " (!: do not filter instances)\n" ++
+ " :issafe [<mod>] display safe haskell information of module <mod>\n" ++
+ " :kind[!] <type> show the kind of <type>\n" ++
+ " (!: also print the normalised type)\n" ++
+ " :load [*]<module> ... load module(s) and their dependents\n" ++
+ " :main [<arguments> ...] run the main function with the given arguments\n" ++
+ " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
+ " :quit exit GHCi\n" ++
+ " :reload reload the current module set\n" ++
+ " :run function [<arguments> ...] run the function with the given arguments\n" ++
+ " :script <filename> run the script <filename>\n" ++
+ " :type <expr> show the type of <expr>\n" ++
+ " :type-at <loc> show the type of <loc> of format: \n" ++
+ " <filename> <line> <col> <end-line> <end-col> <text>\n" ++
+ " text is used for when the span is out of date\n" ++
+ " :undef <cmd> undefine user-defined command :<cmd>\n" ++
+ " :loc-at <loc> return the location of the identifier at <loc> of format: \n" ++
+ " <filename> <line> <col> <end-line> <end-col> <text>\n" ++
+ " text is used for when the span is out of date\n" ++
+ " :all-types return a list of all types in the project including\n" ++
+ " sub-expressions and local bindings\n" ++
+ " :undef <cmd> undefine user-defined command :<cmd>\n" ++
+ " :!<command> run the shell command <command>\n" ++
+ "\n" ++
+ " -- Commands for debugging:\n" ++
+ "\n" ++
+ " :abandon at a breakpoint, abandon current computation\n" ++
+ " :back go back in the history (after :trace)\n" ++
+ " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
+ " :break <name> set a breakpoint on the specified function\n" ++
+ " :continue resume after a breakpoint\n" ++
+ " :delete <number> delete the specified breakpoint\n" ++
+ " :delete * delete all breakpoints\n" ++
+ " :force <expr> print <expr>, forcing unevaluated parts\n" ++
+ " :forward go forward in the history (after :back)\n" ++
+ " :history [<n>] after :trace, show the execution history\n" ++
+ " :list show the source code around current breakpoint\n" ++
+ " :list <identifier> show the source code for <identifier>\n" ++
+ " :list [<module>] <line> show the source code around line number <line>\n" ++
+ " :print [<name> ...] prints a value without forcing its computation\n" ++
+ " :sprint [<name> ...] simplifed version of :print\n" ++
+ " :step single-step after stopping at a breakpoint\n"++
+ " :step <expr> single-step into <expr>\n"++
+ " :steplocal single-step within the current top-level binding\n"++
+ " :stepmodule single-step restricted to the current module\n"++
+ " :trace trace after stopping at a breakpoint\n"++
+ " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++
+
+ "\n" ++
+ " -- Commands for changing settings:\n" ++
+ "\n" ++
+ " :set <option> ... set options\n" ++
+ " :seti <option> ... set options for interactive evaluation only\n" ++
+ " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
+ " :set prog <progname> set the value returned by System.getProgName\n" ++
+ " :set prompt <prompt> set the prompt used in GHCi\n" ++
+ " :set prompt2 <prompt> set the continuation prompt used in GHCi\n" ++
+ " :set editor <cmd> set the command used for :edit\n" ++
+ " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
+ " :unset <option> ... unset options\n" ++
+ "\n" ++
+ " Options for ':set' and ':unset':\n" ++
+ "\n" ++
+ " +m allow multiline commands\n" ++
+ " +r revert top-level expressions after each evaluation\n" ++
+ " +s print timing/memory stats after each evaluation\n" ++
+ " +t print type after evaluation\n" ++
+ " +c collect type/location info after loading modules\n" ++
+ " -<flags> most GHC command line flags can also be set here\n" ++
+ " (eg. -v2, -XFlexibleInstances, etc.)\n" ++
+ " for GHCi-specific flags, see User's Guide,\n"++
+ " Flag reference, Interactive-mode options\n" ++
+ "\n" ++
+ " -- Commands for displaying information:\n" ++
+ "\n" ++
+ " :show bindings show the current bindings made at the prompt\n" ++
+ " :show breaks show the active breakpoints\n" ++
+ " :show context show the breakpoint context\n" ++
+ " :show imports show the current imports\n" ++
+ " :show linker show current linker state\n" ++
+ " :show modules show the currently loaded modules\n" ++
+ " :show packages show the currently active package flags\n" ++
+ " :show paths show the currently active search paths\n" ++
+ " :show language show the currently active language flags\n" ++
+ " :show <setting> show value of <setting>, which is one of\n" ++
+ " [args, prog, prompt, editor, stop]\n" ++
+ " :showi language show language flags for interactive evaluation\n" ++
+ "\n"
+
+findEditor :: IO String
+findEditor = do
+ getEnv "EDITOR"
+ `catchIO` \_ -> do
+#if mingw32_HOST_OS
+ win <- System.Win32.getWindowsDirectory
+ return (win </> "notepad.exe")
+#else
+ return ""
+#endif
+
+foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt
+
+default_progname, default_prompt, default_prompt2, default_stop :: String
+default_progname = "<interactive>"
+default_prompt = "%s> "
+default_prompt2 = "%s| "
+default_stop = ""
+
+default_args :: [String]
+default_args = []
+
+interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
+ -> Ghc ()
+interactiveUI config srcs maybe_exprs = do
+ -- although GHCi compiles with -prof, it is not usable: the byte-code
+ -- compiler and interpreter don't work with profiling. So we check for
+ -- this up front and emit a helpful error message (#2197)
+ i <- liftIO $ isProfiled
+ when (i /= 0) $
+ throwGhcException (InstallationError "GHCi cannot be used when compiled with -prof")
+
+ -- HACK! If we happen to get into an infinite loop (eg the user
+ -- types 'let x=x in x' at the prompt), then the thread will block
+ -- on a blackhole, and become unreachable during GC. The GC will
+ -- detect that it is unreachable and send it the NonTermination
+ -- exception. However, since the thread is unreachable, everything
+ -- it refers to might be finalized, including the standard Handles.
+ -- This sounds like a bug, but we don't have a good solution right
+ -- now.
+ _ <- liftIO $ newStablePtr stdin
+ _ <- liftIO $ newStablePtr stdout
+ _ <- liftIO $ newStablePtr stderr
+
+ -- Initialise buffering for the *interpreted* I/O system
+ initInterpBuffering
+
+ -- The initial set of DynFlags used for interactive evaluation is the same
+ -- as the global DynFlags, plus -XExtendedDefaultRules and
+ -- -XNoMonomorphismRestriction.
+ dflags <- getDynFlags
+ let dflags' = (`xopt_set` Opt_ExtendedDefaultRules)
+ . (`xopt_unset` Opt_MonomorphismRestriction)
+ $ dflags
+ GHC.setInteractiveDynFlags dflags'
+
+ liftIO $ when (isNothing maybe_exprs) $ do
+ -- Only for GHCi (not runghc and ghc -e):
+
+ -- Turn buffering off for the compiled program's stdout/stderr
+ turnOffBuffering
+ -- Turn buffering off for GHCi's stdout
+ hFlush stdout
+ hSetBuffering stdout NoBuffering
+ -- We don't want the cmd line to buffer any input that might be
+ -- intended for the program, so unbuffer stdin.
+ hSetBuffering stdin NoBuffering
+ hSetBuffering stderr NoBuffering
+#if defined(mingw32_HOST_OS)
+ -- On Unix, stdin will use the locale encoding. The IO library
+ -- doesn't do this on Windows (yet), so for now we use UTF-8,
+ -- for consistency with GHC 6.10 and to make the tests work.
+ hSetEncoding stdin utf8
+#endif
+
+ default_editor <- liftIO $ findEditor
+
+ startGHCi (runGHCi srcs maybe_exprs)
+ GHCiState{ progname = default_progname,
+ GhciMonad.args = default_args,
+ prompt = defPrompt config,
+ prompt2 = defPrompt2 config,
+ stop = default_stop,
+ editor = default_editor,
+ options = [],
+ line_number = 1,
+ break_ctr = 0,
+ breaks = [],
+ tickarrays = emptyModuleEnv,
+ ghci_commands = availableCommands config,
+ last_command = Nothing,
+ cmdqueue = [],
+ remembered_ctx = [],
+ transient_ctx = [],
+ ghc_e = isJust maybe_exprs,
+ short_help = shortHelpText config,
+ long_help = fullHelpText config,
+ mod_infos = M.empty
+ }
+
+ return ()
+
+withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
+withGhcAppData right left = do
+ either_dir <- tryIO (getAppUserDataDirectory "ghc")
+ case either_dir of
+ Right dir ->
+ do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
+ right dir
+ _ -> left
+
+runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
+runGHCi paths maybe_exprs = do
+ dflags <- getDynFlags
+ let
+ read_dot_files = not (gopt Opt_IgnoreDotGhci dflags)
+
+ current_dir = return (Just ".ghci")
+
+ app_user_dir = liftIO $ withGhcAppData
+ (\dir -> return (Just (dir </> "ghci.conf")))
+ (return Nothing)
+
+ home_dir = do
+ either_dir <- liftIO $ tryIO (getEnv "HOME")
+ case either_dir of
+ Right home -> return (Just (home </> ".ghci"))
+ _ -> return Nothing
+
+ canonicalizePath' :: FilePath -> IO (Maybe FilePath)
+ canonicalizePath' fp = liftM Just (canonicalizePath fp)
+ `catchIO` \_ -> return Nothing
+
+ sourceConfigFile :: FilePath -> GHCi ()
+ sourceConfigFile file = do
+ exists <- liftIO $ doesFileExist file
+ when exists $ do
+ dir_ok <- liftIO $ checkPerms (getDirectory file)
+ file_ok <- liftIO $ checkPerms file
+ when (dir_ok && file_ok) $ do
+ either_hdl <- liftIO $ tryIO (openFile file ReadMode)
+ case either_hdl of
+ Left _e -> return ()
+ -- NOTE: this assumes that runInputT won't affect the terminal;
+ -- can we assume this will always be the case?
+ -- This would be a good place for runFileInputT.
+ Right hdl ->
+ do runInputTWithPrefs defaultPrefs defaultSettings $
+ runCommands $ fileLoop hdl
+ liftIO (hClose hdl `catchIO` \_ -> return ())
+ where
+ getDirectory f = case takeDirectory f of "" -> "."; d -> d
+ --
+
+ setGHCContextFromGHCiState
+
+ when (read_dot_files) $ do
+ mcfgs0 <- sequence $ [ current_dir, app_user_dir, home_dir ] ++ map (return . Just ) (ghciScripts dflags)
+ mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0)
+ mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
+ -- nub, because we don't want to read .ghci twice if the
+ -- CWD is $HOME.
+
+ -- Perform a :load for files given on the GHCi command line
+ -- When in -e mode, if the load fails then we want to stop
+ -- immediately rather than going on to evaluate the expression.
+ when (not (null paths)) $ do
+ ok <- ghciHandle (\e -> do showException e; return Failed) $
+ -- TODO: this is a hack.
+ runInputTWithPrefs defaultPrefs defaultSettings $
+ loadModule paths
+ when (isJust maybe_exprs && failed ok) $
+ liftIO (exitWith (ExitFailure 1))
+
+ installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)
+
+ -- if verbosity is greater than 0, or we are connected to a
+ -- terminal, display the prompt in the interactive loop.
+ is_tty <- liftIO (hIsTerminalDevice stdin)
+ let show_prompt = verbosity dflags > 0 || is_tty
+
+ -- reset line number
+ getGHCiState >>= \st -> setGHCiState st{line_number=1}
+
+ case maybe_exprs of
+ Nothing ->
+ do
+ -- enter the interactive loop
+ runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
+ Just exprs -> do
+ -- just evaluate the expression we were given
+ enqueueCommands exprs
+ let hdle e = do st <- getGHCiState
+ -- flush the interpreter's stdout/stderr on exit (#3890)
+ flushInterpBuffers
+ -- Jump through some hoops to get the
+ -- current progname in the exception text:
+ -- <progname>: <exception>
+ liftIO $ withProgName (progname st)
+ $ topHandler e
+ -- this used to be topHandlerFastExit, see #2228
+ runInputTWithPrefs defaultPrefs defaultSettings $ do
+ -- make `ghc -e` exit nonzero on invalid input, see Trac #7962
+ runCommands' hdle (Just $ hdle (toException $ ExitFailure 1) >> return ()) (return Nothing)
+
+ -- and finally, exit
+ liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
+
+runGHCiInput :: InputT GHCi a -> GHCi a
+runGHCiInput f = do
+ dflags <- getDynFlags
+ histFile <- if gopt Opt_GhciHistory dflags
+ then liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
+ (return Nothing)
+ else return Nothing
+ runInputT
+ (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
+ f
+
+-- | How to get the next input line from the user
+nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
+nextInputLine show_prompt is_tty
+ | is_tty = do
+ prmpt <- if show_prompt then lift mkPrompt else return ""
+ r <- getInputLine prmpt
+ incrementLineNo
+ return r
+ | otherwise = do
+ when show_prompt $ lift mkPrompt >>= liftIO . putStr
+ fileLoop stdin
+
+-- NOTE: We only read .ghci files if they are owned by the current user,
+-- and aren't world writable. Otherwise, we could be accidentally
+-- running code planted by a malicious third party.
+
+-- Furthermore, We only read ./.ghci if . is owned by the current user
+-- and isn't writable by anyone else. I think this is sufficient: we
+-- don't need to check .. and ../.. etc. because "." always refers to
+-- the same directory while a process is running.
+
+checkPerms :: String -> IO Bool
+#ifdef mingw32_HOST_OS
+checkPerms _ = return True
+#else
+checkPerms name =
+ handleIO (\_ -> return False) $ do
+ st <- getFileStatus name
+ me <- getRealUserID
+ if fileOwner st /= me then do
+ putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
+ return False
+ else do
+ let mode = System.Posix.fileMode st
+ if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
+ || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
+ then do
+ putStrLn $ "*** WARNING: " ++ name ++
+ " is writable by someone else, IGNORING!"
+ return False
+ else return True
+#endif
+
+incrementLineNo :: InputT GHCi ()
+incrementLineNo = do
+ st <- lift $ getGHCiState
+ let ln = 1+(line_number st)
+ lift $ setGHCiState st{line_number=ln}
+
+fileLoop :: Handle -> InputT GHCi (Maybe String)
+fileLoop hdl = do
+ l <- liftIO $ tryIO $ hGetLine hdl
+ case l of
+ Left e | isEOFError e -> return Nothing
+ | -- as we share stdin with the program, the program
+ -- might have already closed it, so we might get a
+ -- handle-closed exception. We therefore catch that
+ -- too.
+ isIllegalOperation e -> return Nothing
+ | InvalidArgument <- etype -> return Nothing
+ | otherwise -> liftIO $ ioError e
+ where etype = ioeGetErrorType e
+ -- treat InvalidArgument in the same way as EOF:
+ -- this can happen if the user closed stdin, or
+ -- perhaps did getContents which closes stdin at
+ -- EOF.
+ Right l' -> do
+ incrementLineNo
+ return (Just l')
+
+mkPrompt :: GHCi String
+mkPrompt = do
+ st <- getGHCiState
+ imports <- GHC.getContext
+ resumes <- GHC.getResumeContext
+
+ context_bit <-
+ case resumes of
+ [] -> return empty
+ r:_ -> do
+ let ix = GHC.resumeHistoryIx r
+ if ix == 0
+ then return (brackets (ppr (GHC.resumeSpan r)) <> space)
+ else do
+ let hist = GHC.resumeHistory r !! (ix-1)
+ pan <- GHC.getHistorySpan hist
+ return (brackets (ppr (negate ix) <> char ':'
+ <+> ppr pan) <> space)
+ let
+ dots | _:rs <- resumes, not (null rs) = text "... "
+ | otherwise = empty
+
+ rev_imports = reverse imports -- rightmost are the most recent
+ modules_bit =
+ hsep [ char '*' <> ppr m | IIModule m <- rev_imports ] <+>
+ hsep (map ppr [ myIdeclName d | IIDecl d <- rev_imports ])
+
+ -- use the 'as' name if there is one
+ myIdeclName d | Just m <- ideclAs d = m
+ | otherwise = unLoc (ideclName d)
+
+ deflt_prompt = dots <> context_bit <> modules_bit
+
+ f ('%':'l':xs) = ppr (1 + line_number st) <> f xs
+ f ('%':'s':xs) = deflt_prompt <> f xs
+ f ('%':'%':xs) = char '%' <> f xs
+ f (x:xs) = char x <> f xs
+ f [] = empty
+
+ dflags <- getDynFlags
+ return (showSDoc dflags (f (prompt st)))
+
+
+queryQueue :: GHCi (Maybe String)
+queryQueue = do
+ st <- getGHCiState
+ case cmdqueue st of
+ [] -> return Nothing
+ c:cs -> do setGHCiState st{ cmdqueue = cs }
+ return (Just c)
+
+-- Reconfigurable pretty-printing Ticket #5461
+installInteractivePrint :: Maybe String -> Bool -> GHCi ()
+installInteractivePrint Nothing _ = return ()
+installInteractivePrint (Just ipFun) exprmode = do
+ ok <- trySuccess $ do
+ (name:_) <- GHC.parseName ipFun
+ modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
+ in he{hsc_IC = new_ic})
+ return Succeeded
+
+ when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))
+
+-- | The main read-eval-print loop
+runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
+runCommands = runCommands' handler Nothing
+
+runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
+ -> Maybe (GHCi ()) -- ^ Source error handler
+ -> InputT GHCi (Maybe String) -> InputT GHCi ()
+runCommands' eh sourceErrorHandler gCmd = do
+ b <- ghandle (\e -> case fromException e of
+ Just UserInterrupt -> return $ Just False
+ _ -> case fromException e of
+ Just ghce ->
+ do liftIO (print (ghce :: GhcException))
+ return Nothing
+ _other ->
+ liftIO (Exception.throwIO e))
+ (runOneCommand eh gCmd)
+ case b of
+ Nothing -> return ()
+ Just success -> do
+ when (not success) $ maybe (return ()) lift sourceErrorHandler
+ runCommands' eh sourceErrorHandler gCmd
+
+-- | Evaluate a single line of user input (either :<command> or Haskell code)
+runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
+ -> InputT GHCi (Maybe Bool)
+runOneCommand eh gCmd = do
+ -- run a previously queued command if there is one, otherwise get new
+ -- input from user
+ mb_cmd0 <- noSpace (lift queryQueue)
+ mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0
+ case mb_cmd1 of
+ Nothing -> return Nothing
+ Just c -> ghciHandle (\e -> lift $ eh e >>= return . Just) $
+ handleSourceError printErrorAndKeepGoing
+ (doCommand c)
+ -- source error's are handled by runStmt
+ -- is the handler necessary here?
+ where
+ printErrorAndKeepGoing err = do
+ GHC.printException err
+ return $ Just True
+
+ noSpace q = q >>= maybe (return Nothing)
+ (\c -> case removeSpaces c of
+ "" -> noSpace q
+ ":{" -> multiLineCmd q
+ _ -> return (Just c) )
+ multiLineCmd q = do
+ st <- lift getGHCiState
+ let p = prompt st
+ lift $ setGHCiState st{ prompt = prompt2 st }
+ mb_cmd <- collectCommand q "" `GHC.gfinally` lift (getGHCiState >>= \st' -> setGHCiState st' { prompt = p })
+ return mb_cmd
+ -- we can't use removeSpaces for the sublines here, so
+ -- multiline commands are somewhat more brittle against
+ -- fileformat errors (such as \r in dos input on unix),
+ -- we get rid of any extra spaces for the ":}" test;
+ -- we also avoid silent failure if ":}" is not found;
+ -- and since there is no (?) valid occurrence of \r (as
+ -- opposed to its String representation, "\r") inside a
+ -- ghci command, we replace any such with ' ' (argh:-(
+ collectCommand q c = q >>=
+ maybe (liftIO (ioError collectError))
+ (\l->if removeSpaces l == ":}"
+ then return (Just c)
+ else collectCommand q (c ++ "\n" ++ map normSpace l))
+ where normSpace '\r' = ' '
+ normSpace x = x
+ -- SDM (2007-11-07): is userError the one to use here?
+ collectError = userError "unterminated multiline command :{ .. :}"
+
+ -- | Handle a line of input
+ doCommand :: String -> InputT GHCi (Maybe Bool)
+
+ -- command
+ doCommand stmt | (':' : cmd) <- removeSpaces stmt = do
+ result <- specialCommand cmd
+ case result of
+ True -> return Nothing
+ _ -> return $ Just True
+
+ -- haskell
+ doCommand stmt = do
+ -- if 'stmt' was entered via ':{' it will contain '\n's
+ let stmt_nl_cnt = length [ () | '\n' <- stmt ]
+ ml <- lift $ isOptionSet Multiline
+ if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input
+ then do
+ fst_line_num <- lift (line_number <$> getGHCiState)
+ mb_stmt <- checkInputForLayout stmt gCmd
+ case mb_stmt of
+ Nothing -> return $ Just True
+ Just ml_stmt -> do
+ -- temporarily compensate line-number for multi-line input
+ result <- timeIt $ lift $ runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion
+ return $ Just result
+ else do -- single line input and :{-multiline input
+ last_line_num <- lift (line_number <$> getGHCiState)
+ -- reconstruct first line num from last line num and stmt
+ let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)
+ | otherwise = last_line_num -- single line input
+ stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]
+ stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines
+ -- temporarily compensate line-number for multi-line input
+ result <- timeIt $ lift $ runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion
+ return $ Just result
+
+ -- runStmt wrapper for temporarily overridden line-number
+ runStmtWithLineNum :: Int -> String -> SingleStep -> GHCi Bool
+ runStmtWithLineNum lnum stmt step = do
+ st0 <- getGHCiState
+ setGHCiState st0 { line_number = lnum }
+ result <- runStmt stmt step
+ -- restore original line_number
+ getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }
+ return result
+
+ -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'
+ dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s
+ , all isSpace l0 = dropLeadingWhiteLines r
+ | otherwise = s
+
+
+-- #4316
+-- lex the input. If there is an unclosed layout context, request input
+checkInputForLayout :: String -> InputT GHCi (Maybe String)
+ -> InputT GHCi (Maybe String)
+checkInputForLayout stmt getStmt = do
+ dflags' <- lift $ getDynFlags
+ let dflags = xopt_set dflags' Opt_AlternativeLayoutRule
+ st0 <- lift $ getGHCiState
+ let buf' = stringToStringBuffer stmt
+ loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1
+ pstate = Lexer.mkPState dflags buf' loc
+ case Lexer.unP goToEnd pstate of
+ (Lexer.POk _ False) -> return $ Just stmt
+ _other -> do
+ st1 <- lift getGHCiState
+ let p = prompt st1
+ lift $ setGHCiState st1{ prompt = prompt2 st1 }
+ mb_stmt <- ghciHandle (\ex -> case fromException ex of
+ Just UserInterrupt -> return Nothing
+ _ -> case fromException ex of
+ Just ghce ->
+ do liftIO (print (ghce :: GhcException))
+ return Nothing
+ _other -> liftIO (Exception.throwIO ex))
+ getStmt
+ lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p }
+ -- the recursive call does not recycle parser state
+ -- as we use a new string buffer
+ case mb_stmt of
+ Nothing -> return Nothing
+ Just str -> if str == ""
+ then return $ Just stmt
+ else do
+ checkInputForLayout (stmt++"\n"++str) getStmt
+ where goToEnd = do
+ eof <- Lexer.nextIsEOF
+ if eof
+ then Lexer.activeContext
+#if __GLASGOW_HASKELL__ < 709
+ else Lexer.lexer return >> goToEnd
+#else
+-- In 7.10 GHC API a bool "queueComments" was added.
+-- @see https://downloads.haskell.org/~ghc/latest/docs/html/libraries/ghc-7.10.1/src/Lexer.html#lexer
+ else Lexer.lexer True return >> goToEnd
+#endif
+
+enqueueCommands :: [String] -> GHCi ()
+enqueueCommands cmds = do
+ st <- getGHCiState
+ setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
+
+-- | If we one of these strings prefixes a command, then we treat it as a decl
+-- rather than a stmt.
+declPrefixes :: [String]
+declPrefixes = ["class ","data ","newtype ","type ","instance ", "deriving ",
+ "foreign ", "default ", "default("]
+
+-- | Entry point to execute some haskell code from user
+runStmt :: String -> SingleStep -> GHCi Bool
+runStmt stmt step
+ -- empty
+ | null (filter (not.isSpace) stmt)
+ = return False
+
+ -- import
+ | "import " `isPrefixOf` stmt
+ = do addImportToContext stmt; return False
+
+ -- data, class, newtype...
+ | any (flip isPrefixOf stmt) declPrefixes
+ = do _ <- liftIO $ tryIO $ hFlushAll stdin
+ result <- GhciMonad.runDecls stmt
+ afterRunStmt (const True) (GHC.RunOk result)
+
+ | otherwise
+ = do -- In the new IO library, read handles buffer data even if the Handle
+ -- is set to NoBuffering. This causes problems for GHCi where there
+ -- are really two stdin Handles. So we flush any bufferred data in
+ -- GHCi's stdin Handle here (only relevant if stdin is attached to
+ -- a file, otherwise the read buffer can't be flushed).
+ _ <- liftIO $ tryIO $ hFlushAll stdin
+ m_result <- GhciMonad.runStmt stmt step
+ case m_result of
+ Nothing -> return False
+ Just result -> afterRunStmt (const True) result
+
+-- | Clean up the GHCi environment after a statement has run
+afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
+afterRunStmt _ (GHC.RunException e) = liftIO $ Exception.throwIO e
+afterRunStmt step_here run_result = do
+ resumes <- GHC.getResumeContext
+ case run_result of
+ GHC.RunOk names -> do
+ show_types <- isOptionSet ShowType
+ when show_types $ printTypeOfNames names
+ GHC.RunBreak _ names mb_info
+ | isNothing mb_info ||
+ step_here (GHC.resumeSpan $ head resumes) -> do
+ mb_id_loc <- toBreakIdAndLocation mb_info
+ let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
+ if (null bCmd)
+ then printStoppedAtBreakInfo (head resumes) names
+ else enqueueCommands [bCmd]
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ enqueueCommands [stop st]
+ return ()
+ | otherwise -> resume step_here GHC.SingleStep >>=
+ afterRunStmt step_here >> return ()
+ _ -> return ()
+
+ flushInterpBuffers
+ liftIO installSignalHandlers
+ b <- isOptionSet RevertCAFs
+ when b revertCAFs
+
+ return (case run_result of GHC.RunOk _ -> True; _ -> False)
+
+toBreakIdAndLocation ::
+ Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
+toBreakIdAndLocation Nothing = return Nothing
+toBreakIdAndLocation (Just inf) = do
+ let md = GHC.breakInfo_module inf
+ nm = GHC.breakInfo_number inf
+ st <- getGHCiState
+ return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
+ breakModule loc == md,
+ breakTick loc == nm ]
+
+printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
+printStoppedAtBreakInfo res names = do
+ printForUser $ ptext (sLit "Stopped at") <+>
+ ppr (GHC.resumeSpan res)
+ -- printTypeOfNames session names
+ let namesSorted = sortBy compareNames names
+ tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
+ docs <- mapM pprTypeAndContents [i | AnId i <- tythings]
+ printForUserPartWay $ vcat docs
+
+printTypeOfNames :: [Name] -> GHCi ()
+printTypeOfNames names
+ = mapM_ (printTypeOfName ) $ sortBy compareNames names
+
+compareNames :: Name -> Name -> Ordering
+n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
+ where compareWith n = (getOccString n, getSrcSpan n)
+
+printTypeOfName :: Name -> GHCi ()
+printTypeOfName n
+ = do maybe_tything <- GHC.lookupName n
+ case maybe_tything of
+ Nothing -> return ()
+ Just thing -> printTyThing thing
+
+
+data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
+
+-- | Entry point for execution a ':<command>' input from user
+specialCommand :: String -> InputT GHCi Bool
+specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
+specialCommand str = do
+ let (cmd,rest) = break isSpace str
+ maybe_cmd <- lift $ lookupCommand cmd
+ htxt <- lift $ short_help `fmap` getGHCiState
+ case maybe_cmd of
+ GotCommand (_,f,_) -> f (dropWhile isSpace rest)
+ BadCommand ->
+ do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
+ ++ htxt)
+ return False
+ NoLastCommand ->
+ do liftIO $ hPutStr stdout ("there is no last command to perform\n"
+ ++ htxt)
+ return False
+
+shellEscape :: String -> GHCi Bool
+shellEscape str = liftIO (system str >> return False)
+
+lookupCommand :: String -> GHCi (MaybeCommand)
+lookupCommand "" = do
+ st <- getGHCiState
+ case last_command st of
+ Just c -> return $ GotCommand c
+ Nothing -> return NoLastCommand
+lookupCommand str = do
+ mc <- lookupCommand' str
+ st <- getGHCiState
+ setGHCiState st{ last_command = mc }
+ return $ case mc of
+ Just c -> GotCommand c
+ Nothing -> BadCommand
+
+lookupCommand' :: String -> GHCi (Maybe Command)
+lookupCommand' ":" = return Nothing
+lookupCommand' str' = do
+ macros <- liftIO $ readIORef macros_ref
+ ghci_cmds <- ghci_commands `fmap` getGHCiState
+ let (str, xcmds) = case str' of
+ ':' : rest -> (rest, []) -- "::" selects a builtin command
+ _ -> (str', macros) -- otherwise include macros in lookup
+
+ lookupExact s = find $ (s ==) . cmdName
+ lookupPrefix s = find $ (s `isPrefixOf`) . cmdName
+
+ builtinPfxMatch = lookupPrefix str ghci_cmds
+
+ -- first, look for exact match (while preferring macros); then, look
+ -- for first prefix match (preferring builtins), *unless* a macro
+ -- overrides the builtin; see #8305 for motivation
+ return $ lookupExact str xcmds <|>
+ lookupExact str ghci_cmds <|>
+ (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>
+ builtinPfxMatch <|>
+ lookupPrefix str xcmds
+
+getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
+getCurrentBreakSpan = do
+ resumes <- GHC.getResumeContext
+ case resumes of
+ [] -> return Nothing
+ (r:_) -> do
+ let ix = GHC.resumeHistoryIx r
+ if ix == 0
+ then return (Just (GHC.resumeSpan r))
+ else do
+ let hist = GHC.resumeHistory r !! (ix-1)
+ pan <- GHC.getHistorySpan hist
+ return (Just pan)
+
+getCurrentBreakModule :: GHCi (Maybe Module)
+getCurrentBreakModule = do
+ resumes <- GHC.getResumeContext
+ case resumes of
+ [] -> return Nothing
+ (r:_) -> do
+ let ix = GHC.resumeHistoryIx r
+ if ix == 0
+ then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
+ else do
+ let hist = GHC.resumeHistory r !! (ix-1)
+ return $ Just $ GHC.getHistoryModule hist
+
+-----------------------------------------------------------------------------
+--
+-- Commands
+--
+-----------------------------------------------------------------------------
+
+noArgs :: GHCi () -> String -> GHCi ()
+noArgs m "" = m
+noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"
+
+withSandboxOnly :: String -> GHCi () -> GHCi ()
+withSandboxOnly cmd this = do
+ dflags <- getDynFlags
+ if not (gopt Opt_GhciSandbox dflags)
+ then printForUser (text cmd <+>
+ ptext (sLit "is not supported with -fno-ghci-sandbox"))
+ else this
+
+-----------------------------------------------------------------------------
+-- :help
+
+help :: String -> GHCi ()
+help _ = do
+ txt <- long_help `fmap` getGHCiState
+ liftIO $ putStr txt
+
+-----------------------------------------------------------------------------
+-- :intro
+
+-- | Make an introduction.
+intro :: String -> GHCi ()
+intro _ =
+ liftIO $
+ putStr (unlines ["Here is a list of some of the common commands used when developing Haskell."
+ ,""
+ ,":load <filename>"
+ ," This loads a module or file and puts you in the context of that file."
+ ," For example, :load X.hs will type-check X.hs and load the interpreted"
+ ," code in to be ran from the prompt."
+ ,""
+ ,":browse <module name>"
+ ," List the declarations and types in the module. "
+ ," Example: :browse Data.List"
+ ,""
+ ,":help"
+ ," Displays a complete list of all the commands available."
+ ,""])
+
+-----------------------------------------------------------------------------
+-- :info
+
+info :: Bool -> String -> InputT GHCi ()
+info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
+info allInfo s = handleSourceError GHC.printException $ do
+ unqual <- GHC.getPrintUnqual
+ dflags <- getDynFlags
+ sdocs <- mapM (infoThing allInfo) (words s)
+ mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs
+
+infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc
+infoThing allInfo str = do
+ names <- GHC.parseName str
+ mb_stuffs <- mapM (GHC.getInfo allInfo) names
+ let filtered = filterOutChildren (\(t,_f,_ci,_fi) -> t) (catMaybes mb_stuffs)
+ return $ vcat (intersperse (text "") $ map pprInfo filtered)
+
+ -- Filter out names whose parent is also there Good
+ -- example is '[]', which is both a type and data
+ -- constructor in the same type
+filterOutChildren :: (a -> TyThing) -> [a] -> [a]
+filterOutChildren get_thing xs
+ = filterOut has_parent xs
+ where
+ all_names = mkNameSet (map (getName . get_thing) xs)
+ has_parent x = case tyThingParent_maybe (get_thing x) of
+ Just p -> getName p `elemNameSet` all_names
+ Nothing -> False
+
+pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc
+pprInfo (thing, fixity, cls_insts, fam_insts)
+ = pprTyThingInContextLoc thing
+ $$ show_fixity
+ $$ vcat (map GHC.pprInstance cls_insts)
+ $$ vcat (map GHC.pprFamInst fam_insts)
+ where
+ show_fixity
+ | fixity == GHC.defaultFixity = empty
+ | otherwise = ppr fixity <+> pprInfixName (GHC.getName thing)
+
+-----------------------------------------------------------------------------
+-- :main
+
+runMain :: String -> GHCi ()
+runMain s = case toArgs s of
+ Left err -> liftIO (hPutStrLn stderr err)
+ Right args ->
+ do dflags <- getDynFlags
+ case mainFunIs dflags of
+ Nothing -> doWithArgs args "main"
+ Just f -> doWithArgs args f
+
+-----------------------------------------------------------------------------
+-- :run
+
+runRun :: String -> GHCi ()
+runRun s = case toCmdArgs s of
+ Left err -> liftIO (hPutStrLn stderr err)
+ Right (cmd, args) -> doWithArgs args cmd
+
+doWithArgs :: [String] -> String -> GHCi ()
+doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
+ show args ++ " (" ++ cmd ++ ")"]
+
+-----------------------------------------------------------------------------
+-- :cd
+
+changeDirectory :: String -> InputT GHCi ()
+changeDirectory "" = do
+ -- :cd on its own changes to the user's home directory
+ either_dir <- liftIO $ tryIO getHomeDirectory
+ case either_dir of
+ Left _e -> return ()
+ Right dir -> changeDirectory dir
+changeDirectory dir = do
+ graph <- GHC.getModuleGraph
+ when (not (null graph)) $
+ liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
+ GHC.setTargets []
+ _ <- GHC.load LoadAllTargets
+ lift $ setContextAfterLoad False []
+ GHC.workingDirectoryChanged
+ dir' <- expandPath dir
+ liftIO $ setCurrentDirectory dir'
+
+trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
+trySuccess act =
+ handleSourceError (\e -> do GHC.printException e
+ return Failed) $ do
+ act
+
+-----------------------------------------------------------------------------
+-- :edit
+
+editFile :: String -> InputT GHCi ()
+editFile str =
+ do file <- if null str then lift chooseEditFile else expandPath str
+ st <- lift getGHCiState
+ let cmd = editor st
+ when (null cmd)
+ $ throwGhcException (CmdLineError "editor not set, use :set editor")
+ code <- liftIO $ system (cmd ++ ' ':file)
+ when (code == ExitSuccess)
+ $ reloadModule ""
+
+-- The user didn't specify a file so we pick one for them.
+-- Our strategy is to pick the first module that failed to load,
+-- or otherwise the first target.
+--
+-- XXX: Can we figure out what happened if the depndecy analysis fails
+-- (e.g., because the porgrammeer mistyped the name of a module)?
+-- XXX: Can we figure out the location of an error to pass to the editor?
+-- XXX: if we could figure out the list of errors that occured during the
+-- last load/reaload, then we could start the editor focused on the first
+-- of those.
+chooseEditFile :: GHCi String
+chooseEditFile =
+ do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
+
+ graph <- GHC.getModuleGraph
+ failed_graph <- filterM hasFailed graph
+ let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
+ pick xs = case xs of
+ x : _ -> GHC.ml_hs_file (GHC.ms_location x)
+ _ -> Nothing
+
+ case pick (order failed_graph) of
+ Just file -> return file
+ Nothing ->
+ do targets <- GHC.getTargets
+ case msum (map fromTarget targets) of
+ Just file -> return file
+ Nothing -> throwGhcException (CmdLineError "No files to edit.")
+
+ where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
+ fromTarget _ = Nothing -- when would we get a module target?
+
+
+-----------------------------------------------------------------------------
+-- :def
+
+defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
+defineMacro _ (':':_) =
+ liftIO $ putStrLn "macro name cannot start with a colon"
+defineMacro overwrite s = do
+ let (macro_name, definition) = break isSpace s
+ macros <- liftIO (readIORef macros_ref)
+ let defined = map cmdName macros
+ if (null macro_name)
+ then if null defined
+ then liftIO $ putStrLn "no macros defined"
+ else liftIO $ putStr ("the following macros are defined:\n" ++
+ unlines defined)
+ else do
+ if (not overwrite && macro_name `elem` defined)
+ then throwGhcException (CmdLineError
+ ("macro '" ++ macro_name ++ "' is already defined"))
+ else do
+
+ let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
+
+ -- give the expression a type signature, so we can be sure we're getting
+ -- something of the right type.
+ let new_expr = '(' : definition ++ ") :: String -> IO String"
+
+ -- compile the expression
+ handleSourceError (\e -> GHC.printException e) $
+ do
+ hv <- GHC.compileExpr new_expr
+ liftIO (writeIORef macros_ref -- later defined macros have precedence
+ ((macro_name, lift . runMacro hv, noCompletion) : filtered))
+
+runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
+runMacro fun s = do
+ str <- liftIO ((unsafeCoerce# fun :: String -> IO String) s)
+ -- make sure we force any exceptions in the result, while we are still
+ -- inside the exception handler for commands:
+ seqList str (return ())
+ enqueueCommands (lines str)
+ return False
+
+
+-----------------------------------------------------------------------------
+-- :undef
+
+undefineMacro :: String -> GHCi ()
+undefineMacro str = mapM_ undef (words str)
+ where undef macro_name = do
+ cmds <- liftIO (readIORef macros_ref)
+ if (macro_name `notElem` map cmdName cmds)
+ then throwGhcException (CmdLineError
+ ("macro '" ++ macro_name ++ "' is not defined"))
+ else do
+ liftIO (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
+
+
+-----------------------------------------------------------------------------
+-- :cmd
+
+cmdCmd :: String -> GHCi ()
+cmdCmd str = do
+ let expr = '(' : str ++ ") :: IO String"
+ handleSourceError (\e -> GHC.printException e) $
+ do
+ hv <- GHC.compileExpr expr
+ cmds <- liftIO $ (unsafeCoerce# hv :: IO String)
+ enqueueCommands (lines cmds)
+ return ()
+
+
+-----------------------------------------------------------------------------
+-- :check
+
+checkModule :: String -> InputT GHCi ()
+checkModule m = do
+ let modl = GHC.mkModuleName m
+ ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do
+ r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
+ dflags <- getDynFlags
+ liftIO $ putStrLn $ showSDoc dflags $
+ case GHC.moduleInfo r of
+ cm | Just scope <- GHC.modInfoTopLevelScope cm ->
+ let
+ (loc, glob) = ASSERT( all isExternalName scope )
+ partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
+ in
+ (text "global names: " <+> ppr glob) $$
+ (text "local names: " <+> ppr loc)
+ _ -> empty
+ return True
+ afterLoad (successIf ok) False
+
+
+-----------------------------------------------------------------------------
+-- :load, :add, :reload
+
+loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
+loadModule fs = timeIt (loadModule' fs)
+
+loadModule_ :: [FilePath] -> InputT GHCi ()
+loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
+
+loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
+loadModule' files = do
+ let (filenames, phases) = unzip files
+ exp_filenames <- mapM expandPath filenames
+ let files' = zip exp_filenames phases
+ targets <- mapM (uncurry GHC.guessTarget) files'
+
+ -- NOTE: we used to do the dependency anal first, so that if it
+ -- fails we didn't throw away the current set of modules. This would
+ -- require some re-working of the GHC interface, so we'll leave it
+ -- as a ToDo for now.
+
+ -- unload first
+ _ <- GHC.abandonAll
+ lift discardActiveBreakPoints
+ GHC.setTargets []
+ _ <- GHC.load LoadAllTargets
+
+ GHC.setTargets targets
+ flag <- doLoad False LoadAllTargets
+ doCollectInfo <- lift (isOptionSet CollectInfo)
+ case flag of
+ Succeeded | doCollectInfo -> do
+ loaded <- getModuleGraph >>= filterM GHC.isLoaded . map GHC.ms_mod_name
+ v <- lift (fmap mod_infos getGHCiState)
+ !newInfos <- collectInfo v loaded
+ lift (modifyGHCiState (\s -> s { mod_infos = newInfos }))
+ _ -> return ()
+ return flag
+
+-- :add
+addModule :: [FilePath] -> InputT GHCi ()
+addModule files = do
+ lift revertCAFs -- always revert CAFs on load/add.
+ files' <- mapM expandPath files
+ targets <- mapM (\m -> GHC.guessTarget m Nothing) files'
+ -- remove old targets with the same id; e.g. for :add *M
+ mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
+ mapM_ GHC.addTarget targets
+ _ <- doLoad False LoadAllTargets
+ return ()
+
+
+-- :reload
+reloadModule :: String -> InputT GHCi ()
+reloadModule m = do
+ _ <- doLoad True $
+ if null m then LoadAllTargets
+ else LoadUpTo (GHC.mkModuleName m)
+ return ()
+
+
+doLoad :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag
+doLoad retain_context howmuch = do
+ -- turn off breakpoints before we load: we can't turn them off later, because
+ -- the ModBreaks will have gone away.
+ lift discardActiveBreakPoints
+
+ -- Enable buffering stdout and stderr as we're compiling. Keeping these
+ -- handles unbuffered will just slow the compilation down, especially when
+ -- compiling in parallel.
+ gbracket (liftIO $ do hSetBuffering stdout LineBuffering
+ hSetBuffering stderr LineBuffering)
+ (\_ ->
+ liftIO $ do hSetBuffering stdout NoBuffering
+ hSetBuffering stderr NoBuffering) $ \_ -> do
+ ok <- trySuccess $ GHC.load howmuch
+ afterLoad ok retain_context
+ return ok
+
+
+afterLoad :: SuccessFlag
+ -> Bool -- keep the remembered_ctx, as far as possible (:reload)
+ -> InputT GHCi ()
+afterLoad ok retain_context = do
+ lift revertCAFs -- always revert CAFs on load.
+ lift discardTickArrays
+ loaded_mod_summaries <- getLoadedModules
+ let loaded_mods = map GHC.ms_mod loaded_mod_summaries
+ modulesLoadedMsg ok loaded_mods
+ lift $ setContextAfterLoad retain_context loaded_mod_summaries
+
+
+setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi ()
+setContextAfterLoad keep_ctxt [] = do
+ setContextKeepingPackageModules keep_ctxt []
+setContextAfterLoad keep_ctxt ms = do
+ -- load a target if one is available, otherwise load the topmost module.
+ targets <- GHC.getTargets
+ case [ m | Just m <- map (findTarget ms) targets ] of
+ [] ->
+ let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
+ load_this (last graph')
+ (m:_) ->
+ load_this m
+ where
+ findTarget mds t
+ = case filter (`matches` t) mds of
+ [] -> Nothing
+ (m:_) -> Just m
+
+ summary `matches` Target (TargetModule m) _ _
+ = GHC.ms_mod_name summary == m
+ summary `matches` Target (TargetFile f _) _ _
+ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
+ _ `matches` _
+ = False
+
+ load_this summary | m <- GHC.ms_mod summary = do
+ is_interp <- GHC.moduleIsInterpreted m
+ dflags <- getDynFlags
+ let star_ok = is_interp && not (safeLanguageOn dflags)
+ -- We import the module with a * iff
+ -- - it is interpreted, and
+ -- - -XSafe is off (it doesn't allow *-imports)
+ let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]
+ | otherwise = [mkIIDecl (GHC.moduleName m)]
+ setContextKeepingPackageModules keep_ctxt new_ctx
+
+
+-- | Keep any package modules (except Prelude) when changing the context.
+setContextKeepingPackageModules
+ :: Bool -- True <=> keep all of remembered_ctx
+ -- False <=> just keep package imports
+ -> [InteractiveImport] -- new context
+ -> GHCi ()
+
+setContextKeepingPackageModules keep_ctx trans_ctx = do
+
+ st <- getGHCiState
+ let rem_ctx = remembered_ctx st
+ new_rem_ctx <- if keep_ctx then return rem_ctx
+ else keepPackageImports rem_ctx
+ setGHCiState st{ remembered_ctx = new_rem_ctx,
+ transient_ctx = filterSubsumed new_rem_ctx trans_ctx }
+ setGHCContextFromGHCiState
+
+
+keepPackageImports :: [InteractiveImport] -> GHCi [InteractiveImport]
+keepPackageImports = filterM is_pkg_import
+ where
+ is_pkg_import :: InteractiveImport -> GHCi Bool
+ is_pkg_import (IIModule _) = return False
+ is_pkg_import (IIDecl d)
+ = do e <- gtry $ GHC.findModule mod_name (ideclPkgQual d)
+ case e :: Either SomeException Module of
+ Left _ -> return False
+ Right m -> return (not (isHomeModule m))
+ where
+ mod_name = unLoc (ideclName d)
+
+
+modulesLoadedMsg :: SuccessFlag -> [Module] -> InputT GHCi ()
+modulesLoadedMsg ok mods = do
+ dflags <- getDynFlags
+ unqual <- GHC.getPrintUnqual
+ let mod_commas
+ | null mods = text "none."
+ | otherwise = hsep (
+ punctuate comma (map ppr mods)) <> text "."
+ status = case ok of
+ Failed -> text "Failed"
+ Succeeded -> text "Ok"
+
+ msg = status <> text ", modules loaded:" <+> mod_commas
+
+ when (verbosity dflags > 0) $
+ liftIO $ putStrLn $ showSDocForUser dflags unqual msg
+
+-----------------------------------------------------------------------------
+-- :type
+
+typeOfExpr :: String -> InputT GHCi ()
+typeOfExpr str
+ = handleSourceError GHC.printException
+ $ do
+ ty <- GHC.exprType str
+ printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser ty)]
+
+-----------------------------------------------------------------------------
+-- :type-at
+
+typeAt :: String -> InputT GHCi ()
+typeAt str =
+ handleSourceError
+ GHC.printException
+ (case parseSpan str of
+ Left err -> liftIO (putStr err)
+ Right (fp,sl,sc,el,ec,sample) ->
+ do infos <- fmap mod_infos (lift getGHCiState)
+ result <- findType infos fp sample sl sc el ec
+ case result of
+ Left err -> liftIO (putStrLn err)
+ Right (info', ty) ->
+ printForUserModInfo (modinfoInfo info')
+ (sep [text sample,nest 2 (dcolon <+> ppr ty)]))
+
+-----------------------------------------------------------------------------
+-- :uses
+
+findAllUses :: String -> InputT GHCi ()
+findAllUses str =
+ handleSourceError GHC.printException $
+ case parseSpan str of
+ Left err -> liftIO (putStr err)
+ Right (fp,sl,sc,el,ec,sample) ->
+ do infos <- fmap mod_infos (lift getGHCiState)
+ result <- findNameUses infos fp sample sl sc el ec
+ case result of
+ Left err -> liftIO (putStrLn err)
+ Right uses ->
+ forM_ uses
+ (\sp ->
+ case sp of
+ RealSrcSpan rs ->
+ liftIO (putStrLn (showSpan rs))
+ UnhelpfulSpan fs ->
+ liftIO (putStrLn (unpackFS fs)))
+ where showSpan span' =
+ unpackFS (srcSpanFile span') ++
+ ":(" ++
+ show (srcSpanStartLine span') ++
+ "," ++
+ show (srcSpanStartCol span') ++
+ ")-(" ++
+ show (srcSpanEndLine span') ++
+ "," ++
+ show (srcSpanEndCol span') ++
+ ")"
+
+-----------------------------------------------------------------------------
+-- :all-types
+
+allTypes :: String -> InputT GHCi ()
+allTypes _ =
+ handleSourceError
+ GHC.printException
+ (do infos <- fmap mod_infos (lift getGHCiState)
+ forM_ (M.elems infos)
+ (\mi ->
+ forM_ (modinfoSpans mi) (printSpan mi)))
+ where printSpan mi (SpanInfo sl sc el ec mty _) =
+ do df <- GHC.getSessionDynFlags
+ case (ml_hs_file (GHC.ms_location (modinfoSummary mi))) of
+ Just fp ->
+ case mty of
+ Nothing -> return ()
+ Just ty ->
+ liftIO
+ (putStrLn
+ (concat [fp ++":"
+ -- GHC exposes a 1-based column number because reasons.
+ ,"(" ++ show sl ++ "," ++ show (1+sc) ++ ")-(" ++
+ show el ++ "," ++ show (1+ec) ++ "): "
+ ,flatten (showSDocForUser
+ df
+#if __GLASGOW_HASKELL__ < 709
+ (neverQualifyNames,neverQualifyModules)
+#else
+ neverQualify
+#endif
+ (pprTypeForUser ty))]))
+ Nothing -> return ()
+ where flatten = unwords . words
+
+-----------------------------------------------------------------------------
+-- :loc-at
+
+locationAt :: String -> InputT GHCi ()
+locationAt str =
+ handleSourceError GHC.printException $
+ case parseSpan str of
+ Left err -> liftIO (putStr err)
+ Right (fp,sl,sc,el,ec,sample) ->
+ do infos <- fmap mod_infos (lift getGHCiState)
+ result <- findLoc infos fp sample sl sc el ec
+ case result of
+ Left err -> liftIO (putStrLn err)
+ Right sp ->
+ case sp of
+ RealSrcSpan rs ->
+ liftIO (putStrLn (showSpan rs))
+ UnhelpfulSpan fs ->
+ liftIO (putStrLn (unpackFS fs))
+ where showSpan span' =
+ unpackFS (srcSpanFile span') ++ ":(" ++
+ show (srcSpanStartLine span') ++ "," ++
+ show (srcSpanStartCol span') ++
+ ")-(" ++
+ show (srcSpanEndLine span') ++ "," ++
+ show (srcSpanEndCol span') ++ ")"
+
+-----------------------------------------------------------------------------
+-- Helpers for locationAt/typeAt
+
+-- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>
+parseSpan :: String -> Either String (FilePath,Int,Int,Int,Int,String)
+parseSpan s =
+ case result of
+ Left err -> Left err
+ Right r -> Right r
+ where result =
+ case span (/= ' ') s of
+ (fp,s') ->
+ do (sl,s1) <- extractInt s'
+ (sc,s2) <- extractInt s1
+ (el,s3) <- extractInt s2
+ (ec,st) <- extractInt s3
+ -- GHC exposes a 1-based column number because reasons.
+ Right (fp,sl,sc-1,el,ec-1,st)
+ extractInt s' =
+ case span (/= ' ') (dropWhile1 (== ' ') s') of
+ (reads -> [(i,_)],s'') ->
+ Right (i,dropWhile1 (== ' ') s'')
+ _ ->
+ Left ("Expected integer in " ++ s')
+ where dropWhile1 _ [] = []
+ dropWhile1 p xs@(x:xs')
+ | p x = xs'
+ | otherwise = xs
+
+-----------------------------------------------------------------------------
+-- :kind
+
+kindOfType :: Bool -> String -> InputT GHCi ()
+kindOfType norm str
+ = handleSourceError GHC.printException
+ $ do
+ (ty, kind) <- GHC.typeKind norm str
+ printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind
+ , ppWhen norm $ equals <+> ppr ty ]
+
+
+-----------------------------------------------------------------------------
+-- :quit
+
+quit :: String -> InputT GHCi Bool
+quit _ = return True
+
+
+-----------------------------------------------------------------------------
+-- :script
+
+-- running a script file #1363
+
+scriptCmd :: String -> InputT GHCi ()
+scriptCmd ws = do
+ case words ws of
+ [s] -> runScript s
+ _ -> throwGhcException (CmdLineError "syntax: :script <filename>")
+
+runScript :: String -- ^ filename
+ -> InputT GHCi ()
+runScript filename = do
+ filename' <- expandPath filename
+ either_script <- liftIO $ tryIO (openFile filename' ReadMode)
+ case either_script of
+ Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "
+ ++(ioeGetErrorString _err))
+ Right script -> do
+ st <- lift $ getGHCiState
+ let prog = progname st
+ line = line_number st
+ lift $ setGHCiState st{progname=filename',line_number=0}
+ scriptLoop script
+ liftIO $ hClose script
+ new_st <- lift $ getGHCiState
+ lift $ setGHCiState new_st{progname=prog,line_number=line}
+ where scriptLoop script = do
+ res <- runOneCommand handler $ fileLoop script
+ case res of
+ Nothing -> return ()
+ Just s -> if s
+ then scriptLoop script
+ else return ()
+
+-----------------------------------------------------------------------------
+-- :issafe
+
+-- Displaying Safe Haskell properties of a module
+
+isSafeCmd :: String -> InputT GHCi ()
+isSafeCmd m =
+ case words m of
+ [s] | looksLikeModuleName s -> do
+ md <- lift $ lookupModule s
+ isSafeModule md
+ [] -> do md <- guessCurrentModule "issafe"
+ isSafeModule md
+ _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")
+
+isSafeModule :: Module -> InputT GHCi ()
+isSafeModule m = do
+ mb_mod_info <- GHC.getModuleInfo m
+ when (isNothing mb_mod_info)
+ (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)
+
+ dflags <- getDynFlags
+ let iface = GHC.modInfoIface $ fromJust mb_mod_info
+ when (isNothing iface)
+ (throwGhcException $ CmdLineError $ "can't load interface file for module: " ++
+ (GHC.moduleNameString $ GHC.moduleName m))
+
+ (msafe, pkgs) <- GHC.moduleTrustReqs m
+ let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface
+ pkg = if packageTrusted dflags m then "trusted" else "untrusted"
+ (good, bad) = tallyPkgs dflags pkgs
+
+ -- print info to user...
+ liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"
+ liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")
+ when (not $ null good)
+ (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++
+ (intercalate ", " $ map packageString good))
+ case msafe && null bad of
+ True -> liftIO $ putStrLn $ mname ++ " is trusted!"
+ False -> do
+ when (not $ null bad)
+ (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "
+ ++ (intercalate ", " $ map packageString bad))
+ liftIO $ putStrLn $ mname ++ " is NOT trusted!"
+
+ where
+ mname = GHC.moduleNameString $ GHC.moduleName m
+
+ packageTrusted dflags md
+ | thisPackage dflags == modulePackage md = True
+#if __GLASGOW_HASKELL__ < 709
+ | otherwise = trusted $ getPackageDetails (pkgState dflags) (modulePackage md)
+#else
+ | otherwise = trusted $ getPackageDetails dflags (modulePackage md)
+#endif
+
+ tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], [])
+ | otherwise = partition part deps
+ where
+#if __GLASGOW_HASKELL__ < 709
+ part pkg = trusted $ getPackageDetails state pkg
+ state = pkgState dflags
+#else
+ part pkg = trusted $ getPackageDetails dflags pkg
+#endif
+
+-----------------------------------------------------------------------------
+-- :browse
+
+-- Browsing a module's contents
+
+browseCmd :: Bool -> String -> InputT GHCi ()
+browseCmd bang m =
+ case words m of
+ ['*':s] | looksLikeModuleName s -> do
+ md <- lift $ wantInterpretedModule s
+ browseModule bang md False
+ [s] | looksLikeModuleName s -> do
+ md <- lift $ lookupModule s
+ browseModule bang md True
+ [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")
+ browseModule bang md True
+ _ -> throwGhcException (CmdLineError "syntax: :browse <module>")
+
+guessCurrentModule :: String -> InputT GHCi Module
+-- Guess which module the user wants to browse. Pick
+-- modules that are interpreted first. The most
+-- recently-added module occurs last, it seems.
+guessCurrentModule cmd
+ = do imports <- GHC.getContext
+ when (null imports) $ throwGhcException $
+ CmdLineError (':' : cmd ++ ": no current module")
+ case (head imports) of
+ IIModule m -> GHC.findModule m Nothing
+ IIDecl d -> GHC.findModule (unLoc (ideclName d)) (ideclPkgQual d)
+
+-- without bang, show items in context of their parents and omit children
+-- with bang, show class methods and data constructors separately, and
+-- indicate import modules, to aid qualifying unqualified names
+-- with sorted, sort items alphabetically
+browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
+browseModule bang modl exports_only = do
+ -- :browse reports qualifiers wrt current context
+ unqual <- GHC.getPrintUnqual
+
+ mb_mod_info <- GHC.getModuleInfo modl
+ case mb_mod_info of
+ Nothing -> throwGhcException (CmdLineError ("unknown module: " ++
+ GHC.moduleNameString (GHC.moduleName modl)))
+ Just mod_info -> do
+ dflags <- getDynFlags
+ let names
+ | exports_only = GHC.modInfoExports mod_info
+ | otherwise = GHC.modInfoTopLevelScope mod_info
+ `orElse` []
+
+ -- sort alphabetically name, but putting locally-defined
+ -- identifiers first. We would like to improve this; see #1799.
+ sorted_names = loc_sort local ++ occ_sort external
+ where
+ (local,external) = ASSERT( all isExternalName names )
+ partition ((==modl) . nameModule) names
+ occ_sort = sortBy (compare `on` nameOccName)
+ -- try to sort by src location. If the first name in our list
+ -- has a good source location, then they all should.
+ loc_sort ns
+ | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)
+ = sortBy (compare `on` nameSrcSpan) ns
+ | otherwise
+ = occ_sort ns
+
+ mb_things <- mapM GHC.lookupName sorted_names
+ let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
+
+ rdr_env <- GHC.getGRE
+
+ let things | bang = catMaybes mb_things
+ | otherwise = filtered_things
+ pretty | bang = pprTyThing
+ | otherwise = pprTyThingInContext
+
+ labels [] = text "-- not currently imported"
+ labels l = text $ intercalate "\n" $ map qualifier l
+
+ qualifier :: Maybe [ModuleName] -> String
+ qualifier = maybe "-- defined locally"
+ (("-- imported via "++) . intercalate ", "
+ . map GHC.moduleNameString)
+ importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
+
+ modNames :: [[Maybe [ModuleName]]]
+ modNames = map (importInfo . GHC.getName) things
+
+ -- annotate groups of imports with their import modules
+ -- the default ordering is somewhat arbitrary, so we group
+ -- by header and sort groups; the names themselves should
+ -- really come in order of source appearance.. (trac #1799)
+ annotate mts = concatMap (\(m,ts)->labels m:ts)
+ $ sortBy cmpQualifiers $ grp mts
+ where cmpQualifiers =
+ compare `on` (map (fmap (map moduleNameFS)) . fst)
+ grp [] = []
+ grp mts@((m,_):_) = (m,map snd g) : grp ng
+ where (g,ng) = partition ((==m).fst) mts
+
+ let prettyThings, prettyThings' :: [SDoc]
+ prettyThings = map pretty things
+ prettyThings' | bang = annotate $ zip modNames prettyThings
+ | otherwise = prettyThings
+ liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')
+ -- ToDo: modInfoInstances currently throws an exception for
+ -- package modules. When it works, we can do this:
+ -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
+
+
+-----------------------------------------------------------------------------
+-- :module
+
+-- Setting the module context. For details on context handling see
+-- "remembered_ctx" and "transient_ctx" in GhciMonad.
+
+moduleCmd :: String -> GHCi ()
+moduleCmd str
+ | all sensible strs = cmd
+ | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
+ where
+ (cmd, strs) =
+ case str of
+ '+':stuff -> rest addModulesToContext stuff
+ '-':stuff -> rest remModulesFromContext stuff
+ stuff -> rest setContext stuff
+
+ rest op stuff = (op as bs, stuffs)
+ where (as,bs) = partitionWith starred stuffs
+ stuffs = words stuff
+
+ sensible ('*':m) = looksLikeModuleName m
+ sensible m = looksLikeModuleName m
+
+ starred ('*':m) = Left (GHC.mkModuleName m)
+ starred m = Right (GHC.mkModuleName m)
+
+
+-- -----------------------------------------------------------------------------
+-- Four ways to manipulate the context:
+-- (a) :module +<stuff>: addModulesToContext
+-- (b) :module -<stuff>: remModulesFromContext
+-- (c) :module <stuff>: setContext
+-- (d) import <module>...: addImportToContext
+
+addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi ()
+addModulesToContext starred unstarred = restoreContextOnFailure $ do
+ addModulesToContext_ starred unstarred
+
+addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()
+addModulesToContext_ starred unstarred = do
+ mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)
+ setGHCContextFromGHCiState
+
+remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()
+remModulesFromContext starred unstarred = do
+ -- we do *not* call restoreContextOnFailure here. If the user
+ -- is trying to fix up a context that contains errors by removing
+ -- modules, we don't want GHC to silently put them back in again.
+ mapM_ rm (starred ++ unstarred)
+ setGHCContextFromGHCiState
+ where
+ rm :: ModuleName -> GHCi ()
+ rm str = do
+ m <- moduleName <$> lookupModuleName str
+ let filt = filter ((/=) m . iiModuleName)
+ modifyGHCiState $ \st ->
+ st { remembered_ctx = filt (remembered_ctx st)
+ , transient_ctx = filt (transient_ctx st) }
+
+setContext :: [ModuleName] -> [ModuleName] -> GHCi ()
+setContext starred unstarred = restoreContextOnFailure $ do
+ modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }
+ -- delete the transient context
+ addModulesToContext_ starred unstarred
+
+addImportToContext :: String -> GHCi ()
+addImportToContext str = restoreContextOnFailure $ do
+ idecl <- GHC.parseImportDecl str
+ addII (IIDecl idecl) -- #5836
+ setGHCContextFromGHCiState
+
+-- Util used by addImportToContext and addModulesToContext
+addII :: InteractiveImport -> GHCi ()
+addII iidecl = do
+ checkAdd iidecl
+ modifyGHCiState $ \st ->
+ st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)
+ , transient_ctx = filter (not . (iidecl `iiSubsumes`))
+ (transient_ctx st)
+ }
+
+-- Sometimes we can't tell whether an import is valid or not until
+-- we finally call 'GHC.setContext'. e.g.
+--
+-- import System.IO (foo)
+--
+-- will fail because System.IO does not export foo. In this case we
+-- don't want to store the import in the context permanently, so we
+-- catch the failure from 'setGHCContextFromGHCiState' and set the
+-- context back to what it was.
+--
+-- See #6007
+--
+restoreContextOnFailure :: GHCi a -> GHCi a
+restoreContextOnFailure do_this = do
+ st <- getGHCiState
+ let rc = remembered_ctx st; tc = transient_ctx st
+ do_this `gonException` (modifyGHCiState $ \st' ->
+ st' { remembered_ctx = rc, transient_ctx = tc })
+
+-- -----------------------------------------------------------------------------
+-- Validate a module that we want to add to the context
+
+checkAdd :: InteractiveImport -> GHCi ()
+checkAdd ii = do
+ dflags <- getDynFlags
+ let safe = safeLanguageOn dflags
+ case ii of
+ IIModule modname
+ | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"
+ | otherwise -> wantInterpretedModuleName modname >> return ()
+
+ IIDecl d -> do
+ let modname = unLoc (ideclName d)
+ pkgqual = ideclPkgQual d
+ m <- GHC.lookupModule modname pkgqual
+ when safe $ do
+ t <- GHC.isModuleTrusted m
+ when (not t) $ throwGhcException $ ProgramError $ ""
+
+-- -----------------------------------------------------------------------------
+-- Update the GHC API's view of the context
+
+-- | Sets the GHC context from the GHCi state. The GHC context is
+-- always set this way, we never modify it incrementally.
+--
+-- We ignore any imports for which the ModuleName does not currently
+-- exist. This is so that the remembered_ctx can contain imports for
+-- modules that are not currently loaded, perhaps because we just did
+-- a :reload and encountered errors.
+--
+-- Prelude is added if not already present in the list. Therefore to
+-- override the implicit Prelude import you can say 'import Prelude ()'
+-- at the prompt, just as in Haskell source.
+--
+setGHCContextFromGHCiState :: GHCi ()
+setGHCContextFromGHCiState = do
+ st <- getGHCiState
+ -- re-use checkAdd to check whether the module is valid. If the
+ -- module does not exist, we do *not* want to print an error
+ -- here, we just want to silently keep the module in the context
+ -- until such time as the module reappears again. So we ignore
+ -- the actual exception thrown by checkAdd, using tryBool to
+ -- turn it into a Bool.
+ iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)
+ dflags <- GHC.getSessionDynFlags
+ GHC.setContext $
+ if xopt Opt_ImplicitPrelude dflags && not (any isPreludeImport iidecls)
+ then iidecls ++ [implicitPreludeImport]
+ else iidecls
+ -- XXX put prel at the end, so that guessCurrentModule doesn't pick it up.
+
+
+-- -----------------------------------------------------------------------------
+-- Utils on InteractiveImport
+
+mkIIModule :: ModuleName -> InteractiveImport
+mkIIModule = IIModule
+
+mkIIDecl :: ModuleName -> InteractiveImport
+mkIIDecl = IIDecl . simpleImportDecl
+
+iiModules :: [InteractiveImport] -> [ModuleName]
+iiModules is = [m | IIModule m <- is]
+
+iiModuleName :: InteractiveImport -> ModuleName
+iiModuleName (IIModule m) = m
+iiModuleName (IIDecl d) = unLoc (ideclName d)
+
+preludeModuleName :: ModuleName
+preludeModuleName = GHC.mkModuleName "Prelude"
+
+implicitPreludeImport :: InteractiveImport
+implicitPreludeImport = IIDecl (simpleImportDecl preludeModuleName)
+
+isPreludeImport :: InteractiveImport -> Bool
+isPreludeImport (IIModule {}) = True
+isPreludeImport (IIDecl d) = unLoc (ideclName d) == preludeModuleName
+
+addNotSubsumed :: InteractiveImport
+ -> [InteractiveImport] -> [InteractiveImport]
+addNotSubsumed i is
+ | any (`iiSubsumes` i) is = is
+ | otherwise = i : filter (not . (i `iiSubsumes`)) is
+
+-- | @filterSubsumed is js@ returns the elements of @js@ not subsumed
+-- by any of @is@.
+filterSubsumed :: [InteractiveImport] -> [InteractiveImport]
+ -> [InteractiveImport]
+filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js
+
+-- | Returns True if the left import subsumes the right one. Doesn't
+-- need to be 100% accurate, conservatively returning False is fine.
+-- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in
+-- plusProv will ensue (#5904))
+--
+-- Note that an IIModule does not necessarily subsume an IIDecl,
+-- because e.g. a module might export a name that is only available
+-- qualified within the module itself.
+--
+-- Note that 'import M' does not necessarily subsume 'import M(foo)',
+-- because M might not export foo and we want an error to be produced
+-- in that case.
+--
+iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool
+iiSubsumes (IIModule m1) (IIModule m2) = m1==m2
+iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude
+ = unLoc (ideclName d1) == unLoc (ideclName d2)
+ && ideclAs d1 == ideclAs d2
+ && (not (ideclQualified d1) || ideclQualified d2)
+ && (idhd1 `hidingSubsumes` idhd2)
+ where
+-- I'm not so sure about this fix here...
+#if __GLASGOW_HASKELL__ < 709
+ idhd2 = ideclHiding d2
+ idhd1 = ideclHiding d1
+#else
+ idhd2 = fmap (fmap unLoc) $ ideclHiding d2
+ idhd1 = fmap (fmap unLoc) $ ideclHiding d1
+#endif
+ _ `hidingSubsumes` Just (False,[]) = True
+ Just (False, xs) `hidingSubsumes` Just (False,ys) = all (`elem` xs) ys
+ h1 `hidingSubsumes` h2 = h1 == h2
+iiSubsumes _ _ = False
+
+
+----------------------------------------------------------------------------
+-- :set
+
+-- set options in the interpreter. Syntax is exactly the same as the
+-- ghc command line, except that certain options aren't available (-C,
+-- -E etc.)
+--
+-- This is pretty fragile: most options won't work as expected. ToDo:
+-- figure out which ones & disallow them.
+
+setCmd :: String -> GHCi ()
+setCmd "" = showOptions False
+setCmd "-a" = showOptions True
+setCmd str
+ = case getCmd str of
+ Right ("args", rest) ->
+ case toArgs rest of
+ Left err -> liftIO (hPutStrLn stderr err)
+ Right args -> setArgs args
+ Right ("prog", rest) ->
+ case toArgs rest of
+ Right [prog] -> setProg prog
+ _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")
+ Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
+ Right ("prompt2", rest) -> setPrompt2 $ dropWhile isSpace rest
+ Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
+ Right ("stop", rest) -> setStop $ dropWhile isSpace rest
+ _ -> case toArgs str of
+ Left err -> liftIO (hPutStrLn stderr err)
+ Right wds -> setOptions wds
+
+setiCmd :: String -> GHCi ()
+setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False
+setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True
+setiCmd str =
+ case toArgs str of
+ Left err -> liftIO (hPutStrLn stderr err)
+ Right wds -> newDynFlags True wds
+
+showOptions :: Bool -> GHCi ()
+showOptions show_all
+ = do st <- getGHCiState
+ dflags <- getDynFlags
+ let opts = options st
+ liftIO $ putStrLn (showSDoc dflags (
+ text "options currently set: " <>
+ if null opts
+ then text "none."
+ else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
+ ))
+ getDynFlags >>= liftIO . showDynFlags show_all
+
+
+showDynFlags :: Bool -> DynFlags -> IO ()
+showDynFlags show_all dflags = do
+ showLanguages' show_all dflags
+ putStrLn $ showSDoc dflags $
+ text "GHCi-specific dynamic flag settings:" $$
+ nest 2 (vcat (map (setting gopt) ghciFlags))
+ putStrLn $ showSDoc dflags $
+ text "other dynamic, non-language, flag settings:" $$
+ nest 2 (vcat (map (setting gopt) others))
+ putStrLn $ showSDoc dflags $
+ text "warning settings:" $$
+ nest 2 (vcat (map (setting wopt) DynFlags.fWarningFlags))
+ where
+#if __GLASGOW_HASKELL__ < 709
+ setting test (str, f, _)
+#else
+ setting test (FlagSpec str f _ _)
+#endif
+ | quiet = empty
+ | is_on = fstr str
+ | otherwise = fnostr str
+ where is_on = test f dflags
+ quiet = not show_all && test f default_dflags == is_on
+
+ default_dflags = defaultDynFlags (settings dflags)
+
+ fstr str = text "-f" <> text str
+ fnostr str = text "-fno-" <> text str
+
+#if __GLASGOW_HASKELL__ < 709
+ (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flgs)
+#else
+ (ghciFlags,others) = partition (\(FlagSpec _ f _ _) -> f `elem` flgs)
+#endif
+ DynFlags.fFlags
+ flgs = [ Opt_PrintExplicitForalls
+ , Opt_PrintExplicitKinds
+ , Opt_PrintBindResult
+ , Opt_BreakOnException
+ , Opt_BreakOnError
+ , Opt_PrintEvldWithShow
+ ]
+
+setArgs, setOptions :: [String] -> GHCi ()
+setProg, setEditor, setStop :: String -> GHCi ()
+
+setArgs args = do
+ st <- getGHCiState
+ setGHCiState st{ GhciMonad.args = args }
+
+setProg prog = do
+ st <- getGHCiState
+ setGHCiState st{ progname = prog }
+
+setEditor cmd = do
+ st <- getGHCiState
+ setGHCiState st{ editor = cmd }
+
+setStop str@(c:_) | isDigit c
+ = do let (nm_str,rest) = break (not.isDigit) str
+ nm = read nm_str
+ st <- getGHCiState
+ let old_breaks = breaks st
+ if all ((/= nm) . fst) old_breaks
+ then printForUser (text "Breakpoint" <+> ppr nm <+>
+ text "does not exist")
+ else do
+ let new_breaks = map fn old_breaks
+ fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
+ | otherwise = (i,loc)
+ setGHCiState st{ breaks = new_breaks }
+setStop cmd = do
+ st <- getGHCiState
+ setGHCiState st{ stop = cmd }
+
+setPrompt :: String -> GHCi ()
+setPrompt = setPrompt_ f err
+ where
+ f v st = st { prompt = v }
+ err st = "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
+
+setPrompt2 :: String -> GHCi ()
+setPrompt2 = setPrompt_ f err
+ where
+ f v st = st { prompt2 = v }
+ err st = "syntax: :set prompt2 <prompt>, currently \"" ++ prompt2 st ++ "\""
+
+setPrompt_ :: (String -> GHCiState -> GHCiState) -> (GHCiState -> String) -> String -> GHCi ()
+setPrompt_ f err value = do
+ st <- getGHCiState
+ if null value
+ then liftIO $ hPutStrLn stderr $ err st
+ else case value of
+ '\"' : _ -> case reads value of
+ [(value', xs)] | all isSpace xs ->
+ setGHCiState $ f value' st
+ _ ->
+ liftIO $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
+ _ -> setGHCiState $ f value st
+
+setOptions wds =
+ do -- first, deal with the GHCi opts (+s, +t, etc.)
+ let (plus_opts, minus_opts) = partitionWith isPlus wds
+ mapM_ setOpt plus_opts
+ -- then, dynamic flags
+ newDynFlags False minus_opts
+
+newDynFlags :: Bool -> [String] -> GHCi ()
+newDynFlags interactive_only minus_opts = do
+ let lopts = map noLoc minus_opts
+
+ idflags0 <- GHC.getInteractiveDynFlags
+ (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts
+
+ liftIO $ handleFlagWarnings idflags1 warns
+ when (not $ null leftovers)
+ (throwGhcException . CmdLineError
+ $ "Some flags have not been recognized: "
+ ++ (concat . intersperse ", " $ map unLoc leftovers))
+
+ when (interactive_only &&
+ packageFlags idflags1 /= packageFlags idflags0) $ do
+ liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
+ GHC.setInteractiveDynFlags idflags1
+ installInteractivePrint (interactivePrint idflags1) False
+
+ dflags0 <- getDynFlags
+ when (not interactive_only) $ do
+ (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts
+ new_pkgs <- GHC.setProgramDynFlags dflags1
+
+ -- if the package flags changed, reset the context and link
+ -- the new packages.
+ dflags2 <- getDynFlags
+ when (packageFlags dflags2 /= packageFlags dflags0) $ do
+ when (verbosity dflags2 > 0) $
+ liftIO . putStrLn $
+ "package flags have changed, resetting and loading new packages..."
+ GHC.setTargets []
+ _ <- GHC.load LoadAllTargets
+ liftIO $ linkPackages dflags2 new_pkgs
+ -- package flags changed, we can't re-use any of the old context
+ setContextAfterLoad False []
+ -- and copy the package state to the interactive DynFlags
+ idflags <- GHC.getInteractiveDynFlags
+ GHC.setInteractiveDynFlags
+ idflags{ pkgState = pkgState dflags2
+ , pkgDatabase = pkgDatabase dflags2
+ , packageFlags = packageFlags dflags2 }
+
+ return ()
+
+
+unsetOptions :: String -> GHCi ()
+unsetOptions str
+ = -- first, deal with the GHCi opts (+s, +t, etc.)
+ let opts = words str
+ (minus_opts, rest1) = partition isMinus opts
+ (plus_opts, rest2) = partitionWith isPlus rest1
+ (other_opts, rest3) = partition (`elem` map fst defaulters) rest2
+
+ defaulters =
+ [ ("args" , setArgs default_args)
+ , ("prog" , setProg default_progname)
+ , ("prompt" , setPrompt default_prompt)
+ , ("prompt2", setPrompt2 default_prompt2)
+ , ("editor" , liftIO findEditor >>= setEditor)
+ , ("stop" , setStop default_stop)
+ ]
+
+ no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
+ no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))
+
+ in if (not (null rest3))
+ then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))
+ else do
+ mapM_ (fromJust.flip lookup defaulters) other_opts
+
+ mapM_ unsetOpt plus_opts
+
+ no_flags <- mapM no_flag minus_opts
+ newDynFlags False no_flags
+
+isMinus :: String -> Bool
+isMinus ('-':_) = True
+isMinus _ = False
+
+isPlus :: String -> Either String String
+isPlus ('+':opt) = Left opt
+isPlus other = Right other
+
+setOpt, unsetOpt :: String -> GHCi ()
+
+setOpt str
+ = case strToGHCiOpt str of
+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
+ Just o -> setOption o
+
+unsetOpt str
+ = case strToGHCiOpt str of
+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
+ Just o -> unsetOption o
+
+strToGHCiOpt :: String -> (Maybe GHCiOption)
+strToGHCiOpt "m" = Just Multiline
+strToGHCiOpt "s" = Just ShowTiming
+strToGHCiOpt "t" = Just ShowType
+strToGHCiOpt "r" = Just RevertCAFs
+strToGHCiOpt "c" = Just CollectInfo
+strToGHCiOpt _ = Nothing
+
+optToStr :: GHCiOption -> String
+optToStr Multiline = "m"
+optToStr ShowTiming = "s"
+optToStr ShowType = "t"
+optToStr RevertCAFs = "r"
+optToStr CollectInfo = "c"
+
+
+-- ---------------------------------------------------------------------------
+-- :show
+
+showCmd :: String -> GHCi ()
+showCmd "" = showOptions False
+showCmd "-a" = showOptions True
+showCmd str = do
+ st <- getGHCiState
+ case words str of
+ ["args"] -> liftIO $ putStrLn (show (GhciMonad.args st))
+ ["prog"] -> liftIO $ putStrLn (show (progname st))
+ ["prompt"] -> liftIO $ putStrLn (show (prompt st))
+ ["prompt2"] -> liftIO $ putStrLn (show (prompt2 st))
+ ["editor"] -> liftIO $ putStrLn (show (editor st))
+ ["stop"] -> liftIO $ putStrLn (show (stop st))
+ ["imports"] -> showImports
+ ["modules" ] -> showModules
+ ["bindings"] -> showBindings
+ ["linker"] ->
+ do dflags <- getDynFlags
+ liftIO $ showLinkerState dflags
+ ["breaks"] -> showBkptTable
+ ["context"] -> showContext
+ ["packages"] -> showPackages
+ ["paths"] -> showPaths
+ ["languages"] -> showLanguages -- backwards compat
+ ["language"] -> showLanguages
+ ["lang"] -> showLanguages -- useful abbreviation
+ _ -> throwGhcException (CmdLineError ("syntax: :show [ args | prog | prompt | prompt2 | editor | stop | modules\n" ++
+ " | bindings | breaks | context | packages | language ]"))
+
+showiCmd :: String -> GHCi ()
+showiCmd str = do
+ case words str of
+ ["languages"] -> showiLanguages -- backwards compat
+ ["language"] -> showiLanguages
+ ["lang"] -> showiLanguages -- useful abbreviation
+ _ -> throwGhcException (CmdLineError ("syntax: :showi language"))
+
+showImports :: GHCi ()
+showImports = do
+ st <- getGHCiState
+ dflags <- getDynFlags
+ let rem_ctx = reverse (remembered_ctx st)
+ trans_ctx = transient_ctx st
+
+ show_one (IIModule star_m)
+ = ":module +*" ++ moduleNameString star_m
+ show_one (IIDecl imp) = showPpr dflags imp
+
+ prel_imp
+ | any isPreludeImport (rem_ctx ++ trans_ctx) = []
+ | not (xopt Opt_ImplicitPrelude dflags) = []
+ | otherwise = ["import Prelude -- implicit"]
+
+ trans_comment s = s ++ " -- added automatically"
+ --
+ liftIO $ mapM_ putStrLn (prel_imp ++ map show_one rem_ctx
+ ++ map (trans_comment . show_one) trans_ctx)
+
+showModules :: GHCi ()
+showModules = do
+ loaded_mods <- getLoadedModules
+ -- we want *loaded* modules only, see #1734
+ let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)
+ mapM_ show_one loaded_mods
+
+getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
+getLoadedModules = do
+ graph <- GHC.getModuleGraph
+ filterM (GHC.isLoaded . GHC.ms_mod_name) graph
+
+showBindings :: GHCi ()
+showBindings = do
+ bindings <- GHC.getBindings
+ (insts, finsts) <- GHC.getInsts
+ docs <- mapM makeDoc (reverse bindings)
+ -- reverse so the new ones come last
+ let idocs = map GHC.pprInstanceHdr insts
+ fidocs = map GHC.pprFamInst finsts
+ mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)
+ where
+ makeDoc (AnId i) = pprTypeAndContents i
+ makeDoc tt = do
+ mb_stuff <- GHC.getInfo False (getName tt)
+ return $ maybe (text "") pprTT mb_stuff
+
+ pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc
+ pprTT (thing, fixity, _cls_insts, _fam_insts)
+ = pprTyThing thing
+ $$ show_fixity
+ where
+ show_fixity
+ | fixity == GHC.defaultFixity = empty
+ | otherwise = ppr fixity <+> ppr (GHC.getName thing)
+
+
+printTyThing :: TyThing -> GHCi ()
+printTyThing tyth = printForUser (pprTyThing tyth)
+
+showBkptTable :: GHCi ()
+showBkptTable = do
+ st <- getGHCiState
+ printForUser $ prettyLocations (breaks st)
+
+showContext :: GHCi ()
+showContext = do
+ resumes <- GHC.getResumeContext
+ printForUser $ vcat (map pp_resume (reverse resumes))
+ where
+ pp_resume res =
+ ptext (sLit "--> ") <> text (GHC.resumeStmt res)
+ $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan res))
+
+showPackages :: GHCi ()
+showPackages = do
+ dflags <- getDynFlags
+ let pkg_flags = packageFlags dflags
+ liftIO $ putStrLn $ showSDoc dflags $ vcat $
+ text ("active package flags:"++if null pkg_flags then " none" else "")
+ : map showFlag pkg_flags
+ where
+#if __GLASGOW_HASKELL__ < 709
+ showFlag (ExposePackage p) = text $ " -package " ++ p
+#else
+-- This flag now has more info about module renaming.
+-- @see
+-- https://downloads.haskell.org/~ghc/latest/docs/html/libraries/ghc-7.10.1/DynFlags.html#v:ExposePackage
+ showFlag (ExposePackage arg mr) = text $ " -package " ++ show arg ++ " " ++ show mr
+#endif
+ showFlag (HidePackage p) = text $ " -hide-package " ++ p
+ showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
+#if __GLASGOW_HASKELL__ < 709
+-- This flag just isn't in the 7.10 API
+ showFlag (ExposePackageId p) = text $ " -package-id " ++ p
+#endif
+ showFlag (TrustPackage p) = text $ " -trust " ++ p
+ showFlag (DistrustPackage p) = text $ " -distrust " ++ p
+
+showPaths :: GHCi ()
+showPaths = do
+ dflags <- getDynFlags
+ liftIO $ do
+ cwd' <- getCurrentDirectory
+ putStrLn $ showSDoc dflags $
+ text "current working directory: " $$
+ nest 2 (text cwd')
+ let ipaths = importPaths dflags
+ putStrLn $ showSDoc dflags $
+ text ("module import search paths:"++if null ipaths then " none" else "") $$
+ nest 2 (vcat (map text ipaths))
+
+showLanguages :: GHCi ()
+showLanguages = getDynFlags >>= liftIO . showLanguages' False
+
+showiLanguages :: GHCi ()
+showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False
+
+showLanguages' :: Bool -> DynFlags -> IO ()
+showLanguages' show_all dflags =
+ putStrLn $ showSDoc dflags $ vcat
+ [ text "base language is: " <>
+ case language dflags of
+ Nothing -> text "Haskell2010"
+ Just Haskell98 -> text "Haskell98"
+ Just Haskell2010 -> text "Haskell2010"
+ , (if show_all then text "all active language options:"
+ else text "with the following modifiers:") $$
+ nest 2 (vcat (map (setting xopt) DynFlags.xFlags))
+ ]
+ where
+#if __GLASGOW_HASKELL__ < 709
+ setting test (str, f, _)
+#else
+ setting test (FlagSpec str f _ _)
+#endif
+ | quiet = empty
+ | is_on = text "-X" <> text str
+ | otherwise = text "-XNo" <> text str
+ where is_on = test f dflags
+ quiet = not show_all && test f default_dflags == is_on
+
+ default_dflags =
+ defaultDynFlags (settings dflags) `lang_set`
+ case language dflags of
+ Nothing -> Just Haskell2010
+ other -> other
+
+-- -----------------------------------------------------------------------------
+-- Completion
+
+completeCmd :: String -> GHCi ()
+completeCmd argLine0 = case parseLine argLine0 of
+ Just ("repl", resultRange, left) -> do
+ (unusedLine,compls) <- ghciCompleteWord (reverse left,"")
+ let compls' = takeRange resultRange compls
+ liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]
+ forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do
+ liftIO $ print r
+ _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")
+ where
+ parseLine argLine
+ | null argLine = Nothing
+ | null rest1 = Nothing
+ | otherwise = (,,) dom <$> resRange <*> s
+ where
+ (dom, rest1) = breakSpace argLine
+ (rng, rest2) = breakSpace rest1
+ resRange | head rest1 == '"' = parseRange ""
+ | otherwise = parseRange rng
+ s | head rest1 == '"' = readMaybe rest1 :: Maybe String
+ | otherwise = readMaybe rest2
+ breakSpace = fmap (dropWhile isSpace) . break isSpace
+
+ takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub
+
+ -- syntax: [n-][m] with semantics "drop (n-1) . take m"
+ parseRange :: String -> Maybe (Maybe Int,Maybe Int)
+ parseRange s = case span isDigit s of
+ (_, "") ->
+ -- upper limit only
+ Just (Nothing, bndRead s)
+ (s1, '-' : s2)
+ | all isDigit s2 ->
+ Just (bndRead s1, bndRead s2)
+ _ ->
+ Nothing
+ where
+ bndRead x = if null x then Nothing else Just (read x)
+
+
+
+completeGhciCommand, completeMacro, completeIdentifier, completeModule,
+ completeSetModule, completeSeti, completeShowiOptions,
+ completeHomeModule, completeSetOptions, completeShowOptions,
+ completeHomeModuleOrFile, completeExpression
+ :: CompletionFunc GHCi
+
+ghciCompleteWord :: CompletionFunc GHCi
+ghciCompleteWord line@(left,_) = case firstWord of
+ ':':cmd | null rest -> completeGhciCommand line
+ | otherwise -> do
+ completion <- lookupCompletion cmd
+ completion line
+ "import" -> completeModule line
+ _ -> completeExpression line
+ where
+ (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
+ lookupCompletion ('!':_) = return completeFilename
+ lookupCompletion c = do
+ maybe_cmd <- lookupCommand' c
+ case maybe_cmd of
+ Just (_,_,f) -> return f
+ Nothing -> return completeFilename
+
+completeGhciCommand = wrapCompleter " " $ \w -> do
+ macros <- liftIO $ readIORef macros_ref
+ cmds <- ghci_commands `fmap` getGHCiState
+ let macro_names = map (':':) . map cmdName $ macros
+ let command_names = map (':':) . map cmdName $ cmds
+ let{ candidates = case w of
+ ':' : ':' : _ -> map (':':) command_names
+ _ -> nub $ macro_names ++ command_names }
+ return $ filter (w `isPrefixOf`) candidates
+
+completeMacro = wrapIdentCompleter $ \w -> do
+ cmds <- liftIO $ readIORef macros_ref
+ return (filter (w `isPrefixOf`) (map cmdName cmds))
+
+completeIdentifier = wrapIdentCompleter $ \w -> do
+ rdrs <- GHC.getRdrNamesInScope
+ dflags <- GHC.getSessionDynFlags
+ return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))
+
+completeModule = wrapIdentCompleter $ \w -> do
+ dflags <- GHC.getSessionDynFlags
+ let pkg_mods = allExposedModules dflags
+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
+ return $ filter (w `isPrefixOf`)
+ $ map (showPpr dflags) $ loaded_mods ++ pkg_mods
+
+completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
+ dflags <- GHC.getSessionDynFlags
+ modules <- case m of
+ Just '-' -> do
+ imports <- GHC.getContext
+ return $ map iiModuleName imports
+ _ -> do
+ let pkg_mods = allExposedModules dflags
+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
+ return $ loaded_mods ++ pkg_mods
+ return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules
+
+completeHomeModule = wrapIdentCompleter listHomeModules
+
+listHomeModules :: String -> GHCi [String]
+listHomeModules w = do
+ g <- GHC.getModuleGraph
+ let home_mods = map GHC.ms_mod_name g
+ dflags <- getDynFlags
+ return $ sort $ filter (w `isPrefixOf`)
+ $ map (showPpr dflags) home_mods
+
+completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
+ return (filter (w `isPrefixOf`) opts)
+ where opts = "args":"prog":"prompt":"prompt2":"editor":"stop":flagList
+ flagList = map head $ group $ sort allFlags
+
+completeSeti = wrapCompleter flagWordBreakChars $ \w -> do
+ return (filter (w `isPrefixOf`) flagList)
+ where flagList = map head $ group $ sort allFlags
+
+completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
+ return (filter (w `isPrefixOf`) opts)
+ where opts = ["args", "prog", "prompt", "prompt2", "editor", "stop",
+ "modules", "bindings", "linker", "breaks",
+ "context", "packages", "paths", "language", "imports"]
+
+completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do
+ return (filter (w `isPrefixOf`) ["language"])
+
+completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
+ $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
+ listFiles
+
+unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
+unionComplete f1 f2 line = do
+ cs1 <- f1 line
+ cs2 <- f2 line
+ return (cs1 ++ cs2)
+
+wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
+wrapCompleter breakChars fun = completeWord Nothing breakChars
+ $ fmap (map simpleCompletion) . fmap sort . fun
+
+wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
+wrapIdentCompleter = wrapCompleter word_break_chars
+
+wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi
+wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars
+ $ \rest -> fmap (map simpleCompletion) . fmap sort . fun (getModifier rest)
+ where
+ getModifier = find (`elem` modifChars)
+
+allExposedModules :: DynFlags -> [ModuleName]
+#if __GLASGOW_HASKELL__ < 709
+allExposedModules dflags
+ = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
+ where
+ pkg_db = pkgIdMap (pkgState dflags)
+#else
+allExposedModules = listVisibleModuleNames
+#endif
+
+completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
+ completeIdentifier
+
+
+-- -----------------------------------------------------------------------------
+-- commands for debugger
+
+sprintCmd, printCmd, forceCmd :: String -> GHCi ()
+sprintCmd = pprintCommand False False
+printCmd = pprintCommand True False
+forceCmd = pprintCommand False True
+
+pprintCommand :: Bool -> Bool -> String -> GHCi ()
+pprintCommand bind force str = do
+ pprintClosureCommand bind force str
+
+stepCmd :: String -> GHCi ()
+stepCmd arg = withSandboxOnly ":step" $ step arg
+ where
+ step [] = doContinue (const True) GHC.SingleStep
+ step expression = runStmt expression GHC.SingleStep >> return ()
+
+stepLocalCmd :: String -> GHCi ()
+stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
+ where
+ step expr
+ | not (null expr) = stepCmd expr
+ | otherwise = do
+ mb_span <- getCurrentBreakSpan
+ case mb_span of
+ Nothing -> stepCmd []
+ Just loc -> do
+ Just md <- getCurrentBreakModule
+ current_toplevel_decl <- enclosingTickSpan md loc
+ doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
+
+stepModuleCmd :: String -> GHCi ()
+stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
+ where
+ step expr
+ | not (null expr) = stepCmd expr
+ | otherwise = do
+ mb_span <- getCurrentBreakSpan
+ case mb_span of
+ Nothing -> stepCmd []
+ Just pan -> do
+ let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span
+ doContinue f GHC.SingleStep
+
+-- | Returns the span of the largest tick containing the srcspan given
+enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
+enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
+enclosingTickSpan md (RealSrcSpan src) = do
+ ticks <- getTickArray md
+ let line = srcSpanStartLine src
+ ASSERT(inRange (bounds ticks) line) do
+ let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
+ toRealSrcSpan (RealSrcSpan s) = s
+ enclosing_spans = [ pan | (_,pan) <- ticks ! line
+ , realSrcSpanEnd (toRealSrcSpan pan) >= realSrcSpanEnd src]
+ return . head . sortBy leftmost_largest $ enclosing_spans
+
+traceCmd :: String -> GHCi ()
+traceCmd arg
+ = withSandboxOnly ":trace" $ tr arg
+ where
+ tr [] = doContinue (const True) GHC.RunAndLogSteps
+ tr expression = runStmt expression GHC.RunAndLogSteps >> return ()
+
+continueCmd :: String -> GHCi ()
+continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion
+
+-- doContinue :: SingleStep -> GHCi ()
+doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
+doContinue pre step = do
+ runResult <- resume pre step
+ _ <- afterRunStmt pre runResult
+ return ()
+
+abandonCmd :: String -> GHCi ()
+abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do
+ b <- GHC.abandon -- the prompt will change to indicate the new context
+ when (not b) $ liftIO $ putStrLn "There is no computation running."
+
+deleteCmd :: String -> GHCi ()
+deleteCmd argLine = withSandboxOnly ":delete" $ do
+ deleteSwitch $ words argLine
+ where
+ deleteSwitch :: [String] -> GHCi ()
+ deleteSwitch [] =
+ liftIO $ putStrLn "The delete command requires at least one argument."
+ -- delete all break points
+ deleteSwitch ("*":_rest) = discardActiveBreakPoints
+ deleteSwitch idents = do
+ mapM_ deleteOneBreak idents
+ where
+ deleteOneBreak :: String -> GHCi ()
+ deleteOneBreak str
+ | all isDigit str = deleteBreak (read str)
+ | otherwise = return ()
+
+historyCmd :: String -> GHCi ()
+historyCmd arg
+ | null arg = history 20
+ | all isDigit arg = history (read arg)
+ | otherwise = liftIO $ putStrLn "Syntax: :history [num]"
+ where
+ history num = do
+ resumes <- GHC.getResumeContext
+ case resumes of
+ [] -> liftIO $ putStrLn "Not stopped at a breakpoint"
+ (r:_) -> do
+ let hist = GHC.resumeHistory r
+ (took,rest) = splitAt num hist
+ case hist of
+ [] -> liftIO $ putStrLn $
+ "Empty history. Perhaps you forgot to use :trace?"
+ _ -> do
+ pans <- mapM GHC.getHistorySpan took
+ let nums = map (printf "-%-3d:") [(1::Int)..]
+ names = map GHC.historyEnclosingDecls took
+ printForUser (vcat(zipWith3
+ (\x y z -> x <+> y <+> z)
+ (map text nums)
+ (map (bold . hcat . punctuate colon . map text) names)
+ (map (parens . ppr) pans)))
+ liftIO $ putStrLn $ if null rest then "<end of history>" else "..."
+
+bold :: SDoc -> SDoc
+bold c | do_bold = text start_bold <> c <> text end_bold
+ | otherwise = c
+
+backCmd :: String -> GHCi ()
+backCmd = noArgs $ withSandboxOnly ":back" $ do
+ (names, _, pan) <- GHC.back
+ printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan
+ printTypeOfNames names
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ enqueueCommands [stop st]
+
+forwardCmd :: String -> GHCi ()
+forwardCmd = noArgs $ withSandboxOnly ":forward" $ do
+ (names, ix, pan) <- GHC.forward
+ printForUser $ (if (ix == 0)
+ then ptext (sLit "Stopped at")
+ else ptext (sLit "Logged breakpoint at")) <+> ppr pan
+ printTypeOfNames names
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ enqueueCommands [stop st]
+
+-- handle the "break" command
+breakCmd :: String -> GHCi ()
+breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine
+
+breakSwitch :: [String] -> GHCi ()
+breakSwitch [] = do
+ liftIO $ putStrLn "The break command requires at least one argument."
+breakSwitch (arg1:rest)
+ | looksLikeModuleName arg1 && not (null rest) = do
+ md <- wantInterpretedModule arg1
+ breakByModule md rest
+ | all isDigit arg1 = do
+ imports <- GHC.getContext
+ case iiModules imports of
+ (mn : _) -> do
+ md <- lookupModuleName mn
+ breakByModuleLine md (read arg1) rest
+ [] -> do
+ liftIO $ putStrLn "No modules are loaded with debugging support."
+ | otherwise = do -- try parsing it as an identifier
+ wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
+ case loc of
+ RealSrcLoc l ->
+ ASSERT( isExternalName name )
+ findBreakAndSet (GHC.nameModule name) $
+ findBreakByCoord (Just (GHC.srcLocFile l))
+ (GHC.srcLocLine l,
+ GHC.srcLocCol l)
+ UnhelpfulLoc _ ->
+ noCanDo name $ text "can't find its location: " <> ppr loc
+ where
+ noCanDo n why = printForUser $
+ text "cannot set breakpoint on " <> ppr n <> text ": " <> why
+
+breakByModule :: Module -> [String] -> GHCi ()
+breakByModule md (arg1:rest)
+ | all isDigit arg1 = do -- looks like a line number
+ breakByModuleLine md (read arg1) rest
+breakByModule _ _
+ = breakSyntax
+
+breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
+breakByModuleLine md line args
+ | [] <- args = findBreakAndSet md $ findBreakByLine line
+ | [col] <- args, all isDigit col =
+ findBreakAndSet md $ findBreakByCoord Nothing (line, read col)
+ | otherwise = breakSyntax
+
+breakSyntax :: a
+breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
+
+findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
+findBreakAndSet md lookupTickTree = do
+ dflags <- getDynFlags
+ tickArray <- getTickArray md
+ (breakArray, _) <- getModBreak md
+ case lookupTickTree tickArray of
+ Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location."
+ Just (tick, pan) -> do
+ success <- liftIO $ setBreakFlag dflags True breakArray tick
+ if success
+ then do
+ (alreadySet, nm) <-
+ recordBreak $ BreakLocation
+ { breakModule = md
+ , breakLoc = pan
+ , breakTick = tick
+ , onBreakCmd = ""
+ }
+ printForUser $
+ text "Breakpoint " <> ppr nm <>
+ if alreadySet
+ then text " was already set at " <> ppr pan
+ else text " activated at " <> ppr pan
+ else do
+ printForUser $ text "Breakpoint could not be activated at"
+ <+> ppr pan
+
+-- When a line number is specified, the current policy for choosing
+-- the best breakpoint is this:
+-- - the leftmost complete subexpression on the specified line, or
+-- - the leftmost subexpression starting on the specified line, or
+-- - the rightmost subexpression enclosing the specified line
+--
+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
+findBreakByLine line arr
+ | not (inRange (bounds arr) line) = Nothing
+ | otherwise =
+ listToMaybe (sortBy (leftmost_largest `on` snd) comp) `mplus`
+ listToMaybe (sortBy (leftmost_smallest `on` snd) incomp) `mplus`
+ listToMaybe (sortBy (rightmost `on` snd) ticks)
+ where
+ ticks = arr ! line
+
+ starts_here = [ tick | tick@(_,pan) <- ticks,
+ GHC.srcSpanStartLine (toRealSpan pan) == line ]
+
+ (comp, incomp) = partition ends_here starts_here
+ where ends_here (_,pan) = GHC.srcSpanEndLine (toRealSpan pan) == line
+ toRealSpan (RealSrcSpan pan) = pan
+ toRealSpan (UnhelpfulSpan _) = panic "findBreakByLine UnhelpfulSpan"
+
+findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
+ -> Maybe (BreakIndex,SrcSpan)
+findBreakByCoord mb_file (line, col) arr
+ | not (inRange (bounds arr) line) = Nothing
+ | otherwise =
+ listToMaybe (sortBy (rightmost `on` snd) contains ++
+ sortBy (leftmost_smallest `on` snd) after_here)
+ where
+ ticks = arr ! line
+
+ -- the ticks that span this coordinate
+ contains = [ tick | tick@(_,pan) <- ticks, pan `spans` (line,col),
+ is_correct_file pan ]
+
+ is_correct_file pan
+ | Just f <- mb_file = GHC.srcSpanFile (toRealSpan pan) == f
+ | otherwise = True
+
+ after_here = [ tick | tick@(_,pan) <- ticks,
+ let pan' = toRealSpan pan,
+ GHC.srcSpanStartLine pan' == line,
+ GHC.srcSpanStartCol pan' >= col ]
+
+ toRealSpan (RealSrcSpan pan) = pan
+ toRealSpan (UnhelpfulSpan _) = panic "findBreakByCoord UnhelpfulSpan"
+
+-- For now, use ANSI bold on terminals that we know support it.
+-- Otherwise, we add a line of carets under the active expression instead.
+-- In particular, on Windows and when running the testsuite (which sets
+-- TERM to vt100 for other reasons) we get carets.
+-- We really ought to use a proper termcap/terminfo library.
+do_bold :: Bool
+do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
+ where mTerm = System.Environment.getEnv "TERM"
+ `catchIO` \_ -> return "TERM not set"
+
+start_bold :: String
+start_bold = "\ESC[1m"
+end_bold :: String
+end_bold = "\ESC[0m"
+
+
+-----------------------------------------------------------------------------
+-- :list
+
+listCmd :: String -> InputT GHCi ()
+listCmd c = listCmd' c
+
+listCmd' :: String -> InputT GHCi ()
+listCmd' "" = do
+ mb_span <- lift getCurrentBreakSpan
+ case mb_span of
+ Nothing ->
+ printForUser $ text "Not stopped at a breakpoint; nothing to list"
+ Just (RealSrcSpan pan) ->
+ listAround pan True
+ Just pan@(UnhelpfulSpan _) ->
+ do resumes <- GHC.getResumeContext
+ case resumes of
+ [] -> panic "No resumes"
+ (r:_) ->
+ do let traceIt = case GHC.resumeHistory r of
+ [] -> text "rerunning with :trace,"
+ _ -> empty
+ doWhat = traceIt <+> text ":back then :list"
+ printForUser (text "Unable to list source for" <+>
+ ppr pan
+ $$ text "Try" <+> doWhat)
+listCmd' str = list2 (words str)
+
+list2 :: [String] -> InputT GHCi ()
+list2 [arg] | all isDigit arg = do
+ imports <- GHC.getContext
+ case iiModules imports of
+ [] -> liftIO $ putStrLn "No module to list"
+ (mn : _) -> do
+ md <- lift $ lookupModuleName mn
+ listModuleLine md (read arg)
+list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
+ md <- wantInterpretedModule arg1
+ listModuleLine md (read arg2)
+list2 [arg] = do
+ wantNameFromInterpretedModule noCanDo arg $ \name -> do
+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
+ case loc of
+ RealSrcLoc l ->
+ do tickArray <- ASSERT( isExternalName name )
+ lift $ getTickArray (GHC.nameModule name)
+ let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))
+ (GHC.srcLocLine l, GHC.srcLocCol l)
+ tickArray
+ case mb_span of
+ Nothing -> listAround (realSrcLocSpan l) False
+ Just (_, UnhelpfulSpan _) -> panic "list2 UnhelpfulSpan"
+ Just (_, RealSrcSpan pan) -> listAround pan False
+ UnhelpfulLoc _ ->
+ noCanDo name $ text "can't find its location: " <>
+ ppr loc
+ where
+ noCanDo n why = printForUser $
+ text "cannot list source code for " <> ppr n <> text ": " <> why
+list2 _other =
+ liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
+
+listModuleLine :: Module -> Int -> InputT GHCi ()
+listModuleLine modl line = do
+ graph <- GHC.getModuleGraph
+ let this = filter ((== modl) . GHC.ms_mod) graph
+ case this of
+ [] -> panic "listModuleLine"
+ summ:_ -> do
+ let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
+ loc = mkRealSrcLoc (mkFastString (filename)) line 0
+ listAround (realSrcLocSpan loc) False
+
+-- | list a section of a source file around a particular SrcSpan.
+-- If the highlight flag is True, also highlight the span using
+-- start_bold\/end_bold.
+
+-- GHC files are UTF-8, so we can implement this by:
+-- 1) read the file in as a BS and syntax highlight it as before
+-- 2) convert the BS to String using utf-string, and write it out.
+-- It would be better if we could convert directly between UTF-8 and the
+-- console encoding, of course.
+listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()
+listAround pan do_highlight = do
+ contents <- liftIO $ BS.readFile (unpackFS file)
+ let ls = BS.split '\n' contents
+ ls' = take (line2 - line1 + 1 + pad_before + pad_after) $
+ drop (line1 - 1 - pad_before) $ ls
+ fst_line = max 1 (line1 - pad_before)
+ line_nos = [ fst_line .. ]
+
+ highlighted | do_highlight = zipWith highlight line_nos ls'
+ | otherwise = [\p -> BS.concat[p,l] | l <- ls']
+
+ bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
+ prefixed = zipWith ($) highlighted bs_line_nos
+ output = BS.intercalate (BS.pack "\n") prefixed
+
+ utf8Decoded <- liftIO $ BS.useAsCStringLen output
+ $ \(p,n) -> utf8DecodeString (castPtr p) n
+ liftIO $ putStrLn utf8Decoded
+ where
+ file = GHC.srcSpanFile pan
+ line1 = GHC.srcSpanStartLine pan
+ col1 = GHC.srcSpanStartCol pan - 1
+ line2 = GHC.srcSpanEndLine pan
+ col2 = GHC.srcSpanEndCol pan - 1
+
+ pad_before | line1 == 1 = 0
+ | otherwise = 1
+ pad_after = 1
+
+ highlight | do_bold = highlight_bold
+ | otherwise = highlight_carets
+
+ highlight_bold no line prefix
+ | no == line1 && no == line2
+ = let (a,r) = BS.splitAt col1 line
+ (b,c) = BS.splitAt (col2-col1) r
+ in
+ BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
+ | no == line1
+ = let (a,b) = BS.splitAt col1 line in
+ BS.concat [prefix, a, BS.pack start_bold, b]
+ | no == line2
+ = let (a,b) = BS.splitAt col2 line in
+ BS.concat [prefix, a, BS.pack end_bold, b]
+ | otherwise = BS.concat [prefix, line]
+
+ highlight_carets no line prefix
+ | no == line1 && no == line2
+ = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
+ BS.replicate (col2-col1) '^']
+ | no == line1
+ = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
+ prefix, line]
+ | no == line2
+ = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
+ BS.pack "^^"]
+ | otherwise = BS.concat [prefix, line]
+ where
+ indent = BS.pack (" " ++ replicate (length (show no)) ' ')
+ nl = BS.singleton '\n'
+
+
+-- --------------------------------------------------------------------------
+-- Tick arrays
+
+getTickArray :: Module -> GHCi TickArray
+getTickArray modl = do
+ st <- getGHCiState
+ let arrmap = tickarrays st
+ case lookupModuleEnv arrmap modl of
+ Just arr -> return arr
+ Nothing -> do
+ (_breakArray, ticks) <- getModBreak modl
+ let arr = mkTickArray (assocs ticks)
+ setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
+ return arr
+
+discardTickArrays :: GHCi ()
+discardTickArrays = do
+ st <- getGHCiState
+ setGHCiState st{tickarrays = emptyModuleEnv}
+
+mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
+mkTickArray ticks
+ = accumArray (flip (:)) [] (1, max_line)
+ [ (line, (nm,pan)) | (nm,pan) <- ticks,
+ let pan' = toRealSpan pan,
+ line <- srcSpanLines pan' ]
+ where
+ max_line = foldr max 0 (map (GHC.srcSpanEndLine . toRealSpan . snd) ticks)
+ srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]
+ toRealSpan (RealSrcSpan pan) = pan
+ toRealSpan (UnhelpfulSpan _) = panic "mkTickArray UnhelpfulSpan"
+
+-- don't reset the counter back to zero?
+discardActiveBreakPoints :: GHCi ()
+discardActiveBreakPoints = do
+ st <- getGHCiState
+ mapM_ (turnOffBreak.snd) (breaks st)
+ setGHCiState $ st { breaks = [] }
+
+deleteBreak :: Int -> GHCi ()
+deleteBreak identity = do
+ st <- getGHCiState
+ let oldLocations = breaks st
+ (this,rest) = partition (\loc -> fst loc == identity) oldLocations
+ if null this
+ then printForUser (text "Breakpoint" <+> ppr identity <+>
+ text "does not exist")
+ else do
+ mapM_ (turnOffBreak.snd) this
+ setGHCiState $ st { breaks = rest }
+
+turnOffBreak :: BreakLocation -> GHCi Bool
+turnOffBreak loc = do
+ dflags <- getDynFlags
+ (arr, _) <- getModBreak (breakModule loc)
+ liftIO $ setBreakFlag dflags False arr (breakTick loc)
+
+getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
+getModBreak m = do
+ Just mod_info <- GHC.getModuleInfo m
+ let modBreaks = GHC.modInfoModBreaks mod_info
+ let arr = GHC.modBreaks_flags modBreaks
+ let ticks = GHC.modBreaks_locs modBreaks
+ return (arr, ticks)
+
+setBreakFlag :: DynFlags -> Bool -> GHC.BreakArray -> Int -> IO Bool
+setBreakFlag dflags toggle arr i
+ | toggle = GHC.setBreakOn dflags arr i
+ | otherwise = GHC.setBreakOff dflags arr i
+
+
+-- ---------------------------------------------------------------------------
+-- User code exception handling
+
+-- This is the exception handler for exceptions generated by the
+-- user's code and exceptions coming from children sessions;
+-- it normally just prints out the exception. The
+-- handler must be recursive, in case showing the exception causes
+-- more exceptions to be raised.
+--
+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,
+-- raising another exception. We therefore don't put the recursive
+-- handler arond the flushing operation, so if stderr is closed
+-- GHCi will just die gracefully rather than going into an infinite loop.
+handler :: SomeException -> GHCi Bool
+
+handler exception = do
+ flushInterpBuffers
+ liftIO installSignalHandlers
+ ghciHandle handler (showException exception >> return False)
+
+showException :: SomeException -> GHCi ()
+showException se =
+ liftIO $ case fromException se of
+ -- omit the location for CmdLineError:
+ Just (CmdLineError s) -> putException s
+ -- ditto:
+ Just ph@(PhaseFailed {}) -> putException (showGhcException ph "")
+ Just other_ghc_ex -> putException (show other_ghc_ex)
+ Nothing ->
+ case fromException se of
+ Just UserInterrupt -> putException "Interrupted."
+ _ -> putException ("*** Exception: " ++ show se)
+ where
+ putException = hPutStrLn stderr
+
+
+-----------------------------------------------------------------------------
+-- recursive exception handlers
+
+-- Don't forget to unblock async exceptions in the handler, or if we're
+-- in an exception loop (eg. let a = error a in a) the ^C exception
+-- may never be delivered. Thanks to Marcin for pointing out the bug.
+
+ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a
+ghciHandle h m = gmask $ \restore -> do
+ dflags <- getDynFlags
+ gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)
+
+ghciTry :: GHCi a -> GHCi (Either SomeException a)
+ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
+
+tryBool :: GHCi a -> GHCi Bool
+tryBool m = do
+ r <- ghciTry m
+ case r of
+ Left _ -> return False
+ Right _ -> return True
+
+-- ----------------------------------------------------------------------------
+-- Utils
+
+lookupModule :: GHC.GhcMonad m => String -> m Module
+lookupModule mName = lookupModuleName (GHC.mkModuleName mName)
+
+lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module
+lookupModuleName mName = GHC.lookupModule mName Nothing
+
+isHomeModule :: Module -> Bool
+#if __GLASGOW_HASKELL__ < 709
+isHomeModule m = modulePackage m == mainPackageId
+#else
+isHomeModule m = modulePackage m == mainPackageKey
+#endif
+
+-- TODO: won't work if home dir is encoded.
+-- (changeDirectory may not work either in that case.)
+expandPath :: MonadIO m => String -> InputT m String
+expandPath = liftIO . expandPathIO
+
+expandPathIO :: String -> IO String
+expandPathIO p =
+ case dropWhile isSpace p of
+ ('~':d) -> do
+ tilde <- getHomeDirectory -- will fail if HOME not defined
+ return (tilde ++ '/':d)
+ other ->
+ return other
+
+wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
+wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)
+
+wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module
+wantInterpretedModuleName modname = do
+ modl <- lookupModuleName modname
+ let str = moduleNameString modname
+ dflags <- getDynFlags
+ when (modulePackage modl /= thisPackage dflags) $
+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
+ is_interpreted <- GHC.moduleIsInterpreted modl
+ when (not is_interpreted) $
+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
+ return modl
+
+wantNameFromInterpretedModule :: GHC.GhcMonad m
+ => (Name -> SDoc -> m ())
+ -> String
+ -> (Name -> m ())
+ -> m ()
+wantNameFromInterpretedModule noCanDo str and_then =
+ handleSourceError GHC.printException $ do
+ names <- GHC.parseName str
+ case names of
+ [] -> return ()
+ (n:_) -> do
+ let modl = ASSERT( isExternalName n ) GHC.nameModule n
+ if not (GHC.isExternalName n)
+ then noCanDo n $ ppr n <>
+ text " is not defined in an interpreted module"
+ else do
+ is_interpreted <- GHC.moduleIsInterpreted modl
+ if not is_interpreted
+ then noCanDo n $ text "module " <> ppr modl <>
+ text " is not interpreted"
+ else and_then n
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..0d1ebfb
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,889 @@
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+-----------------------------------------------------------------------------
+--
+-- GHC Driver program
+--
+-- (c) The University of Glasgow 2005
+--
+-----------------------------------------------------------------------------
+
+module Main (main) where
+
+-- The official GHC API
+import qualified GHC
+import GHC ( -- DynFlags(..), HscTarget(..),
+ -- GhcMode(..), GhcLink(..),
+ Ghc, GhcMonad(..),
+ LoadHowMuch(..) )
+import CmdLineParser
+
+-- ghci-ng
+import qualified GHC.Paths
+
+-- Implementations of the various modes (--show-iface, mkdependHS. etc.)
+import LoadIface ( showIface )
+import HscMain ( newHscEnv )
+import DriverPipeline ( oneShot, compileFile )
+import DriverMkDepend ( doMkDependHS )
+#ifdef GHCI
+import InteractiveUI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
+#endif
+
+
+-- Various other random stuff that we need
+import Config
+import Constants
+import HscTypes
+#if __GLASGOW_HASKELL__ < 709
+import Packages ( dumpPackages )
+#else
+import Packages ( pprPackages )
+#endif
+import DriverPhases
+import BasicTypes ( failed )
+import StaticFlags
+import DynFlags
+import ErrUtils
+import FastString
+import Outputable
+import SrcLoc
+import Util
+import Panic
+import MonadUtils ( liftIO )
+
+-- Imports for --abi-hash
+import LoadIface ( loadUserInterface )
+import Module ( mkModuleName )
+import Finder ( findImportedModule, cannotFindInterface )
+import TcRnMonad ( initIfaceCheck )
+import Binary ( openBinMem, put_, fingerprintBinMem )
+
+-- Standard Haskell libraries
+import System.IO
+import System.Environment
+import System.Exit
+import System.FilePath
+import Control.Monad
+import Data.Char
+import Data.List
+import Data.Maybe
+
+-----------------------------------------------------------------------------
+-- ToDo:
+
+-- time commands when run with -v
+-- user ways
+-- Win32 support: proper signal handling
+-- reading the package configuration file is too slow
+-- -K<size>
+
+-----------------------------------------------------------------------------
+-- GHC's command-line interface
+
+main :: IO ()
+main = do
+ initGCStatistics -- See Note [-Bsymbolic and hooks]
+ hSetBuffering stdout LineBuffering
+ hSetBuffering stderr LineBuffering
+ GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
+ -- 1. extract the -B flag from the args
+ argv00 <- getArgs
+ let argv0 = ("-B" ++ GHC.Paths.libdir) :
+ if any (`elem` argv00) ["--info", "--interactive", "--make", "-c"]
+ then argv00 -- needed for "cabal repl --with-ghc=ghci-ng"
+ else "--interactive" : argv00
+
+ let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
+ mbMinusB | null minusB_args = Nothing
+ | otherwise = Just (drop 2 (last minusB_args))
+
+ let argv1' = map (mkGeneralLocated "on the commandline") argv1
+ (argv2, staticFlagWarnings) <- parseStaticFlags argv1'
+
+ -- 2. Parse the "mode" flags (--make, --interactive etc.)
+ (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
+
+ let flagWarnings = staticFlagWarnings ++ modeFlagWarnings
+
+ -- If all we want to do is something like showing the version number
+ -- then do it now, before we start a GHC session etc. This makes
+ -- getting basic information much more resilient.
+
+ -- In particular, if we wait until later before giving the version
+ -- number then bootstrapping gets confused, as it tries to find out
+ -- what version of GHC it's using before package.conf exists, so
+ -- starting the session fails.
+ case mode of
+ Left preStartupMode ->
+ do case preStartupMode of
+ ShowSupportedExtensions -> showSupportedExtensions
+ ShowVersion -> showVersion
+ ShowNumVersion -> putStrLn cProjectVersion
+ ShowOptions -> showOptions
+ Right postStartupMode ->
+ -- start our GHC session
+ GHC.runGhc mbMinusB $ do
+
+ dflags <- GHC.getSessionDynFlags
+
+ case postStartupMode of
+ Left preLoadMode ->
+ liftIO $ do
+ case preLoadMode of
+ ShowInfo -> showInfo dflags
+ ShowGhcUsage -> showGhcUsage dflags
+ ShowGhciUsage -> showGhciUsage dflags
+ PrintWithDynFlags f -> putStrLn (f dflags)
+ Right postLoadMode ->
+ main' postLoadMode dflags argv3 flagWarnings
+
+main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String]
+ -> Ghc ()
+main' postLoadMode dflags0 args flagWarnings = do
+ -- set the default GhcMode, HscTarget and GhcLink. The HscTarget
+ -- can be further adjusted on a module by module basis, using only
+ -- the -fvia-C and -fasm flags. If the default HscTarget is not
+ -- HscC or HscAsm, -fvia-C and -fasm have no effect.
+ let dflt_target = hscTarget dflags0
+ (mode, lang, link)
+ = case postLoadMode of
+ DoInteractive -> (CompManager, HscInterpreted, LinkInMemory)
+ DoEval _ -> (CompManager, HscInterpreted, LinkInMemory)
+ DoMake -> (CompManager, dflt_target, LinkBinary)
+ DoMkDependHS -> (MkDepend, dflt_target, LinkBinary)
+ DoAbiHash -> (OneShot, dflt_target, LinkBinary)
+ _ -> (OneShot, dflt_target, LinkBinary)
+
+ let dflags1 = case lang of
+ HscInterpreted ->
+ let platform = targetPlatform dflags0
+ dflags0a = updateWays $ dflags0 { ways = interpWays }
+ dflags0b = foldl gopt_set dflags0a
+ $ concatMap (wayGeneralFlags platform)
+ interpWays
+ dflags0c = foldl gopt_unset dflags0b
+ $ concatMap (wayUnsetGeneralFlags platform)
+ interpWays
+ in dflags0c
+ _ ->
+ dflags0
+ dflags2 = dflags1{ ghcMode = mode,
+ hscTarget = lang,
+ ghcLink = link,
+ verbosity = case postLoadMode of
+ DoEval _ -> 0
+ _other -> 1
+ }
+
+ -- turn on -fimplicit-import-qualified for GHCi now, so that it
+ -- can be overriden from the command-line
+ -- XXX: this should really be in the interactive DynFlags, but
+ -- we don't set that until later in interactiveUI
+ dflags3 | DoInteractive <- postLoadMode = imp_qual_enabled
+ | DoEval _ <- postLoadMode = imp_qual_enabled
+ | otherwise = dflags2
+ where imp_qual_enabled = dflags2 `gopt_set` Opt_ImplicitImportQualified
+
+ -- The rest of the arguments are "dynamic"
+ -- Leftover ones are presumably files
+ (dflags4, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags3 args
+
+ GHC.prettyPrintGhcErrors dflags4 $ do
+
+ let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
+
+ handleSourceError (\e -> do
+ GHC.printException e
+ liftIO $ exitWith (ExitFailure 1)) $ do
+ liftIO $ handleFlagWarnings dflags4 flagWarnings'
+
+ -- make sure we clean up after ourselves
+ GHC.defaultCleanupHandler dflags4 $ do
+
+ liftIO $ showBanner postLoadMode dflags4
+
+ let
+ -- To simplify the handling of filepaths, we normalise all filepaths right
+ -- away - e.g., for win32 platforms, backslashes are converted
+ -- into forward slashes.
+ normal_fileish_paths = map (normalise . unLoc) fileish_args
+ (srcs, objs) = partition_args normal_fileish_paths [] []
+
+ dflags5 = dflags4 { ldInputs = map (FileOption "") objs
+ ++ ldInputs dflags4 }
+
+ -- we've finished manipulating the DynFlags, update the session
+ _ <- GHC.setSessionDynFlags dflags5
+ dflags6 <- GHC.getSessionDynFlags
+ hsc_env <- GHC.getSession
+
+ ---------------- Display configuration -----------
+ when (verbosity dflags6 >= 4) $
+#if __GLASGOW_HASKELL__ >= 709
+ let dumpPackages flags = putStrLn $ show $ runSDoc (pprPackages flags) ctx
+ where ctx = initSDocContext flags defaultDumpStyle
+ in
+#endif
+ liftIO $ dumpPackages dflags6
+
+ when (verbosity dflags6 >= 3) $ do
+ liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
+
+ ---------------- Final sanity checking -----------
+ liftIO $ checkOptions postLoadMode dflags6 srcs objs
+
+ ---------------- Do the business -----------
+ handleSourceError (\e -> do
+ GHC.printException e
+ liftIO $ exitWith (ExitFailure 1)) $ do
+ case postLoadMode of
+ ShowInterface f -> liftIO $ doShowIface dflags6 f
+ DoMake -> doMake srcs
+ DoMkDependHS -> doMkDependHS (map fst srcs)
+ StopBefore p -> liftIO (oneShot hsc_env p srcs)
+ DoInteractive -> ghciUI srcs Nothing
+ DoEval exprs -> ghciUI srcs $ Just $ reverse exprs
+ DoAbiHash -> abiHash srcs
+
+ liftIO $ dumpFinalStats dflags6
+
+ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()
+#ifndef GHCI
+ghciUI _ _ = throwGhcException (CmdLineError "not built for interactive use")
+#else
+ghciUI = interactiveUI defaultGhciSettings
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Splitting arguments into source files and object files. This is where we
+-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
+-- file indicating the phase specified by the -x option in force, if any.
+
+partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
+ -> ([(String, Maybe Phase)], [String])
+partition_args [] srcs objs = (reverse srcs, reverse objs)
+partition_args ("-x":suff:args) srcs objs
+ | "none" <- suff = partition_args args srcs objs
+ | StopLn <- phase = partition_args args srcs (slurp ++ objs)
+ | otherwise = partition_args rest (these_srcs ++ srcs) objs
+ where phase = startPhase suff
+ (slurp,rest) = break (== "-x") args
+ these_srcs = zip slurp (repeat (Just phase))
+partition_args (arg:args) srcs objs
+ | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
+ | otherwise = partition_args args srcs (arg:objs)
+
+ {-
+ We split out the object files (.o, .dll) and add them
+ to ldInputs for use by the linker.
+
+ The following things should be considered compilation manager inputs:
+
+ - haskell source files (strings ending in .hs, .lhs or other
+ haskellish extension),
+
+ - module names (not forgetting hierarchical module names),
+
+ - things beginning with '-' are flags that were not recognised by
+ the flag parser, and we want them to generate errors later in
+ checkOptions, so we class them as source files (#5921)
+
+ - and finally we consider everything not containing a '.' to be
+ a comp manager input, as shorthand for a .hs or .lhs filename.
+
+ Everything else is considered to be a linker object, and passed
+ straight through to the linker.
+ -}
+looks_like_an_input :: String -> Bool
+looks_like_an_input m = isSourceFilename m
+ || looksLikeModuleName m
+ || "-" `isPrefixOf` m
+ || '.' `notElem` m
+
+-- -----------------------------------------------------------------------------
+-- Option sanity checks
+
+-- | Ensure sanity of options.
+--
+-- Throws 'UsageError' or 'CmdLineError' if not.
+checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
+ -- Final sanity checking before kicking off a compilation (pipeline).
+checkOptions mode dflags srcs objs = do
+ -- Complain about any unknown flags
+ let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
+ when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
+
+ when (notNull (filter wayRTSOnly (ways dflags))
+ && isInterpretiveMode mode) $
+ hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
+
+ -- -prof and --interactive are not a good combination
+ when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)
+ && isInterpretiveMode mode) $
+ do throwGhcException (UsageError
+ "--interactive can't be used with -prof or -unreg.")
+ -- -ohi sanity check
+ if (isJust (outputHi dflags) &&
+ (isCompManagerMode mode || srcs `lengthExceeds` 1))
+ then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")
+ else do
+
+ -- -o sanity checking
+ if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
+ && not (isLinkMode mode))
+ then throwGhcException (UsageError "can't apply -o to multiple source files")
+ else do
+
+ let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
+
+ when (not_linking && not (null objs)) $
+ hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)
+
+ -- Check that there are some input files
+ -- (except in the interactive case)
+ if null srcs && (null objs || not_linking) && needsInputsMode mode
+ then throwGhcException (UsageError "no input files")
+ else do
+
+ -- Verify that output files point somewhere sensible.
+ verifyOutputFiles dflags
+
+
+-- Compiler output options
+
+-- called to verify that the output files & directories
+-- point somewhere valid.
+--
+-- The assumption is that the directory portion of these output
+-- options will have to exist by the time 'verifyOutputFiles'
+-- is invoked.
+--
+verifyOutputFiles :: DynFlags -> IO ()
+verifyOutputFiles dflags = do
+ -- not -odir: we create the directory for -odir if it doesn't exist (#2278).
+ let ofile = outputFile dflags
+ when (isJust ofile) $ do
+ let fn = fromJust ofile
+ flg <- doesDirNameExist fn
+ when (not flg) (nonExistentDir "-o" fn)
+ let ohi = outputHi dflags
+ when (isJust ohi) $ do
+ let hi = fromJust ohi
+ flg <- doesDirNameExist hi
+ when (not flg) (nonExistentDir "-ohi" hi)
+ where
+ nonExistentDir flg dir =
+ throwGhcException (CmdLineError ("error: directory portion of " ++
+ show dir ++ " does not exist (used with " ++
+ show flg ++ " option.)"))
+
+-----------------------------------------------------------------------------
+-- GHC modes of operation
+
+type Mode = Either PreStartupMode PostStartupMode
+type PostStartupMode = Either PreLoadMode PostLoadMode
+
+data PreStartupMode
+ = ShowVersion -- ghc -V/--version
+ | ShowNumVersion -- ghc --numeric-version
+ | ShowSupportedExtensions -- ghc --supported-extensions
+ | ShowOptions -- ghc --show-options
+
+showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode
+showVersionMode = mkPreStartupMode ShowVersion
+showNumVersionMode = mkPreStartupMode ShowNumVersion
+showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
+showOptionsMode = mkPreStartupMode ShowOptions
+
+mkPreStartupMode :: PreStartupMode -> Mode
+mkPreStartupMode = Left
+
+isShowVersionMode :: Mode -> Bool
+isShowVersionMode (Left ShowVersion) = True
+isShowVersionMode _ = False
+
+isShowNumVersionMode :: Mode -> Bool
+isShowNumVersionMode (Left ShowNumVersion) = True
+isShowNumVersionMode _ = False
+
+data PreLoadMode
+ = ShowGhcUsage -- ghc -?
+ | ShowGhciUsage -- ghci -?
+ | ShowInfo -- ghc --info
+ | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo
+
+showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
+showGhcUsageMode = mkPreLoadMode ShowGhcUsage
+showGhciUsageMode = mkPreLoadMode ShowGhciUsage
+showInfoMode = mkPreLoadMode ShowInfo
+
+printSetting :: String -> Mode
+printSetting k = mkPreLoadMode (PrintWithDynFlags f)
+ where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
+ $ lookup k (compilerInfo dflags)
+
+mkPreLoadMode :: PreLoadMode -> Mode
+mkPreLoadMode = Right . Left
+
+isShowGhcUsageMode :: Mode -> Bool
+isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
+isShowGhcUsageMode _ = False
+
+isShowGhciUsageMode :: Mode -> Bool
+isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
+isShowGhciUsageMode _ = False
+
+data PostLoadMode
+ = ShowInterface FilePath -- ghc --show-iface
+ | DoMkDependHS -- ghc -M
+ | StopBefore Phase -- ghc -E | -C | -S
+ -- StopBefore StopLn is the default
+ | DoMake -- ghc --make
+ | DoInteractive -- ghc --interactive
+ | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]
+ | DoAbiHash -- ghc --abi-hash
+
+doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode
+doMkDependHSMode = mkPostLoadMode DoMkDependHS
+doMakeMode = mkPostLoadMode DoMake
+doInteractiveMode = mkPostLoadMode DoInteractive
+doAbiHashMode = mkPostLoadMode DoAbiHash
+
+showInterfaceMode :: FilePath -> Mode
+showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
+
+stopBeforeMode :: Phase -> Mode
+stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
+
+doEvalMode :: String -> Mode
+doEvalMode str = mkPostLoadMode (DoEval [str])
+
+mkPostLoadMode :: PostLoadMode -> Mode
+mkPostLoadMode = Right . Right
+
+isDoInteractiveMode :: Mode -> Bool
+isDoInteractiveMode (Right (Right DoInteractive)) = True
+isDoInteractiveMode _ = False
+
+isStopLnMode :: Mode -> Bool
+isStopLnMode (Right (Right (StopBefore StopLn))) = True
+isStopLnMode _ = False
+
+isDoMakeMode :: Mode -> Bool
+isDoMakeMode (Right (Right DoMake)) = True
+isDoMakeMode _ = False
+
+#ifdef GHCI
+isInteractiveMode :: PostLoadMode -> Bool
+isInteractiveMode DoInteractive = True
+isInteractiveMode _ = False
+#endif
+
+-- isInterpretiveMode: byte-code compiler involved
+isInterpretiveMode :: PostLoadMode -> Bool
+isInterpretiveMode DoInteractive = True
+isInterpretiveMode (DoEval _) = True
+isInterpretiveMode _ = False
+
+needsInputsMode :: PostLoadMode -> Bool
+needsInputsMode DoMkDependHS = True
+needsInputsMode (StopBefore _) = True
+needsInputsMode DoMake = True
+needsInputsMode _ = False
+
+-- True if we are going to attempt to link in this mode.
+-- (we might not actually link, depending on the GhcLink flag)
+isLinkMode :: PostLoadMode -> Bool
+isLinkMode (StopBefore StopLn) = True
+isLinkMode DoMake = True
+isLinkMode DoInteractive = True
+isLinkMode (DoEval _) = True
+isLinkMode _ = False
+
+isCompManagerMode :: PostLoadMode -> Bool
+isCompManagerMode DoMake = True
+isCompManagerMode DoInteractive = True
+isCompManagerMode (DoEval _) = True
+isCompManagerMode _ = False
+
+-- -----------------------------------------------------------------------------
+-- Parsing the mode flag
+
+parseModeFlags :: [Located String]
+ -> IO (Mode,
+ [Located String],
+ [Located String])
+parseModeFlags args = do
+ let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
+ runCmdLine (processArgs mode_flags args)
+ (Nothing, [], [])
+ mode = case mModeFlag of
+ Nothing -> doMakeMode
+ Just (m, _) -> m
+ errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
+ when (not (null errs)) $ throwGhcException
+#if __GLASGOW_HASKELL__ < 709
+ $ errorsToGhcException errs
+#else
+ $ errorsToGhcException $ map (\(L sp e) -> (show sp, e)) errs
+#endif
+ return (mode, flags' ++ leftover, warns)
+
+type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
+ -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
+ -- so we collect the new ones and return them.
+
+mode_flags :: [Flag ModeM]
+#if __GLASGOW_HASKELL__ < 709
+mode_flags = flags
+#else
+mode_flags = zipWith ($) flags ghcModes
+#endif
+ where flags = concat [help, othr, prim]
+ ------- help / version -------------------------------------------------
+ help = [
+ Flag "?" (PassFlag (setMode showGhcUsageMode))
+ , Flag "-help" (PassFlag (setMode showGhcUsageMode))
+ , Flag "V" (PassFlag (setMode showVersionMode))
+ , Flag "-version" (PassFlag (setMode showVersionMode))
+ , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode))
+ , Flag "-info" (PassFlag (setMode showInfoMode))
+ , Flag "-show-options" (PassFlag (setMode showOptionsMode))
+ , Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))
+ , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
+ ]
+ othr = [ Flag k' (PassFlag (setMode (printSetting k)))
+ | k <- ["Project version",
+ "Booter version",
+ "Stage",
+ "Build platform",
+ "Host platform",
+ "Target platform",
+ "Have interpreter",
+ "Object splitting supported",
+ "Have native code generator",
+ "Support SMP",
+ "Unregisterised",
+ "Tables next to code",
+ "RTS ways",
+ "Leading underscore",
+ "Debug on",
+ "LibDir",
+ "Global Package DB",
+ "C compiler flags",
+ "Gcc Linker flags",
+ "Ld Linker flags"],
+ let k' = "-print-" ++ map (replaceSpace . toLower) k
+ replaceSpace ' ' = '-'
+ replaceSpace c = c
+ ]
+ ------- interfaces -----------------------------------------------------
+ prim = [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
+ "--show-iface"))
+
+ ------- primary modes --------------------------------------------------
+ , Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
+ addFlag "-no-link" f))
+ , Flag "M" (PassFlag (setMode doMkDependHSMode))
+ , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))
+ , Flag "C" (PassFlag (setMode (stopBeforeMode HCc)))
+ , Flag "S" (PassFlag (setMode (stopBeforeMode (as False))))
+ , Flag "-make" (PassFlag (setMode doMakeMode))
+ , Flag "-interactive" (PassFlag (setMode doInteractiveMode))
+ , Flag "-abi-hash" (PassFlag (setMode doAbiHashMode))
+ , Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))
+ ]
+#if __GLASGOW_HASKELL__ >= 709
+ ghcModes = cycle [AllModes]
+#endif
+
+setMode :: Mode -> String -> EwM ModeM ()
+setMode newMode newFlag = liftEwM $ do
+ (mModeFlag, errs, flags') <- getCmdLineState
+ let (modeFlag', errs') =
+ case mModeFlag of
+ Nothing -> ((newMode, newFlag), errs)
+ Just (oldMode, oldFlag) ->
+ case (oldMode, newMode) of
+ -- -c/--make are allowed together, and mean --make -no-link
+ _ | isStopLnMode oldMode && isDoMakeMode newMode
+ || isStopLnMode newMode && isDoMakeMode oldMode ->
+ ((doMakeMode, "--make"), [])
+
+ -- If we have both --help and --interactive then we
+ -- want showGhciUsage
+ _ | isShowGhcUsageMode oldMode &&
+ isDoInteractiveMode newMode ->
+ ((showGhciUsageMode, oldFlag), [])
+ | isShowGhcUsageMode newMode &&
+ isDoInteractiveMode oldMode ->
+ ((showGhciUsageMode, newFlag), [])
+ -- Otherwise, --help/--version/--numeric-version always win
+ | isDominantFlag oldMode -> ((oldMode, oldFlag), [])
+ | isDominantFlag newMode -> ((newMode, newFlag), [])
+ -- We need to accumulate eval flags like "-e foo -e bar"
+ (Right (Right (DoEval esOld)),
+ Right (Right (DoEval [eNew]))) ->
+ ((Right (Right (DoEval (eNew : esOld))), oldFlag),
+ errs)
+ -- Saying e.g. --interactive --interactive is OK
+ _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
+ -- Otherwise, complain
+ _ -> let err = flagMismatchErr oldFlag newFlag
+ in ((oldMode, oldFlag), err : errs)
+ putCmdLineState (Just modeFlag', errs', flags')
+ where isDominantFlag f = isShowGhcUsageMode f ||
+ isShowGhciUsageMode f ||
+ isShowVersionMode f ||
+ isShowNumVersionMode f
+
+flagMismatchErr :: String -> String -> String
+flagMismatchErr oldFlag newFlag
+ = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"
+
+addFlag :: String -> String -> EwM ModeM ()
+addFlag s flag = liftEwM $ do
+ (m, e, flags') <- getCmdLineState
+ putCmdLineState (m, e, mkGeneralLocated loc s : flags')
+ where loc = "addFlag by " ++ flag ++ " on the commandline"
+
+-- ----------------------------------------------------------------------------
+-- Run --make mode
+
+doMake :: [(String,Maybe Phase)] -> Ghc ()
+doMake srcs = do
+ let (hs_srcs, non_hs_srcs) = partition haskellish srcs
+
+ haskellish (f,Nothing) =
+ looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f
+ haskellish (_,Just phase) =
+ phase `notElem` [as True, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
+
+ hsc_env <- GHC.getSession
+
+ -- if we have no haskell sources from which to do a dependency
+ -- analysis, then just do one-shot compilation and/or linking.
+ -- This means that "ghc Foo.o Bar.o -o baz" links the program as
+ -- we expect.
+ if (null hs_srcs)
+ then liftIO (oneShot hsc_env StopLn srcs)
+ else do
+
+ o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
+ non_hs_srcs
+ dflags <- GHC.getSessionDynFlags
+ let dflags' = dflags { ldInputs = map (FileOption "") o_files
+ ++ ldInputs dflags }
+ _ <- GHC.setSessionDynFlags dflags'
+
+ targets <- mapM (uncurry GHC.guessTarget) hs_srcs
+ GHC.setTargets targets
+ ok_flag <- GHC.load LoadAllTargets
+
+ when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
+ return ()
+
+
+-- ---------------------------------------------------------------------------
+-- --show-iface mode
+
+doShowIface :: DynFlags -> FilePath -> IO ()
+doShowIface dflags file = do
+ hsc_env <- newHscEnv dflags
+ showIface hsc_env file
+
+-- ---------------------------------------------------------------------------
+-- Various banners and verbosity output.
+
+showBanner :: PostLoadMode -> DynFlags -> IO ()
+showBanner _postLoadMode dflags = do
+ let verb = verbosity dflags
+
+#ifdef GHCI
+ -- Show the GHCi banner
+ when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
+#endif
+
+ -- Display details of the configuration in verbose mode
+ when (verb >= 2) $
+ do hPutStr stderr "Glasgow Haskell Compiler, Version "
+ hPutStr stderr cProjectVersion
+ hPutStr stderr ", stage "
+ hPutStr stderr cStage
+ hPutStr stderr " booted by GHC version "
+ hPutStrLn stderr cBooterVersion
+
+-- We print out a Read-friendly string, but a prettier one than the
+-- Show instance gives us
+showInfo :: DynFlags -> IO ()
+showInfo dflags = do
+ let sq x = " [" ++ x ++ "\n ]"
+ putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
+
+showSupportedExtensions :: IO ()
+showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
+
+showVersion :: IO ()
+showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
+
+showOptions :: IO ()
+showOptions = putStr (unlines availableOptions)
+ where
+ availableOptions = map ((:) '-') $
+ getFlagNames mode_flags ++
+ getFlagNames flagsDynamic ++
+ (filterUnwantedStatic . getFlagNames $ flagsStatic) ++
+ flagsStaticNames
+ getFlagNames opts = map getFlagName opts
+#if __GLASGOW_HASKELL__ < 709
+ getFlagName (Flag name _) = name
+#else
+ getFlagName (Flag name _ _) = name
+#endif
+ -- this is a hack to get rid of two unwanted entries that get listed
+ -- as static flags. Hopefully this hack will disappear one day together
+ -- with static flags
+ filterUnwantedStatic = filter (\x -> not (x `elem` ["f", "fno-"]))
+
+showGhcUsage :: DynFlags -> IO ()
+showGhcUsage = showUsage False
+
+showGhciUsage :: DynFlags -> IO ()
+showGhciUsage = showUsage True
+
+showUsage :: Bool -> DynFlags -> IO ()
+showUsage ghci dflags = do
+ let usage_path = if ghci then ghciUsagePath dflags
+ else ghcUsagePath dflags
+ usage <- readFile usage_path
+ dump usage
+ where
+ dump "" = return ()
+ dump ('$':'$':s) = putStr progName >> dump s
+ dump (c:s) = putChar c >> dump s
+
+dumpFinalStats :: DynFlags -> IO ()
+dumpFinalStats dflags =
+ when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
+
+dumpFastStringStats :: DynFlags -> IO ()
+dumpFastStringStats dflags = do
+ buckets <- getFastStringTable
+ let (entries, longest, has_z) = countFS 0 0 0 buckets
+ msg = text "FastString stats:" $$
+ nest 4 (vcat [text "size: " <+> int (length buckets),
+ text "entries: " <+> int entries,
+ text "longest chain: " <+> int longest,
+ text "has z-encoding: " <+> (has_z `pcntOf` entries)
+ ])
+ -- we usually get more "has z-encoding" than "z-encoded", because
+ -- when we z-encode a string it might hash to the exact same string,
+ -- which will is not counted as "z-encoded". Only strings whose
+ -- Z-encoding is different from the original string are counted in
+ -- the "z-encoded" total.
+ putMsg dflags msg
+ where
+ x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
+
+countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)
+countFS entries longest has_z [] = (entries, longest, has_z)
+countFS entries longest has_z (b:bs) =
+ let
+ len = length b
+ longest' = max len longest
+ entries' = entries + len
+ has_zs = length (filter hasZEncoding b)
+ in
+ countFS entries' longest' (has_z + has_zs) bs
+
+-- -----------------------------------------------------------------------------
+-- ABI hash support
+
+{-
+ ghc --abi-hash Data.Foo System.Bar
+
+Generates a combined hash of the ABI for modules Data.Foo and
+System.Bar. The modules must already be compiled, and appropriate -i
+options may be necessary in order to find the .hi files.
+
+This is used by Cabal for generating the InstalledPackageId for a
+package. The InstalledPackageId must change when the visible ABI of
+the package chagnes, so during registration Cabal calls ghc --abi-hash
+to get a hash of the package's ABI.
+-}
+
+abiHash :: [(String, Maybe Phase)] -> Ghc ()
+abiHash strs = do
+ hsc_env <- getSession
+ let dflags = hsc_dflags hsc_env
+
+ liftIO $ do
+
+ let find_it str = do
+ let modname = mkModuleName str
+ r <- findImportedModule hsc_env modname Nothing
+ case r of
+ Found _ m -> return m
+ _error -> throwGhcException $ CmdLineError $ showSDoc dflags $
+ cannotFindInterface dflags modname r
+
+ mods <- mapM find_it (map fst strs)
+
+ let get_iface modl = loadUserInterface False (text "abiHash") modl
+ ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods
+
+ bh <- openBinMem (3*1024) -- just less than a block
+ put_ bh hiVersion
+ -- package hashes change when the compiler version changes (for now)
+ -- see #5328
+ mapM_ (put_ bh . mi_mod_hash) ifaces
+ f <- fingerprintBinMem bh
+
+ putStrLn (showPpr dflags f)
+
+-- -----------------------------------------------------------------------------
+-- Util
+
+unknownFlagsErr :: [String] -> a
+unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs
+ where
+ oneError f =
+ "unrecognised flag: " ++ f ++ "\n" ++
+ (case fuzzyMatch f (nub allFlags) of
+ [] -> ""
+ suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))
+
+{- Note [-Bsymbolic and hooks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-Bsymbolic is a flag that prevents the binding of references to global
+symbols to symbols outside the shared library being compiled (see `man
+ld`). When dynamically linking, we don't use -Bsymbolic on the RTS
+package: that is because we want hooks to be overridden by the user,
+we don't want to constrain them to the RTS package.
+
+Unfortunately this seems to have broken somehow on OS X: as a result,
+defaultHooks (in hschooks.c) is not called, which does not initialize
+the GC stats. As a result, this breaks things like `:set +s` in GHCi
+(#8754). As a hacky workaround, we instead call 'defaultHooks'
+directly to initalize the flags in the RTS.
+
+A biproduct of this, I believe, is that hooks are likely broken on OS
+X when dynamically linking. But this probably doesn't affect most
+people since we're linking GHC dynamically, but most things themselves
+link statically.
+-}
+
+foreign import ccall safe "initGCStatistics"
+ initGCStatistics :: IO ()
+
+-- | Compatibility between GHC 7.8.2 -> GHC 7.8.3.
+as :: Bool -> Phase
+#if MIN_VERSION_ghc(7,8,3)
+as = As
+#else
+as _ = As
+#endif