root/compiler/main/GHC.hs

Revision 979785c489da00572b801450ead1114d33b7b2a4, 51.5 KB (checked in by David Terei <davidterei@…>, 5 weeks ago)

Add experimental GHCi monad.

Modification of previous commit:
e0e99f9948c1eac82cf69dd3cc30cb068e42d45e

Allows setting which monad GHCi runs statements in. Unsupported at this
stage.

  • Property mode set to 100644
Line 
1-- -----------------------------------------------------------------------------
2--
3-- (c) The University of Glasgow, 2005
4--
5-- The GHC API
6--
7-- -----------------------------------------------------------------------------
8
9module GHC (
10        -- * Initialisation
11        defaultErrorHandler,
12        defaultCleanupHandler,
13
14        -- * GHC Monad
15        Ghc, GhcT, GhcMonad(..), HscEnv,
16        runGhc, runGhcT, initGhcMonad,
17        gcatch, gbracket, gfinally,
18        printException,
19        printExceptionAndWarnings,
20        handleSourceError,
21        needsTemplateHaskell,
22
23        -- * Flags and settings
24        DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
25        GhcMode(..), GhcLink(..), defaultObjectTarget,
26        parseDynamicFlags,
27        getSessionDynFlags, setSessionDynFlags,
28        getProgramDynFlags, setProgramDynFlags,
29        getInteractiveDynFlags, setInteractiveDynFlags,
30        parseStaticFlags,
31
32        -- * Targets
33        Target(..), TargetId(..), Phase,
34        setTargets,
35        getTargets,
36        addTarget,
37        removeTarget,
38        guessTarget,
39       
40        -- * Loading\/compiling the program
41        depanal,
42        load, LoadHowMuch(..), InteractiveImport(..),
43        SuccessFlag(..), succeeded, failed,
44        defaultWarnErrLogger, WarnErrLogger,
45        workingDirectoryChanged,
46        parseModule, typecheckModule, desugarModule, loadModule,
47        ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
48        TypecheckedSource, ParsedSource, RenamedSource,   -- ditto
49        TypecheckedMod, ParsedMod,
50        moduleInfo, renamedSource, typecheckedSource,
51        parsedSource, coreModule,
52
53        -- ** Compiling to Core
54        CoreModule(..),
55        compileToCoreModule, compileToCoreSimplified,
56        compileCoreToObj,
57
58        -- * Inspecting the module structure of the program
59        ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
60        getModSummary,
61        getModuleGraph,
62        isLoaded,
63        topSortModuleGraph,
64
65        -- * Inspecting modules
66        ModuleInfo,
67        getModuleInfo,
68        modInfoTyThings,
69        modInfoTopLevelScope,
70        modInfoExports,
71        modInfoInstances,
72        modInfoIsExportedName,
73        modInfoLookupName,
74        modInfoIface,
75        modInfoSafe,
76        lookupGlobalName,
77        findGlobalAnns,
78        mkPrintUnqualifiedForModule,
79        ModIface(..),
80        SafeHaskellMode(..),
81
82        -- * Querying the environment
83        packageDbModules,
84
85        -- * Printing
86        PrintUnqualified, alwaysQualify,
87
88        -- * Interactive evaluation
89        getBindings, getInsts, getPrintUnqual,
90        findModule, lookupModule,
91#ifdef GHCI
92        isModuleTrusted,
93        setContext, getContext, 
94        getNamesInScope,
95        getRdrNamesInScope,
96        getGRE,
97        moduleIsInterpreted,
98        getInfo,
99        exprType,
100        typeKind,
101        parseName,
102        RunResult(..), 
103        runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation,
104        parseImportDecl, SingleStep(..),
105        resume,
106        Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
107               resumeHistory, resumeHistoryIx),
108        History(historyBreakInfo, historyEnclosingDecls), 
109        GHC.getHistorySpan, getHistoryModule,
110        getResumeContext,
111        abandon, abandonAll,
112        InteractiveEval.back,
113        InteractiveEval.forward,
114        showModule,
115        isModuleInterpreted,
116        InteractiveEval.compileExpr, HValue, dynCompileExpr,
117        GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
118        modInfoModBreaks,
119        ModBreaks(..), BreakIndex,
120        BreakInfo(breakInfo_number, breakInfo_module),
121        BreakArray, setBreakOn, setBreakOff, getBreak,
122#endif
123        lookupName,
124
125#ifdef GHCI
126        -- ** EXPERIMENTAL
127        setGHCiMonad,
128#endif
129
130        -- * Abstract syntax elements
131
132        -- ** Packages
133        PackageId,
134
135        -- ** Modules
136        Module, mkModule, pprModule, moduleName, modulePackageId,
137        ModuleName, mkModuleName, moduleNameString,
138
139        -- ** Names
140        Name, 
141        isExternalName, nameModule, pprParenSymName, nameSrcSpan,
142        NamedThing(..),
143        RdrName(Qual,Unqual),
144       
145        -- ** Identifiers
146        Id, idType,
147        isImplicitId, isDeadBinder,
148        isExportedId, isLocalId, isGlobalId,
149        isRecordSelector,
150        isPrimOpId, isFCallId, isClassOpId_maybe,
151        isDataConWorkId, idDataCon,
152        isBottomingId, isDictonaryId,
153        recordSelectorFieldLabel,
154
155        -- ** Type constructors
156        TyCon, 
157        tyConTyVars, tyConDataCons, tyConArity,
158        isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
159        isFamilyTyCon, tyConClass_maybe,
160        synTyConDefn, synTyConType, synTyConResKind,
161
162        -- ** Type variables
163        TyVar,
164        alphaTyVars,
165
166        -- ** Data constructors
167        DataCon,
168        dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
169        dataConIsInfix, isVanillaDataCon, dataConUserType,
170        dataConStrictMarks, 
171        StrictnessMark(..), isMarkedStrict,
172
173        -- ** Classes
174        Class, 
175        classMethods, classSCTheta, classTvsFds, classATs,
176        pprFundeps,
177
178        -- ** Instances
179        ClsInst, 
180        instanceDFunId, 
181        pprInstance, pprInstanceHdr,
182        pprFamInst, pprFamInstHdr,
183
184        -- ** Types and Kinds
185        Type, splitForAllTys, funResultTy, 
186        pprParendType, pprTypeApp, 
187        Kind,
188        PredType,
189        ThetaType, pprForAll, pprThetaArrowTy,
190
191        -- ** Entities
192        TyThing(..), 
193
194        -- ** Syntax
195        module HsSyn, -- ToDo: remove extraneous bits
196
197        -- ** Fixities
198        FixityDirection(..), 
199        defaultFixity, maxPrecedence, 
200        negateFixity,
201        compareFixity,
202
203        -- ** Source locations
204        SrcLoc(..), RealSrcLoc, 
205        mkSrcLoc, noSrcLoc,
206        srcLocFile, srcLocLine, srcLocCol,
207        SrcSpan(..), RealSrcSpan,
208        mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
209        srcSpanStart, srcSpanEnd,
210        srcSpanFile, 
211        srcSpanStartLine, srcSpanEndLine, 
212        srcSpanStartCol, srcSpanEndCol,
213
214        -- ** Located
215        GenLocated(..), Located,
216
217        -- *** Constructing Located
218        noLoc, mkGeneralLocated,
219
220        -- *** Deconstructing Located
221        getLoc, unLoc,
222
223        -- *** Combining and comparing Located values
224        eqLocated, cmpLocated, combineLocs, addCLoc,
225        leftmost_smallest, leftmost_largest, rightmost,
226        spans, isSubspanOf,
227
228        -- * Exceptions
229        GhcException(..), showGhcException,
230
231        -- * Token stream manipulations
232        Token,
233        getTokenStream, getRichTokenStream,
234        showRichTokenStream, addSourceToTokens,
235
236        -- * Pure interface to the parser
237        parser,
238
239        -- * Miscellaneous
240        --sessionHscEnv,
241        cyclicModuleErr,
242  ) where
243
244{-
245 ToDo:
246
247  * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
248  * what StaticFlags should we expose, if any?
249-}
250
251#include "HsVersions.h"
252
253#ifdef GHCI
254import Linker           ( HValue )
255import ByteCodeInstr
256import BreakArray
257import InteractiveEval
258#endif
259
260import HscMain
261import GhcMake
262import DriverPipeline   ( compile' )
263import GhcMonad
264import TcRnMonad        ( finalSafeMode )
265import TcRnTypes
266import Packages
267import NameSet
268import RdrName
269import qualified HsSyn -- hack as we want to reexport the whole module
270import HsSyn
271import Type     hiding( typeKind )
272import Kind             ( synTyConResKind )
273import TcType           hiding( typeKind )
274import Id
275import TysPrim          ( alphaTyVars )
276import TyCon
277import Class
278import DataCon
279import Name             hiding ( varName )
280import Avail
281import InstEnv
282import FamInstEnv
283import SrcLoc
284import CoreSyn
285import TidyPgm
286import DriverPhases     ( Phase(..), isHaskellSrcFilename )
287import Finder
288import HscTypes
289import DynFlags
290import StaticFlagParser
291import qualified StaticFlags
292import SysTools
293import Annotations
294import Module
295import UniqFM
296import Panic
297import Bag              ( unitBag )
298import ErrUtils
299import MonadUtils
300import Util
301import StringBuffer
302import Outputable
303import BasicTypes
304import Maybes           ( expectJust )
305import FastString
306import qualified Parser
307import Lexer
308
309import System.Directory ( doesFileExist, getCurrentDirectory )
310import Data.Maybe
311import Data.List        ( find )
312import Data.Time
313import Data.Typeable    ( Typeable )
314import Data.Word        ( Word8 )
315import Control.Monad
316import System.Exit      ( exitWith, ExitCode(..) )
317import Exception
318import Data.IORef
319import System.FilePath
320import System.IO
321import Prelude hiding (init)
322
323
324-- %************************************************************************
325-- %*                                                                      *
326--             Initialisation: exception handlers
327-- %*                                                                      *
328-- %************************************************************************
329
330
331-- | Install some default exception handlers and run the inner computation.
332-- Unless you want to handle exceptions yourself, you should wrap this around
333-- the top level of your program.  The default handlers output the error
334-- message(s) to stderr and exit cleanly.
335defaultErrorHandler :: (ExceptionMonad m, MonadIO m)
336                    => LogAction -> FlushOut -> m a -> m a
337defaultErrorHandler la (FlushOut flushOut) inner =
338  -- top-level exception handler: any unrecognised exception is a compiler bug.
339  ghandle (\exception -> liftIO $ do
340           flushOut
341           case fromException exception of
342                -- an IO exception probably isn't our fault, so don't panic
343                Just (ioe :: IOException) ->
344                  fatalErrorMsg' la (text (show ioe))
345                _ -> case fromException exception of
346                     Just UserInterrupt -> exitWith (ExitFailure 1)
347                     Just StackOverflow ->
348                         fatalErrorMsg' la (text "stack overflow: use +RTS -K<size> to increase it")
349                     _ -> case fromException exception of
350                          Just (ex :: ExitCode) -> throw ex
351                          _ ->
352                              fatalErrorMsg' la
353                                  (text (show (Panic (show exception))))
354           exitWith (ExitFailure 1)
355         ) $
356
357  -- error messages propagated as exceptions
358  handleGhcException
359            (\ge -> liftIO $ do
360                flushOut
361                case ge of
362                     PhaseFailed _ code -> exitWith code
363                     Signal _ -> exitWith (ExitFailure 1)
364                     _ -> do fatalErrorMsg' la (text (show ge))
365                             exitWith (ExitFailure 1)
366            ) $
367  inner
368
369-- | Install a default cleanup handler to remove temporary files deposited by
370-- a GHC run.  This is seperate from 'defaultErrorHandler', because you might
371-- want to override the error handling, but still get the ordinary cleanup
372-- behaviour.
373defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) =>
374                         DynFlags -> m a -> m a
375defaultCleanupHandler dflags inner =
376    -- make sure we clean up after ourselves
377    inner `gfinally`
378          (liftIO $ do
379              cleanTempFiles dflags
380              cleanTempDirs dflags
381          )
382          --  exceptions will be blocked while we clean the temporary files,
383          -- so there shouldn't be any difficulty if we receive further
384          -- signals.
385
386
387-- %************************************************************************
388-- %*                                                                      *
389--             The Ghc Monad
390-- %*                                                                      *
391-- %************************************************************************
392
393-- | Run function for the 'Ghc' monad.
394--
395-- It initialises the GHC session and warnings via 'initGhcMonad'.  Each call
396-- to this function will create a new session which should not be shared among
397-- several threads.
398--
399-- Any errors not handled inside the 'Ghc' action are propagated as IO
400-- exceptions.
401
402runGhc :: Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
403       -> Ghc a           -- ^ The action to perform.
404       -> IO a
405runGhc mb_top_dir ghc = do
406  ref <- newIORef (panic "empty session")
407  let session = Session ref
408  flip unGhc session $ do
409    initGhcMonad mb_top_dir
410    ghc
411  -- XXX: unregister interrupt handlers here?
412
413-- | Run function for 'GhcT' monad transformer.
414--
415-- It initialises the GHC session and warnings via 'initGhcMonad'.  Each call
416-- to this function will create a new session which should not be shared among
417-- several threads.
418
419runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) =>
420           Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
421        -> GhcT m a        -- ^ The action to perform.
422        -> m a
423runGhcT mb_top_dir ghct = do
424  ref <- liftIO $ newIORef (panic "empty session")
425  let session = Session ref
426  flip unGhcT session $ do
427    initGhcMonad mb_top_dir
428    ghct
429
430-- | Initialise a GHC session.
431--
432-- If you implement a custom 'GhcMonad' you must call this function in the
433-- monad run function.  It will initialise the session variable and clear all
434-- warnings.
435--
436-- The first argument should point to the directory where GHC's library files
437-- reside.  More precisely, this should be the output of @ghc --print-libdir@
438-- of the version of GHC the module using this API is compiled with.  For
439-- portability, you should use the @ghc-paths@ package, available at
440-- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/ghc-paths>.
441
442initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
443initGhcMonad mb_top_dir = do
444  -- catch ^C
445  liftIO $ installSignalHandlers
446
447  liftIO $ StaticFlags.initStaticOpts
448
449  mySettings <- liftIO $ initSysTools mb_top_dir
450  dflags <- liftIO $ initDynFlags (defaultDynFlags mySettings)
451  env <- liftIO $ newHscEnv dflags
452  setSession env
453
454
455-- %************************************************************************
456-- %*                                                                      *
457--             Flags & settings
458-- %*                                                                      *
459-- %************************************************************************
460
461-- $DynFlags
462--
463-- The GHC session maintains two sets of 'DynFlags':
464--
465--   * The "interactive" @DynFlags@, which are used for everything
466--     related to interactive evaluation, including 'runStmt',
467--     'runDecls', 'exprType', 'lookupName' and so on (everything
468--     under \"Interactive evaluation\" in this module).
469--
470--   * The "program" @DynFlags@, which are used when loading
471--     whole modules with 'load'
472--
473-- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the
474-- interactive @DynFlags@.
475--
476-- 'setProgramDynFlags', 'getProgramDynFlags' work with the
477-- program @DynFlags@.
478--
479-- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags'
480-- retrieves the program @DynFlags@ (for backwards compatibility).
481
482
483-- | Updates both the interactive and program DynFlags in a Session.
484-- This also reads the package database (unless it has already been
485-- read), and prepares the compilers knowledge about packages.  It can
486-- be called again to load new packages: just add new package flags to
487-- (packageFlags dflags).
488--
489-- Returns a list of new packages that may need to be linked in using
490-- the dynamic linker (see 'linkPackages') as a result of new package
491-- flags.  If you are not doing linking or doing static linking, you
492-- can ignore the list of packages returned.
493--
494setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
495setSessionDynFlags dflags = do
496  (dflags', preload) <- liftIO $ initPackages dflags
497  modifySession $ \h -> h{ hsc_dflags = dflags'
498                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags' } }
499  return preload
500
501-- | Sets the program 'DynFlags'.
502setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
503setProgramDynFlags dflags = do
504  (dflags', preload) <- liftIO $ initPackages dflags
505  modifySession $ \h -> h{ hsc_dflags = dflags' }
506  return preload
507
508-- | Returns the program 'DynFlags'.
509getProgramDynFlags :: GhcMonad m => m DynFlags
510getProgramDynFlags = getSessionDynFlags
511
512-- | Set the 'DynFlags' used to evaluate interactive expressions.
513-- Note: this cannot be used for changes to packages.  Use
514-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the
515-- 'pkgState' into the interactive @DynFlags@.
516setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
517setInteractiveDynFlags dflags = do
518  modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags }}
519
520-- | Get the 'DynFlags' used to evaluate interactive expressions.
521getInteractiveDynFlags :: GhcMonad m => m DynFlags
522getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))
523
524
525parseDynamicFlags :: Monad m =>
526                     DynFlags -> [Located String]
527                  -> m (DynFlags, [Located String], [Located String])
528parseDynamicFlags = parseDynamicFlagsCmdLine
529
530
531-- %************************************************************************
532-- %*                                                                      *
533--             Setting, getting, and modifying the targets
534-- %*                                                                      *
535-- %************************************************************************
536
537-- ToDo: think about relative vs. absolute file paths. And what
538-- happens when the current directory changes.
539
540-- | Sets the targets for this session.  Each target may be a module name
541-- or a filename.  The targets correspond to the set of root modules for
542-- the program\/library.  Unloading the current program is achieved by
543-- setting the current set of targets to be empty, followed by 'load'.
544setTargets :: GhcMonad m => [Target] -> m ()
545setTargets targets = modifySession (\h -> h{ hsc_targets = targets })
546
547-- | Returns the current set of targets
548getTargets :: GhcMonad m => m [Target]
549getTargets = withSession (return . hsc_targets)
550
551-- | Add another target.
552addTarget :: GhcMonad m => Target -> m ()
553addTarget target
554  = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
555
556-- | Remove a target
557removeTarget :: GhcMonad m => TargetId -> m ()
558removeTarget target_id
559  = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
560  where
561   filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
562
563-- | Attempts to guess what Target a string refers to.  This function
564-- implements the @--make@/GHCi command-line syntax for filenames:
565--
566--   - if the string looks like a Haskell source filename, then interpret it
567--     as such
568--
569--   - if adding a .hs or .lhs suffix yields the name of an existing file,
570--     then use that
571--
572--   - otherwise interpret the string as a module name
573--
574guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
575guessTarget str (Just phase)
576   = return (Target (TargetFile str (Just phase)) True Nothing)
577guessTarget str Nothing
578   | isHaskellSrcFilename file
579   = return (target (TargetFile file Nothing))
580   | otherwise
581   = do exists <- liftIO $ doesFileExist hs_file
582        if exists
583           then return (target (TargetFile hs_file Nothing))
584           else do
585        exists <- liftIO $ doesFileExist lhs_file
586        if exists
587           then return (target (TargetFile lhs_file Nothing))
588           else do
589        if looksLikeModuleName file
590           then return (target (TargetModule (mkModuleName file)))
591           else do
592        throwGhcException
593                 (ProgramError (showSDoc $
594                 text "target" <+> quotes (text file) <+> 
595                 text "is not a module name or a source file"))
596     where 
597         (file,obj_allowed)
598                | '*':rest <- str = (rest, False)
599                | otherwise       = (str,  True)
600
601         hs_file  = file <.> "hs"
602         lhs_file = file <.> "lhs"
603
604         target tid = Target tid obj_allowed Nothing
605
606
607-- | Inform GHC that the working directory has changed.  GHC will flush
608-- its cache of module locations, since it may no longer be valid.
609--
610-- Note: Before changing the working directory make sure all threads running
611-- in the same session have stopped.  If you change the working directory,
612-- you should also unload the current program (set targets to empty,
613-- followed by load).
614workingDirectoryChanged :: GhcMonad m => m ()
615workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
616
617
618-- %************************************************************************
619-- %*                                                                      *
620--             Running phases one at a time
621-- %*                                                                      *
622-- %************************************************************************
623
624class ParsedMod m where
625  modSummary   :: m -> ModSummary
626  parsedSource :: m -> ParsedSource
627
628class ParsedMod m => TypecheckedMod m where
629  renamedSource     :: m -> Maybe RenamedSource
630  typecheckedSource :: m -> TypecheckedSource
631  moduleInfo        :: m -> ModuleInfo
632  tm_internals      :: m -> (TcGblEnv, ModDetails)
633        -- ToDo: improvements that could be made here:
634        --  if the module succeeded renaming but not typechecking,
635        --  we can still get back the GlobalRdrEnv and exports, so
636        --  perhaps the ModuleInfo should be split up into separate
637        --  fields.
638
639class TypecheckedMod m => DesugaredMod m where
640  coreModule :: m -> ModGuts
641
642-- | The result of successful parsing.
643data ParsedModule =
644  ParsedModule { pm_mod_summary   :: ModSummary
645               , pm_parsed_source :: ParsedSource
646               , pm_extra_src_files :: [FilePath] }
647
648instance ParsedMod ParsedModule where
649  modSummary m    = pm_mod_summary m
650  parsedSource m = pm_parsed_source m
651
652-- | The result of successful typechecking.  It also contains the parser
653--   result.
654data TypecheckedModule =
655  TypecheckedModule { tm_parsed_module       :: ParsedModule
656                    , tm_renamed_source      :: Maybe RenamedSource
657                    , tm_typechecked_source  :: TypecheckedSource
658                    , tm_checked_module_info :: ModuleInfo
659                    , tm_internals_          :: (TcGblEnv, ModDetails)
660                    }
661
662instance ParsedMod TypecheckedModule where
663  modSummary m   = modSummary (tm_parsed_module m)
664  parsedSource m = parsedSource (tm_parsed_module m)
665
666instance TypecheckedMod TypecheckedModule where
667  renamedSource m     = tm_renamed_source m
668  typecheckedSource m = tm_typechecked_source m
669  moduleInfo m        = tm_checked_module_info m
670  tm_internals m      = tm_internals_ m
671
672-- | The result of successful desugaring (i.e., translation to core).  Also
673--  contains all the information of a typechecked module.
674data DesugaredModule =
675  DesugaredModule { dm_typechecked_module :: TypecheckedModule
676                  , dm_core_module        :: ModGuts
677             }
678
679instance ParsedMod DesugaredModule where
680  modSummary m   = modSummary (dm_typechecked_module m)
681  parsedSource m = parsedSource (dm_typechecked_module m)
682
683instance TypecheckedMod DesugaredModule where
684  renamedSource m     = renamedSource (dm_typechecked_module m)
685  typecheckedSource m = typecheckedSource (dm_typechecked_module m)
686  moduleInfo m        = moduleInfo (dm_typechecked_module m)
687  tm_internals m      = tm_internals_ (dm_typechecked_module m)
688
689instance DesugaredMod DesugaredModule where
690  coreModule m = dm_core_module m
691
692type ParsedSource      = Located (HsModule RdrName)
693type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
694                          Maybe LHsDocString)
695type TypecheckedSource = LHsBinds Id
696
697-- NOTE:
698--   - things that aren't in the output of the typechecker right now:
699--     - the export list
700--     - the imports
701--     - type signatures
702--     - type/data/newtype declarations
703--     - class declarations
704--     - instances
705--   - extra things in the typechecker's output:
706--     - default methods are turned into top-level decls.
707--     - dictionary bindings
708
709-- | Return the 'ModSummary' of a module with the given name.
710--
711-- The module must be part of the module graph (see 'hsc_mod_graph' and
712-- 'ModuleGraph').  If this is not the case, this function will throw a
713-- 'GhcApiError'.
714--
715-- This function ignores boot modules and requires that there is only one
716-- non-boot module with the given name.
717getModSummary :: GhcMonad m => ModuleName -> m ModSummary
718getModSummary mod = do
719   mg <- liftM hsc_mod_graph getSession
720   case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of
721     [] -> throw $ mkApiErr (text "Module not part of module graph")
722     [ms] -> return ms
723     multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple)
724
725-- | Parse a module.
726--
727-- Throws a 'SourceError' on parse error.
728parseModule :: GhcMonad m => ModSummary -> m ParsedModule
729parseModule ms = do
730   hsc_env <- getSession
731   let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
732   hpm <- liftIO $ hscParse hsc_env_tmp ms
733   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm))
734
735-- | Typecheck and rename a parsed module.
736--
737-- Throws a 'SourceError' if either fails.
738typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
739typecheckModule pmod = do
740 let ms = modSummary pmod
741 hsc_env <- getSession
742 let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
743 (tc_gbl_env, rn_info)
744       <- liftIO $ hscTypecheckRename hsc_env_tmp ms $
745                      HsParsedModule { hpm_module = parsedSource pmod,
746                                       hpm_src_files = pm_extra_src_files pmod }
747 details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
748 safe    <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env
749 return $
750     TypecheckedModule {
751       tm_internals_          = (tc_gbl_env, details),
752       tm_parsed_module       = pmod,
753       tm_renamed_source      = rn_info,
754       tm_typechecked_source  = tcg_binds tc_gbl_env,
755       tm_checked_module_info =
756         ModuleInfo {
757           minf_type_env  = md_types details,
758           minf_exports   = availsToNameSet $ md_exports details,
759           minf_rdr_env   = Just (tcg_rdr_env tc_gbl_env),
760           minf_instances = md_insts details,
761           minf_iface     = Nothing,
762           minf_safe      = safe
763#ifdef GHCI
764          ,minf_modBreaks = emptyModBreaks
765#endif
766         }}
767
768-- | Desugar a typechecked module.
769desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
770desugarModule tcm = do
771 let ms = modSummary tcm
772 let (tcg, _) = tm_internals tcm
773 hsc_env <- getSession
774 let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
775 guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg
776 return $
777     DesugaredModule {
778       dm_typechecked_module = tcm,
779       dm_core_module        = guts
780     }
781
782-- | Load a module.  Input doesn't need to be desugared.
783--
784-- A module must be loaded before dependent modules can be typechecked.  This
785-- always includes generating a 'ModIface' and, depending on the
786-- 'DynFlags.hscTarget', may also include code generation.
787--
788-- This function will always cause recompilation and will always overwrite
789-- previous compilation results (potentially files on disk).
790--
791loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
792loadModule tcm = do
793   let ms = modSummary tcm
794   let mod = ms_mod_name ms
795   let loc = ms_location ms
796   let (tcg, _details) = tm_internals tcm
797
798   mb_linkable <- case ms_obj_date ms of
799                     Just t | t > ms_hs_date ms  -> do
800                         l <- liftIO $ findObjectLinkable (ms_mod ms) 
801                                                  (ml_obj_file loc) t
802                         return (Just l)
803                     _otherwise -> return Nothing
804                                               
805   let source_modified | isNothing mb_linkable = SourceModified
806                       | otherwise             = SourceUnmodified
807                       -- we can't determine stability here
808
809   -- compile doesn't change the session
810   hsc_env <- getSession
811   mod_info <- liftIO $ compile' (hscNothingBackendOnly     tcg,
812                                  hscInteractiveBackendOnly tcg,
813                                  hscBatchBackendOnly       tcg)
814                                  hsc_env ms 1 1 Nothing mb_linkable
815                                  source_modified
816
817   modifySession $ \e -> e{ hsc_HPT = addToUFM (hsc_HPT e) mod mod_info }
818   return tcm
819
820
821-- %************************************************************************
822-- %*                                                                      *
823--             Dealing with Core
824-- %*                                                                      *
825-- %************************************************************************
826
827-- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for
828-- the 'GHC.compileToCoreModule' interface.
829data CoreModule
830  = CoreModule {
831      -- | Module name
832      cm_module   :: !Module,
833      -- | Type environment for types declared in this module
834      cm_types    :: !TypeEnv,
835      -- | Declarations
836      cm_binds    :: CoreProgram,
837      -- | Safe Haskell mode
838      cm_safe     :: SafeHaskellMode
839    }
840
841instance Outputable CoreModule where
842   ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb,
843                    cm_safe = sf})
844    = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te
845      $$ vcat (map ppr cb)
846
847-- | This is the way to get access to the Core bindings corresponding
848-- to a module. 'compileToCore' parses, typechecks, and
849-- desugars the module, then returns the resulting Core module (consisting of
850-- the module name, type declarations, and function declarations) if
851-- successful.
852compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
853compileToCoreModule = compileCore False
854
855-- | Like compileToCoreModule, but invokes the simplifier, so
856-- as to return simplified and tidied Core.
857compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
858compileToCoreSimplified = compileCore True
859{-
860-- | Provided for backwards-compatibility: compileToCore returns just the Core
861-- bindings, but for most purposes, you probably want to call
862-- compileToCoreModule.
863compileToCore :: GhcMonad m => FilePath -> m [CoreBind]
864compileToCore fn = do
865   mod <- compileToCoreModule session fn
866   return $ cm_binds mod
867-}
868-- | Takes a CoreModule and compiles the bindings therein
869-- to object code. The first argument is a bool flag indicating
870-- whether to run the simplifier.
871-- The resulting .o, .hi, and executable files, if any, are stored in the
872-- current directory, and named according to the module name.
873-- This has only so far been tested with a single self-contained module.
874compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m ()
875compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
876  dflags      <- getSessionDynFlags
877  currentTime <- liftIO $ getCurrentTime
878  cwd         <- liftIO $ getCurrentDirectory
879  modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd
880                   ((moduleNameSlashes . moduleName) mName)
881
882  let modSum = ModSummary { ms_mod = mName,
883         ms_hsc_src = ExtCoreFile,
884         ms_location = modLocation,
885         -- By setting the object file timestamp to Nothing,
886         -- we always force recompilation, which is what we
887         -- want. (Thus it doesn't matter what the timestamp
888         -- for the (nonexistent) source file is.)
889         ms_hs_date = currentTime,
890         ms_obj_date = Nothing,
891         -- Only handling the single-module case for now, so no imports.
892         ms_srcimps = [],
893         ms_textual_imps = [],
894         -- No source file
895         ms_hspp_file = "",
896         ms_hspp_opts = dflags,
897         ms_hspp_buf = Nothing
898      }
899
900  hsc_env <- getSession
901  liftIO $ hscCompileCore hsc_env simplify (cm_safe cm) modSum (cm_binds cm)
902
903
904compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
905compileCore simplify fn = do
906   -- First, set the target to the desired filename
907   target <- guessTarget fn Nothing
908   addTarget target
909   _ <- load LoadAllTargets
910   -- Then find dependencies
911   modGraph <- depanal [] True
912   case find ((== fn) . msHsFilePath) modGraph of
913     Just modSummary -> do
914       -- Now we have the module name;
915       -- parse, typecheck and desugar the module
916       mod_guts <- coreModule `fmap`
917                      -- TODO: space leaky: call hsc* directly?
918                      (desugarModule =<< typecheckModule =<< parseModule modSummary)
919       liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $
920         if simplify
921          then do
922             -- If simplify is true: simplify (hscSimplify), then tidy
923             -- (tidyProgram).
924             hsc_env <- getSession
925             simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts
926             tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
927             return $ Left tidy_guts
928          else
929             return $ Right mod_guts
930
931     Nothing -> panic "compileToCoreModule: target FilePath not found in\
932                           module dependency graph"
933  where -- two versions, based on whether we simplify (thus run tidyProgram,
934        -- which returns a (CgGuts, ModDetails) pair, or not (in which case
935        -- we just have a ModGuts.
936        gutsToCoreModule :: SafeHaskellMode
937                         -> Either (CgGuts, ModDetails) ModGuts
938                         -> CoreModule
939        gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule {
940          cm_module = cg_module cg,
941          cm_types  = md_types md,
942          cm_binds  = cg_binds cg,
943          cm_safe   = safe_mode
944        }
945        gutsToCoreModule safe_mode (Right mg) = CoreModule {
946          cm_module  = mg_module mg,
947          cm_types   = typeEnvFromEntities (bindersOfBinds (mg_binds mg))
948                                           (mg_tcs mg)
949                                           (mg_fam_insts mg),
950          cm_binds   = mg_binds mg,
951          cm_safe    = safe_mode
952         }
953
954-- %************************************************************************
955-- %*                                                                      *
956--             Inspecting the session
957-- %*                                                                      *
958-- %************************************************************************
959
960-- | Get the module dependency graph.
961getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
962getModuleGraph = liftM hsc_mod_graph getSession
963
964-- | Determines whether a set of modules requires Template Haskell.
965--
966-- Note that if the session's 'DynFlags' enabled Template Haskell when
967-- 'depanal' was called, then each module in the returned module graph will
968-- have Template Haskell enabled whether it is actually needed or not.
969needsTemplateHaskell :: ModuleGraph -> Bool
970needsTemplateHaskell ms =
971    any (xopt Opt_TemplateHaskell . ms_hspp_opts) ms
972
973-- | Return @True@ <==> module is loaded.
974isLoaded :: GhcMonad m => ModuleName -> m Bool
975isLoaded m = withSession $ \hsc_env ->
976  return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
977
978-- | Return the bindings for the current interactive session.
979getBindings :: GhcMonad m => m [TyThing]
980getBindings = withSession $ \hsc_env ->
981    return $ icInScopeTTs $ hsc_IC hsc_env
982
983-- | Return the instances for the current interactive session.
984getInsts :: GhcMonad m => m ([ClsInst], [FamInst])
985getInsts = withSession $ \hsc_env ->
986    return $ ic_instances (hsc_IC hsc_env)
987
988getPrintUnqual :: GhcMonad m => m PrintUnqualified
989getPrintUnqual = withSession $ \hsc_env ->
990  return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))
991
992-- | Container for information about a 'Module'.
993data ModuleInfo = ModuleInfo {
994        minf_type_env  :: TypeEnv,
995        minf_exports   :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
996        minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
997        minf_instances :: [ClsInst],
998        minf_iface     :: Maybe ModIface,
999        minf_safe      :: SafeHaskellMode
1000#ifdef GHCI
1001       ,minf_modBreaks :: ModBreaks
1002#endif
1003  }
1004        -- We don't want HomeModInfo here, because a ModuleInfo applies
1005        -- to package modules too.
1006
1007-- | Request information about a loaded 'Module'
1008getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)  -- XXX: Maybe X
1009getModuleInfo mdl = withSession $ \hsc_env -> do
1010  let mg = hsc_mod_graph hsc_env
1011  if mdl `elem` map ms_mod mg
1012        then liftIO $ getHomeModuleInfo hsc_env mdl
1013        else do
1014  {- if isHomeModule (hsc_dflags hsc_env) mdl
1015        then return Nothing
1016        else -} liftIO $ getPackageModuleInfo hsc_env mdl
1017   -- ToDo: we don't understand what the following comment means.
1018   --    (SDM, 19/7/2011)
1019   -- getPackageModuleInfo will attempt to find the interface, so
1020   -- we don't want to call it for a home module, just in case there
1021   -- was a problem loading the module and the interface doesn't
1022   -- exist... hence the isHomeModule test here.  (ToDo: reinstate)
1023
1024getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
1025#ifdef GHCI
1026getPackageModuleInfo hsc_env mdl
1027  = do  eps <- hscEPS hsc_env
1028        iface <- hscGetModuleInterface hsc_env mdl
1029        let 
1030            avails = mi_exports iface
1031            names  = availsToNameSet avails
1032            pte    = eps_PTE eps
1033            tys    = [ ty | name <- concatMap availNames avails,
1034                            Just ty <- [lookupTypeEnv pte name] ]
1035        --
1036        return (Just (ModuleInfo {
1037                        minf_type_env  = mkTypeEnv tys,
1038                        minf_exports   = names,
1039                        minf_rdr_env   = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
1040                        minf_instances = error "getModuleInfo: instances for package module unimplemented",
1041                        minf_iface     = Just iface,
1042                        minf_safe      = getSafeMode $ mi_trust iface,
1043                        minf_modBreaks = emptyModBreaks 
1044                }))
1045#else
1046-- bogusly different for non-GHCI (ToDo)
1047getPackageModuleInfo _hsc_env _mdl = do
1048  return Nothing
1049#endif
1050
1051getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
1052getHomeModuleInfo hsc_env mdl = 
1053  case lookupUFM (hsc_HPT hsc_env) (moduleName mdl) of
1054    Nothing  -> return Nothing
1055    Just hmi -> do
1056      let details = hm_details hmi
1057          iface   = hm_iface hmi
1058      return (Just (ModuleInfo {
1059                        minf_type_env  = md_types details,
1060                        minf_exports   = availsToNameSet (md_exports details),
1061                        minf_rdr_env   = mi_globals $! hm_iface hmi,
1062                        minf_instances = md_insts details,
1063                        minf_iface     = Just iface,
1064                        minf_safe      = getSafeMode $ mi_trust iface
1065#ifdef GHCI
1066                       ,minf_modBreaks = getModBreaks hmi
1067#endif
1068                        }))
1069
1070-- | The list of top-level entities defined in a module
1071modInfoTyThings :: ModuleInfo -> [TyThing]
1072modInfoTyThings minf = typeEnvElts (minf_type_env minf)
1073
1074modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
1075modInfoTopLevelScope minf
1076  = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
1077
1078modInfoExports :: ModuleInfo -> [Name]
1079modInfoExports minf = nameSetToList $! minf_exports minf
1080
1081-- | Returns the instances defined by the specified module.
1082-- Warning: currently unimplemented for package modules.
1083modInfoInstances :: ModuleInfo -> [ClsInst]
1084modInfoInstances = minf_instances
1085
1086modInfoIsExportedName :: ModuleInfo -> Name -> Bool
1087modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
1088
1089mkPrintUnqualifiedForModule :: GhcMonad m =>
1090                               ModuleInfo
1091                            -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X
1092mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do
1093  return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf))
1094
1095modInfoLookupName :: GhcMonad m =>
1096                     ModuleInfo -> Name
1097                  -> m (Maybe TyThing) -- XXX: returns a Maybe X
1098modInfoLookupName minf name = withSession $ \hsc_env -> do
1099   case lookupTypeEnv (minf_type_env minf) name of
1100     Just tyThing -> return (Just tyThing)
1101     Nothing      -> do
1102       eps <- liftIO $ readIORef (hsc_EPS hsc_env)
1103       return $! lookupType (hsc_dflags hsc_env) 
1104                            (hsc_HPT hsc_env) (eps_PTE eps) name
1105
1106modInfoIface :: ModuleInfo -> Maybe ModIface
1107modInfoIface = minf_iface
1108
1109-- | Retrieve module safe haskell mode
1110modInfoSafe :: ModuleInfo -> SafeHaskellMode
1111modInfoSafe = minf_safe
1112
1113#ifdef GHCI
1114modInfoModBreaks :: ModuleInfo -> ModBreaks
1115modInfoModBreaks = minf_modBreaks 
1116#endif
1117
1118isDictonaryId :: Id -> Bool
1119isDictonaryId id
1120  = case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau }
1121
1122-- | Looks up a global name: that is, any top-level name in any
1123-- visible module.  Unlike 'lookupName', lookupGlobalName does not use
1124-- the interactive context, and therefore does not require a preceding
1125-- 'setContext'.
1126lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
1127lookupGlobalName name = withSession $ \hsc_env -> do
1128   liftIO $ lookupTypeHscEnv hsc_env name
1129
1130findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
1131findGlobalAnns deserialize target = withSession $ \hsc_env -> do
1132    ann_env <- liftIO $ prepareAnnotations hsc_env Nothing
1133    return (findAnns deserialize ann_env target)
1134
1135#ifdef GHCI
1136-- | get the GlobalRdrEnv for a session
1137getGRE :: GhcMonad m => m GlobalRdrEnv
1138getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
1139#endif
1140
1141-- -----------------------------------------------------------------------------
1142
1143-- | Return all /external/ modules available in the package database.
1144-- Modules from the current session (i.e., from the 'HomePackageTable') are
1145-- not included.
1146packageDbModules :: GhcMonad m =>
1147                    Bool  -- ^ Only consider exposed packages.
1148                 -> m [Module]
1149packageDbModules only_exposed = do
1150   dflags <- getSessionDynFlags
1151   let pkgs = eltsUFM (pkgIdMap (pkgState dflags))
1152   return $
1153     [ mkModule pid modname | p <- pkgs
1154                            , not only_exposed || exposed p
1155                            , let pid = packageConfigId p
1156                            , modname <- exposedModules p ]
1157
1158-- -----------------------------------------------------------------------------
1159-- Misc exported utils
1160
1161dataConType :: DataCon -> Type
1162dataConType dc = idType (dataConWrapId dc)
1163
1164-- | print a 'NamedThing', adding parentheses if the name is an operator.
1165pprParenSymName :: NamedThing a => a -> SDoc
1166pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
1167
1168-- ----------------------------------------------------------------------------
1169
1170#if 0
1171
1172-- ToDo:
1173--   - Data and Typeable instances for HsSyn.
1174
1175-- ToDo: check for small transformations that happen to the syntax in
1176-- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
1177
1178-- ToDo: maybe use TH syntax instead of IfaceSyn?  There's already a way
1179-- to get from TyCons, Ids etc. to TH syntax (reify).
1180
1181-- :browse will use either lm_toplev or inspect lm_interface, depending
1182-- on whether the module is interpreted or not.
1183
1184#endif
1185
1186-- Extract the filename, stringbuffer content and dynflags associed to a module
1187--
1188-- XXX: Explain pre-conditions
1189getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)
1190getModuleSourceAndFlags mod = do
1191  m <- getModSummary (moduleName mod)
1192  case ml_hs_file $ ms_location m of
1193    Nothing -> throw $ mkApiErr (text "No source available for module " <+> ppr mod)
1194    Just sourceFile -> do
1195        source <- liftIO $ hGetStringBuffer sourceFile
1196        return (sourceFile, source, ms_hspp_opts m)
1197
1198
1199-- | Return module source as token stream, including comments.
1200--
1201-- The module must be in the module graph and its source must be available.
1202-- Throws a 'HscTypes.SourceError' on parse error.
1203getTokenStream :: GhcMonad m => Module -> m [Located Token]
1204getTokenStream mod = do
1205  (sourceFile, source, flags) <- getModuleSourceAndFlags mod
1206  let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
1207  case lexTokenStream source startLoc flags of
1208    POk _ ts  -> return ts
1209    PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
1210
1211-- | Give even more information on the source than 'getTokenStream'
1212-- This function allows reconstructing the source completely with
1213-- 'showRichTokenStream'.
1214getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
1215getRichTokenStream mod = do
1216  (sourceFile, source, flags) <- getModuleSourceAndFlags mod
1217  let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
1218  case lexTokenStream source startLoc flags of
1219    POk _ ts -> return $ addSourceToTokens startLoc source ts
1220    PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
1221
1222-- | Given a source location and a StringBuffer corresponding to this
1223-- location, return a rich token stream with the source associated to the
1224-- tokens.
1225addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
1226                  -> [(Located Token, String)]
1227addSourceToTokens _ _ [] = []
1228addSourceToTokens loc buf (t@(L span _) : ts)
1229    = case span of
1230      UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts
1231      RealSrcSpan s   -> (t,str) : addSourceToTokens newLoc newBuf ts
1232        where
1233          (newLoc, newBuf, str) = go "" loc buf
1234          start = realSrcSpanStart s
1235          end = realSrcSpanEnd s
1236          go acc loc buf | loc < start = go acc nLoc nBuf
1237                         | start <= loc && loc < end = go (ch:acc) nLoc nBuf
1238                         | otherwise = (loc, buf, reverse acc)
1239              where (ch, nBuf) = nextChar buf
1240                    nLoc = advanceSrcLoc loc ch
1241
1242
1243-- | Take a rich token stream such as produced from 'getRichTokenStream' and
1244-- return source code almost identical to the original code (except for
1245-- insignificant whitespace.)
1246showRichTokenStream :: [(Located Token, String)] -> String
1247showRichTokenStream ts = go startLoc ts ""
1248    where sourceFile = getFile $ map (getLoc . fst) ts
1249          getFile [] = panic "showRichTokenStream: No source file found"
1250          getFile (UnhelpfulSpan _ : xs) = getFile xs
1251          getFile (RealSrcSpan s : _) = srcSpanFile s
1252          startLoc = mkRealSrcLoc sourceFile 1 1
1253          go _ [] = id
1254          go loc ((L span _, str):ts)
1255              = case span of
1256                UnhelpfulSpan _ -> go loc ts
1257                RealSrcSpan s
1258                 | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++)
1259                                       . (str ++)
1260                                       . go tokEnd ts
1261                 | otherwise -> ((replicate (tokLine - locLine) '\n') ++)
1262                              . ((replicate tokCol ' ') ++)
1263                              . (str ++)
1264                              . go tokEnd ts
1265                  where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
1266                        (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s)
1267                        tokEnd = realSrcSpanEnd s
1268
1269-- -----------------------------------------------------------------------------
1270-- Interactive evaluation
1271
1272-- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
1273-- filesystem and package database to find the corresponding 'Module',
1274-- using the algorithm that is used for an @import@ declaration.
1275findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
1276findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
1277  let 
1278    dflags   = hsc_dflags hsc_env
1279    this_pkg = thisPackage dflags
1280  --
1281  case maybe_pkg of
1282    Just pkg | fsToPackageId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
1283      res <- findImportedModule hsc_env mod_name maybe_pkg
1284      case res of
1285        Found _ m -> return m
1286        err       -> noModError dflags noSrcSpan mod_name err
1287    _otherwise -> do
1288      home <- lookupLoadedHomeModule mod_name
1289      case home of
1290        Just m  -> return m
1291        Nothing -> liftIO $ do
1292           res <- findImportedModule hsc_env mod_name maybe_pkg
1293           case res of
1294             Found loc m | modulePackageId m /= this_pkg -> return m
1295                         | otherwise -> modNotLoadedError m loc
1296             err -> noModError dflags noSrcSpan mod_name err
1297
1298modNotLoadedError :: Module -> ModLocation -> IO a
1299modNotLoadedError m loc = ghcError $ CmdLineError $ showSDoc $
1300   text "module is not loaded:" <+> 
1301   quotes (ppr (moduleName m)) <+>
1302   parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
1303
1304-- | Like 'findModule', but differs slightly when the module refers to
1305-- a source file, and the file has not been loaded via 'load'.  In
1306-- this case, 'findModule' will throw an error (module not loaded),
1307-- but 'lookupModule' will check to see whether the module can also be
1308-- found in a package, and if so, that package 'Module' will be
1309-- returned.  If not, the usual module-not-found error will be thrown.
1310--
1311lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
1312lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)
1313lookupModule mod_name Nothing = withSession $ \hsc_env -> do
1314  home <- lookupLoadedHomeModule mod_name
1315  case home of
1316    Just m  -> return m
1317    Nothing -> liftIO $ do
1318      res <- findExposedPackageModule hsc_env mod_name Nothing
1319      case res of
1320        Found _ m -> return m
1321        err       -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
1322
1323lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
1324lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->
1325  case lookupUFM (hsc_HPT hsc_env) mod_name of
1326    Just mod_info      -> return (Just (mi_module (hm_iface mod_info)))
1327    _not_a_home_module -> return Nothing
1328
1329#ifdef GHCI
1330-- | Check that a module is safe to import (according to Safe Haskell).
1331--
1332-- We return True to indicate the import is safe and False otherwise
1333-- although in the False case an error may be thrown first.
1334isModuleTrusted :: GhcMonad m => Module -> m Bool
1335isModuleTrusted m = withSession $ \hsc_env ->
1336    liftIO $ hscCheckSafe hsc_env m noSrcSpan
1337
1338-- | EXPERIMENTAL: DO NOT USE.
1339--
1340-- Set the monad GHCi lifts user statements into.
1341--
1342-- Checks that a type (in string form) is an instance of the
1343-- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is,
1344-- throws an error otherwise.
1345{-# WARNING setGHCiMonad "This is experimental! Don't use." #-}
1346setGHCiMonad :: GhcMonad m => String -> m ()
1347setGHCiMonad name = withSession $ \hsc_env -> do
1348    ty <- liftIO $ hscIsGHCiMonad hsc_env name
1349    modifySession $ \s ->
1350        let ic = (hsc_IC s) { ic_monad = ty }
1351        in s { hsc_IC = ic }
1352
1353getHistorySpan :: GhcMonad m => History -> m SrcSpan
1354getHistorySpan h = withSession $ \hsc_env ->
1355    return $ InteractiveEval.getHistorySpan hsc_env h
1356
1357obtainTermFromVal :: GhcMonad m => Int ->  Bool -> Type -> a -> m Term
1358obtainTermFromVal bound force ty a = withSession $ \hsc_env ->
1359    liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
1360
1361obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
1362obtainTermFromId bound force id = withSession $ \hsc_env ->
1363    liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
1364
1365#endif
1366
1367-- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
1368-- entity known to GHC, including 'Name's defined using 'runStmt'.
1369lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
1370lookupName name =
1371     withSession $ \hsc_env -> 
1372       liftIO $ hscTcRcLookupName hsc_env name
1373
1374-- -----------------------------------------------------------------------------
1375-- Pure API
1376
1377-- | A pure interface to the module parser.
1378--
1379parser :: String         -- ^ Haskell module source text (full Unicode is supported)
1380       -> DynFlags       -- ^ the flags
1381       -> FilePath       -- ^ the filename (for source locations)
1382       -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))
1383
1384parser str dflags filename = 
1385   let
1386       loc  = mkRealSrcLoc (mkFastString filename) 1 1
1387       buf  = stringToStringBuffer str
1388   in
1389   case unP Parser.parseModule (mkPState dflags buf loc) of
1390
1391     PFailed span err   -> 
1392         Left (unitBag (mkPlainErrMsg span err))
1393
1394     POk pst rdr_module ->
1395         let (warns,_) = getMessages pst in
1396         Right (warns, rdr_module)
Note: See TracBrowser for help on using the browser.