+flagsFromCabal :: FilePath -> IO [String]
+flagsFromCabal distPref = do
+ lbi <- getPersistBuildConfig distPref
+ let pd = localPkgDescr lbi
+ case library pd of
+ Nothing -> error "no library"
+ Just lib ->
+ let bi = libBuildInfo lib
+ odir = buildDir lbi
+ opts = ghcOptions lbi bi odir
+ in return opts
+
+----------------------------------------------------------------
+--- LOADING HASKELL SOURCE
+--- (these bits actually run the compiler and produce abstract syntax)
+
+safeLoad :: LoadHowMuch -> Ghc SuccessFlag
+-- like GHC.load, but does not stop process on exception
+safeLoad mode = do
+ _dflags <- getSessionDynFlags
+ ghandle (\(e :: SomeException) -> liftIO (print e) >> return Failed ) $
+ handleSourceError (\e -> printExceptionAndWarnings e >> return Failed) $
+ load mode
+
+
+targetsAtOneGo :: [FileName] -> (Maybe Handle, Maybe Handle) -> Ghc ()
+-- load a list of targets
+targetsAtOneGo hsfiles handles = do
+ targets <- mapM (\f -> guessTarget f Nothing) hsfiles
+ setTargets targets
+ modgraph <- depanal [] False
+ let mods = flattenSCCs $ topSortModuleGraph False modgraph Nothing
+ graphData mods handles
+
+fileTarget :: FileName -> Target
+fileTarget filename = Target (TargetFile filename Nothing) True Nothing
+
+---------------------------------------------------------------
+----- CRAWLING ABSTRACT SYNTAX TO SNAFFLE THE DEFINITIONS -----
+
+graphData :: ModuleGraph -> (Maybe Handle, Maybe Handle) -> Ghc ()
+graphData graph handles = do
+ mapM_ foundthings graph
+ where foundthings ms =
+ let filename = msHsFilePath ms
+ modname = moduleName $ ms_mod ms
+ in handleSourceError (\e -> do
+ printExceptionAndWarnings e
+ liftIO $ exitWith (ExitFailure 1)) $
+ do liftIO $ putStrLn ("loading " ++ filename)
+ mod <- loadModule =<< typecheckModule =<< parseModule ms
+ case mod of
+ _ | isBootSummary ms -> return ()
+ _ | Just s <- renamedSource mod ->
+ liftIO (writeTagsData handles =<< fileData filename modname s)
+ _otherwise ->
+ liftIO $ exitWith (ExitFailure 1)
+
+fileData :: FileName -> ModuleName -> RenamedSource -> IO FileData
+fileData filename modname (group, _imports, _lie, _doc, _haddock) = do
+ -- lie is related to type checking and so is irrelevant
+ -- imports contains import declarations and no definitions
+ -- doc and haddock seem haddock-related; let's hope to ignore them
+ ls <- lines `fmap` readFile filename
+ let line_map = M.fromAscList $ zip [1..] ls
+ evaluate line_map
+ return $ FileData filename (boundValues modname group) line_map
+
+boundValues :: ModuleName -> HsGroup Name -> [FoundThing]
+-- ^Finds all the top-level definitions in a module
+boundValues mod group =
+ let vals = case hs_valds group of
+ ValBindsOut nest _sigs ->
+ [ x | (_rec, binds) <- nest, bind <- bagToList binds,
+ x <- boundThings mod bind ]
+ _other -> error "boundValues"
+ tys = concat $ map tyBound (hs_tyclds group)
+ where tyBound ltcd = case unLoc ltcd of
+ ForeignType { tcdLName = n } -> [found n]
+ TyData { tcdLName = tycon, tcdCons = cons } ->
+ dataNames tycon cons
+ TySynonym { tcdLName = n } -> [found n]
+ ClassDecl { tcdLName = n } -> [found n]
+ _ -> error "boundValues: tys"
+ fors = concat $ map forBound (hs_fords group)
+ where forBound lford = case unLoc lford of
+ ForeignImport n _ _ -> [found n]
+ ForeignExport { } -> []
+ in vals ++ tys ++ fors
+ where dataNames tycon cons = found tycon : map conName cons
+ conName td = found $ con_name $ unLoc td
+ found = foundOfLName mod
+
+startOfLocated :: Located a -> SrcLoc
+startOfLocated lHs = srcSpanStart $ getLoc lHs
+
+foundOfLName :: ModuleName -> Located Name -> FoundThing
+foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
+
+boundThings :: ModuleName -> LHsBind Name -> [FoundThing]
+boundThings modname lbinding =
+ case unLoc lbinding of
+ FunBind { fun_id = id } -> [thing id]
+ PatBind { pat_lhs = lhs } -> patThings lhs []
+ VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
+ AbsBinds { } -> [] -- nothing interesting in a type abstraction
+ where thing = foundOfLName modname
+ patThings lpat tl =
+ let loc = startOfLocated lpat
+ lid id = FoundThing modname (getOccString id) loc
+ in case unLoc lpat of
+ WildPat _ -> tl
+ VarPat name -> lid name : tl
+ VarPatOut name _ -> lid name : tl -- XXX need help here
+ LazyPat p -> patThings p tl
+ AsPat id p -> patThings p (thing id : tl)
+ ParPat p -> patThings p tl
+ BangPat p -> patThings p tl
+ ListPat ps _ -> foldr patThings tl ps
+ TuplePat ps _ _ -> foldr patThings tl ps
+ PArrPat ps _ -> foldr patThings tl ps
+ ConPatIn _ conargs -> conArgs conargs tl
+ ConPatOut _ _ _ _ conargs _ -> conArgs conargs tl
+ LitPat _ -> tl
+#if __GLASGOW_HASKELL__ > 608
+ NPat _ _ _ -> tl -- form of literal pattern?
+#else
+ NPat _ _ _ _ -> tl -- form of literal pattern?
+#endif
+ NPlusKPat id _ _ _ -> thing id : tl
+ TypePat _ -> tl -- XXX need help here
+ SigPatIn p _ -> patThings p tl
+ SigPatOut p _ -> patThings p tl
+ _ -> error "boundThings"
+ conArgs (PrefixCon ps) tl = foldr patThings tl ps
+ conArgs (RecCon (HsRecFields { rec_flds = flds })) tl
+ = foldr (\f tl' -> patThings (hsRecFieldArg f) tl') tl flds
+ conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl