diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -9,6 +9,7 @@ import Data.List (find, isPrefixOf) import qualified Data.List as L import Data.Maybe (catMaybes) +import qualified Data.Text.IO as T import DynFlags (parseDynamicFlagsCmdLine, updOptLevel) import qualified EnumSet as EnumSet import qualified GHC as GHC @@ -39,10 +40,8 @@ " index - list all dependency packages, modules, terms and types.\n" ++ " packages /path/to/dir - list all packages that are referenced by sources in this dir.\n" --- Possible backends: --- --- https://github.com/mpickering/hie-bios --- http://hackage.haskell.org/package/cabal-helper +-- TODO support an option to search for .ghc.{flags, path} files and use them + main :: IO () main = do (break ("--" ==) -> (args, filterFlags -> flags)) <- getArgs @@ -73,12 +72,12 @@ homeModules <- inferHomeModules GHC.setTargets $ mkTarget <$> homeModules - let respond rest (S.filterNil . S.toSexp -> a) = liftIO . putStrLn $ + let respond rest (S.filterNil . S.toSexp -> a) = liftIO $ if (elem "--json" rest) then case sexpToJson a of Left err -> error err - Right j -> encodeJson dflags' j - else S.render a + Right j -> putStrLn $ encodeJson dflags' j + else T.putStrLn $ S.render a case args of "imports" : file : rest -> do quals <- imports file @@ -89,6 +88,7 @@ "packages" : rest -> do hits <- packages respond rest hits + -- TODO make parseTypes available on the command line _ -> liftIO $ error "invalid parameters" diff --git a/hsinspect.cabal b/hsinspect.cabal --- a/hsinspect.cabal +++ b/hsinspect.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hsinspect -version: 0.0.13 +version: 0.0.14 synopsis: Inspect Haskell source files. license: GPL-3.0-or-later license-file: LICENSE @@ -27,8 +27,10 @@ , base >=4.11 && <5 , containers , directory + , filepath , ghc , ghc-boot + , text , time ghc-options: -Wall -Werror=missing-home-modules -Werror=orphans @@ -56,5 +58,6 @@ HsInspect.Json HsInspect.Packages HsInspect.Sexp + HsInspect.TypeParser HsInspect.Util HsInspect.Workarounds diff --git a/library/HsInspect/Imports.hs b/library/HsInspect/Imports.hs --- a/library/HsInspect/Imports.hs +++ b/library/HsInspect/Imports.hs @@ -10,6 +10,8 @@ import Data.List (sort) import Data.Maybe (fromJust) +import Data.Text (Text) +import qualified Data.Text as T import qualified GHC as GHC import HscTypes (TargetId(..)) import HsInspect.Sexp @@ -41,12 +43,12 @@ let ln = if is_qual then Nothing - else Just $ showGhc gre_name + else Just . T.pack $ showGhc gre_name lqn = if is_mod == is_as then Nothing - else Just $ showGhc is_as ++ "." ++ showGhc gre_name - fqn = showGhc is_mod ++ "." ++ showGhc gre_name + else Just . T.pack $ showGhc is_as ++ "." ++ showGhc gre_name + fqn = T.pack $ showGhc is_mod ++ "." ++ showGhc gre_name in Qualified ln lqn fqn -- 1. local name @@ -54,15 +56,12 @@ -- 3. fully qualified name data Qualified = Qualified - (Maybe String) - (Maybe String) - String + (Maybe Text) + (Maybe Text) + Text deriving (Eq, Ord, Show) - +{- BOILERPLATE Qualified ToSexp field=[local,qual,full] -} +{- BOILERPLATE START -} instance ToSexp Qualified where - toSexp (Qualified ln lqn fqn) = - alist - [ ("local", toSexp ln), - ("qual", toSexp lqn), - ("full", toSexp fqn) - ] + toSexp (Qualified p_1_1 p_1_2 p_1_3) = alist [("local", toSexp p_1_1), ("qual", toSexp p_1_2), ("full", toSexp p_1_3)] +{- BOILERPLATE END -} diff --git a/library/HsInspect/Index.hs b/library/HsInspect/Index.hs --- a/library/HsInspect/Index.hs +++ b/library/HsInspect/Index.hs @@ -14,14 +14,14 @@ import qualified ConLike as GHC import Control.Monad import Control.Monad.IO.Class -import Data.Coerce import Data.List (isInfixOf, sort) import Data.Maybe (catMaybes, mapMaybe, maybeToList) import Data.Set (Set) import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T import qualified DataCon as GHC import qualified DynFlags as GHC -import FastString (unpackFS) import qualified GHC import GHC.PackageDb import qualified GHC.PackageDb as GHC @@ -119,7 +119,7 @@ let entries = sort $ uncurry mkEntries <$> symbols mkEntries m things = ModuleEntries (moduleName m) (sort $ renderThings things) renderThings things = catMaybes $ (uncurry $ tyrender dflags unitid) <$> things - pure $ PackageEntries srcid inplace entries haddocks + pure $ PackageEntries srcid inplace entries (T.pack <$> haddocks) -- for a .hi file returns the module and a list of all things (with types -- resolved) in that module and their original module if they are re-exported. @@ -149,8 +149,8 @@ tyrender dflags unitid m' (GHC.AGlobal thing) = let m = mkExported dflags unitid <$> m' - shw :: GHC.Outputable m => m -> String - shw = showPpr dflags + shw :: GHC.Outputable m => m -> Text + shw = T.pack . showPpr dflags in case thing of (GHC.AnId var) -> Just $ IdEntry m (shw $ GHC.idName var) @@ -160,21 +160,43 @@ (shw $ GHC.dataConUserType dc) (GHC.AConLike (GHC.PatSynCon ps)) -> Just $ PatSynEntry m (shw $ GHC.getName ps) - (showSDoc dflags $ GHC.pprPatSynType ps ) + (T.pack . showSDoc dflags $ GHC.pprPatSynType ps ) (GHC.ATyCon tc) -> Just $ TyConEntry m (shw $ GHC.tyConName tc) (shw $ GHC.tyConFlavour tc) _ -> Nothing tyrender _ _ _ _ = Nothing -data Entry = IdEntry (Maybe Exported) String String -- ^ name type - | ConEntry (Maybe Exported) String String -- ^ name type - | PatSynEntry (Maybe Exported) String String -- ^ name orig - | TyConEntry (Maybe Exported) String String -- ^ type flavour +data Entry = IdEntry (Maybe Exported) Text Text -- ^ name type + | ConEntry (Maybe Exported) Text Text -- ^ name type + | PatSynEntry (Maybe Exported) Text Text -- ^ name orig + | TyConEntry (Maybe Exported) Text Text -- ^ type flavour deriving (Eq, Ord) +{- BOILERPLATE Entry ToSexp + field={IdEntry:[export,name,type], + ConEntry:[export,name,type], + PatSynEntry:[export,name,type], + TyConEntry:[export,type,flavour]} + class={IdEntry:id, + ConEntry:con, + PatSynEntry:pat, + TyConEntry:tycon} +-} +{- BOILERPLATE START -} +instance ToSexp Entry where + toSexp (IdEntry p_1_1 p_1_2 p_1_3) = alist $ ("class", "id") : [("export", toSexp p_1_1), ("name", toSexp p_1_2), ("type", toSexp p_1_3)] + toSexp (ConEntry p_1_1 p_1_2 p_1_3) = alist $ ("class", "con") : [("export", toSexp p_1_1), ("name", toSexp p_1_2), ("type", toSexp p_1_3)] + toSexp (PatSynEntry p_1_1 p_1_2 p_1_3) = alist $ ("class", "pat") : [("export", toSexp p_1_1), ("name", toSexp p_1_2), ("type", toSexp p_1_3)] + toSexp (TyConEntry p_1_1 p_1_2 p_1_3) = alist $ ("class", "tycon") : [("export", toSexp p_1_1), ("type", toSexp p_1_2), ("flavour", toSexp p_1_3)] +{- BOILERPLATE END -} data ModuleEntries = ModuleEntries GHC.ModuleName [Entry] deriving (Eq, Ord) +{- BOILERPLATE ModuleEntries ToSexp field=[module,ids] -} +{- BOILERPLATE START -} +instance ToSexp ModuleEntries where + toSexp (ModuleEntries p_1_1 p_1_2) = alist [("module", toSexp p_1_1), ("ids", toSexp p_1_2)] +{- BOILERPLATE END -} -- The haddocks serve a dual purpose: not only do they point to where haddocks -- might be, they give a hint to the text editor where the sources for this @@ -182,15 +204,26 @@ -- -- Users should type `cabal haddock --enable-documentation` to populate the docs -- of their dependencies and local projects. -type Haddocks = [FilePath] +type Haddocks = [Text] -- Bool indicates if this is an -inplace package data PackageEntries = PackageEntries (Maybe SourcePackageId) Bool [ModuleEntries] Haddocks +{- BOILERPLATE PackageEntries ToSexp field=[srcid,inplace,modules,haddocks] -} +{- BOILERPLATE START -} +instance ToSexp PackageEntries where + toSexp (PackageEntries p_1_1 p_1_2 p_1_3 p_1_4) = alist [("srcid", toSexp p_1_1), ("inplace", toSexp p_1_2), ("modules", toSexp p_1_3), ("haddocks", toSexp p_1_4)] +{- BOILERPLATE END -} -- srcid is Nothing if it matches the re-export location data Exported = Exported (Maybe SourcePackageId) GHC.ModuleName deriving (Eq, Ord) +{- BOILERPLATE Exported ToSexp field=[srcid, module] -} +{- BOILERPLATE START -} +instance ToSexp Exported where + toSexp (Exported p_1_1 p_1_2) = alist [("srcid", toSexp p_1_1), ("module", toSexp p_1_2)] +{- BOILERPLATE END -} + mkExported :: GHC.DynFlags -> UnitId -> Module -> Exported mkExported dflags unitid m = let unitid' = moduleUnitId m @@ -200,44 +233,3 @@ else sourcePackageId <$> lookupPackage dflags unitid') (moduleName m) -instance ToSexp Exported where - toSexp (Exported srcid name) = alist - [ ("srcid", toSexp $ unpackFS . coerce <$> srcid), - ("module", SexpString . moduleNameString $ name) ] - -instance ToSexp Entry where - toSexp (IdEntry m name typ) = alist - [ ("name", SexpString name), - ("type", SexpString typ), - ("class", "id"), - ("export", toSexp m)] - toSexp (ConEntry m name typ) = alist - [ ("name", SexpString name), - ("type", SexpString typ), - ("class", "con"), - ("export", toSexp m) ] - toSexp (PatSynEntry m name typ) = alist - [ ("name", SexpString name), - ("type", SexpString typ), - ("class", "pat"), - ("export", toSexp m) ] - toSexp (TyConEntry m typ flavour) = alist - [ ("type", SexpString typ), - ("class", "tycon"), - ("flavour", SexpString flavour), - ("export", toSexp m) ] - -instance ToSexp ModuleEntries where - toSexp (ModuleEntries modl entries) = - alist - [ ("module", SexpString . moduleNameString $ modl), - ("ids", toSexp entries) - ] - -instance ToSexp PackageEntries where - toSexp (PackageEntries srcid inplace modules haddocks) = - alist - [ ("srcid", toSexp $ unpackFS . coerce <$> srcid), - ("inplace", toSexp inplace), - ("modules", toSexp modules), - ("haddocks", toSexp haddocks) ] diff --git a/library/HsInspect/Json.hs b/library/HsInspect/Json.hs --- a/library/HsInspect/Json.hs +++ b/library/HsInspect/Json.hs @@ -2,19 +2,22 @@ module HsInspect.Json where +import qualified Data.Text as T import qualified GHC as GHC import HsInspect.Sexp import Json import MonadUtils (mapSndM) import Outputable (showSDoc) +import Util (mapFst) encodeJson :: GHC.DynFlags -> JsonDoc -> String encodeJson dflags j = showSDoc dflags . renderJSON $ j sexpToJson :: Sexp -> Either String JsonDoc sexpToJson SexpNil = Right JSNull -sexpToJson (toAList -> Just kvs) = JSObject <$> mapSndM sexpToJson kvs +sexpToJson (toAList -> Just kvs) = JSObject . mapFst T.unpack <$> mapSndM sexpToJson kvs sexpToJson (toList -> Just as) = JSArray <$> traverse sexpToJson as sexpToJson (SexpCons _ _) = Left $ "cons cell has no JSON equivalent" -sexpToJson (SexpString s) = Right $ JSString s -sexpToJson (SexpSymbol s) = Right $ JSString s -- nobody said it had to roundtrip +sexpToJson (SexpString s) = Right . JSString $ T.unpack s +sexpToJson (SexpSymbol s) = Right . JSString $ T.unpack s -- nobody said it had to roundtrip +-- TODO write our own JSON repr to avoid a ghc dep and improve perf diff --git a/library/HsInspect/Packages.hs b/library/HsInspect/Packages.hs --- a/library/HsInspect/Packages.hs +++ b/library/HsInspect/Packages.hs @@ -7,7 +7,6 @@ import Control.Monad (join, void) import Control.Monad.IO.Class (liftIO) -import Data.Coerce import Data.List (delete, nub, nubBy, sort, (\\)) import Data.Maybe (catMaybes, mapMaybe) import Data.Set (Set) @@ -75,8 +74,8 @@ data PkgSummary = PkgSummary [GHC.PackageName] [GHC.PackageName] deriving (Eq, Ord) +{- BOILERPLATE PkgSummary ToSexp field=[used,unused] -} +{- BOILERPLATE START -} instance ToSexp PkgSummary where - toSexp (PkgSummary used unused) = - alist [ ("used", toS used) - , ("unused", toS unused) ] - where toS ids = toSexp $ unpackFS . coerce <$> ids + toSexp (PkgSummary p_1_1 p_1_2) = alist [("used", toSexp p_1_1), ("unused", toSexp p_1_2)] +{- BOILERPLATE END -} diff --git a/library/HsInspect/Sexp.hs b/library/HsInspect/Sexp.hs --- a/library/HsInspect/Sexp.hs +++ b/library/HsInspect/Sexp.hs @@ -1,20 +1,22 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE IncoherentInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -- | Very minimal ADT for outputting some S-Expressions. module HsInspect.Sexp where -import Data.List (intercalate) -import Data.String +import Data.String (IsString, fromString) +import Data.Text (Text) +import qualified Data.Text as T +import FastString (unpackFS) import Json (escapeJsonString) +import Module (ModuleName, moduleNameString) +import PackageConfig (PackageName(..), SourcePackageId(..)) data Sexp = SexpCons Sexp Sexp | SexpNil - | SexpString String - | SexpSymbol String + | SexpString Text + | SexpSymbol Text list :: [Sexp] -> Sexp list = foldr SexpCons SexpNil @@ -25,14 +27,14 @@ toList _ = Nothing instance IsString Sexp where - fromString = SexpSymbol + fromString = SexpSymbol . T.pack alist :: [(Sexp, Sexp)] -> Sexp alist els = list $ mkEl =<< els where mkEl (k, v) = [SexpCons k v] -toAList :: Sexp -> Maybe [(String, Sexp)] +toAList :: Sexp -> Maybe [(Text, Sexp)] toAList SexpNil = Just [] toAList (SexpCons (SexpCons (SexpSymbol k) v) rest) = ((k, v) :) <$> toAList rest toAList _ = Nothing @@ -43,8 +45,8 @@ instance ToSexp Sexp where toSexp = id -instance ToSexp String where - toSexp s = SexpString s +instance ToSexp Text where + toSexp = SexpString instance ToSexp Bool where toSexp False = SexpNil @@ -57,6 +59,15 @@ toSexp (Just a) = toSexp a toSexp Nothing = SexpNil +instance ToSexp SourcePackageId where + toSexp (SourcePackageId fs) = SexpString . T.pack $ unpackFS fs + +instance ToSexp ModuleName where + toSexp = SexpString . T.pack . moduleNameString + +instance ToSexp PackageName where + toSexp (PackageName fs) = SexpString . T.pack $ unpackFS fs + filterNil :: Sexp -> Sexp filterNil SexpNil = SexpNil filterNil (SexpCons (SexpCons (SexpSymbol _) SexpNil) rest) = filterNil rest @@ -64,9 +75,10 @@ filterNil (SexpString s) = SexpString s filterNil (SexpSymbol s) = SexpSymbol s -render :: Sexp -> String +render :: Sexp -> Text render SexpNil = "nil" -render (toList -> Just ss) = "(" ++ (intercalate " " $ render <$> ss) ++ ")\n" -render (SexpCons a b) = "(" ++ render a ++ " . " ++ render b ++ ")\n" -render (SexpString s) = "\"" ++ escapeJsonString s ++ "\"" -render (SexpSymbol a) = escapeJsonString a +render (toList -> Just ss) = "(" <> (T.intercalate " " $ render <$> ss) <> ")\n" +render (SexpCons a b) = "(" <> render a <> " . " <> render b <> ")\n" +render (SexpString s) = "\"" <> (T.pack . escapeJsonString $ T.unpack s) <> "\"" +render (SexpSymbol a) = T.pack . escapeJsonString $ T.unpack a +-- TODO write our own escapeString to avoid a ghc dep and improve perf diff --git a/library/HsInspect/TypeParser.hs b/library/HsInspect/TypeParser.hs new file mode 100644 --- /dev/null +++ b/library/HsInspect/TypeParser.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module HsInspect.TypeParser where + +import Control.Exception (throwIO) +import Data.List (sortOn) +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import GHC (HscEnv) +import qualified GHC as GHC +import qualified HsInspect.Util as H +import HsInspect.Workarounds (mkCppState) +import qualified Lexer as GHC +import qualified Outputable as GHC +import qualified Parser + +data Type = ProductType Text [Text] Text [Text] -- ^^ type tparams cons [param types] + | RecordType Text [Text] Text [(Text, Text)] -- ^^ type tparams cons [(fieldname, param type)] + | SumType Text [Text] [(Text, [Text])] -- ^^ type tparams [(cons, param types)] (no records) + deriving (Eq, Show) + +-- line, col (1-indexed) +data Pos = Pos Int Int + deriving (Eq, Ord, Show) + +data Comment = Comment Text Pos Pos -- text start end + deriving (Eq, Show) + +parseTypes :: HscEnv -> FilePath -> IO ([Type], [Comment]) +parseTypes env file = do + (pstate, _) <- mkCppState env file + let showGhc :: GHC.Outputable a => a -> Text + showGhc = T.pack . H.showGhc + case GHC.unP Parser.parseModule pstate of + -- ParseResult (Located (HsModule GhcPs)) + GHC.POk st (GHC.L _ hsmod) -> do + -- http://hackage.haskell.org/package/ghc-8.8.3/docs/HsDecls.html#t:HsDecl + -- [Located (HsDecl p)] + let decls = GHC.hsmodDecls hsmod + findType (GHC.L _ (GHC.TyClD _ (GHC.DataDecl _ tycon' (GHC.HsQTvs _ tparams') _ ddn))) = + let + tycon = showGhc tycon' + tparams = renderTparam <$> tparams' + renderField :: GHC.GenLocated l (GHC.ConDeclField GHC.GhcPs) -> (Text, Text) + renderField (GHC.L _ field) = (showGhc . head $ GHC.cd_fld_names field, showGhc $ GHC.cd_fld_type field) + renderArg :: GHC.LBangType GHC.GhcPs -> Text + renderArg (GHC.L _ arg) = showGhc arg + rhs = do + (GHC.L _ ddl) <- GHC.dd_cons ddn + case ddl of + GHC.ConDeclH98 _ cons _ _ _ (GHC.RecCon (GHC.L _ fields)) _ -> [(showGhc cons, Left $ renderField <$> fields)] + GHC.ConDeclH98 _ cons _ _ _ (GHC.InfixCon a1 a2) _ -> [(showGhc cons, Right $ [renderArg a1, renderArg a2])] + GHC.ConDeclH98 _ cons _ _ _ (GHC.PrefixCon args) _ -> [(showGhc cons, Right $ renderArg <$> args)] + _ -> [] -- GADTS + + in case rhs of + [] -> Nothing + [(cons, Right tpes)] -> Just $ ProductType tycon tparams cons tpes + [(cons, Left fields)] -> Just $ RecordType tycon tparams cons fields + mult -> Just . SumType tycon tparams $ render <$> mult + where + render (cons, Right args) = (cons, args) + render (cons, Left fargs) = (cons, snd <$> fargs) + + findType _ = Nothing + + renderTparam :: GHC.GenLocated l (GHC.HsTyVarBndr GHC.GhcPs) -> Text + renderTparam (GHC.L _ (GHC.UserTyVar _ p)) = showGhc p + renderTparam (GHC.L _ (GHC.KindedTyVar _ p _)) = showGhc p + renderTparam (GHC.L _ (GHC.XTyVarBndr _)) = "" + + extractComment (GHC.L (GHC.RealSrcSpan pos) c) = + let start = Pos (GHC.srcSpanStartLine pos) (GHC.srcSpanStartCol pos) + end = Pos (GHC.srcSpanEndLine pos) (GHC.srcSpanEndCol pos) + in (\str -> Comment (T.pack str) start end) <$> case c of + (GHC.AnnLineComment txt) -> Just txt + (GHC.AnnBlockComment txt) -> Just txt + _ -> Nothing + extractComment _ = Nothing + + types = mapMaybe findType decls + comments = mapMaybe extractComment $ GHC.comment_q st + + pure (types, sortOn (\(Comment _ s _) -> s) comments) + + GHC.PFailed _ _ err -> throwIO . userError $ "unable to parse " <> file <> " due to " <> GHC.showSDocUnsafe err diff --git a/library/HsInspect/Util.hs b/library/HsInspect/Util.hs --- a/library/HsInspect/Util.hs +++ b/library/HsInspect/Util.hs @@ -3,7 +3,7 @@ module HsInspect.Util where import Control.Monad.IO.Class -import Data.List (isSuffixOf, nub) +import Data.List (find, isSuffixOf, nub) import Data.Maybe (catMaybes) import Data.Set (Set) import qualified Data.Set as Set @@ -11,6 +11,7 @@ import qualified GHC as GHC import Outputable (Outputable, showPpr) import System.Directory (doesDirectoryExist, listDirectory, makeAbsolute) +import System.FilePath (takeDirectory, takeFileName, ()) homeSources :: GHC.GhcMonad m => m [FilePath] homeSources = do @@ -31,6 +32,18 @@ getModule GHC.Target{GHC.targetId} = case targetId of GHC.TargetModule m -> Just m GHC.TargetFile _ _ -> Nothing + +-- returns the first file that matches the predicate +locateDominating :: (String -> Bool) -> FilePath -> IO (Maybe FilePath) +locateDominating p dir = do + files <- listDirectory dir + let parent = takeDirectory dir + case find p $ takeFileName <$> files of + Just file -> pure . Just $ dir file + Nothing -> + if parent == dir + then pure Nothing + else locateDominating p parent walkSuffix :: String -> FilePath -> IO [FilePath] walkSuffix suffix dir = filter (suffix `isSuffixOf`) <$> walk dir diff --git a/library/HsInspect/Workarounds.hs b/library/HsInspect/Workarounds.hs --- a/library/HsInspect/Workarounds.hs +++ b/library/HsInspect/Workarounds.hs @@ -15,7 +15,7 @@ import FastString import qualified GHC as GHC import HeaderInfo (getOptions) -import HscTypes (Target(..), TargetId(..)) +import HscTypes (HscEnv, Target(..), TargetId(..)) #if MIN_VERSION_GLASGOW_HASKELL(8,10,1,0) import GHC.Hs.ImpExp (ImportDecl(..)) #else @@ -36,27 +36,31 @@ import TcRnTypes (tcg_rdr_env) #endif -parseHeader' :: GHC.GhcMonad m => FilePath -> m ([String], GHC.HsModule GHC.GhcPs) -parseHeader' file = do - sess <- GHC.getSession +-- applies CPP rules to the input file and extracts the pragmas, +-- a more portable alternative to GHC.hGetStringBuffer +mkCppState :: HscEnv -> FilePath -> IO (PState, [Located String]) +mkCppState sess file = do #if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) - pp <- liftIO $ preprocess sess file Nothing Nothing + pp <- preprocess sess file Nothing Nothing let (dflags, tmp) = case pp of Left _ -> error $ "preprocessing failed " <> show file Right success -> success #else - (dflags, tmp) <- liftIO $ preprocess sess (file, Nothing) + (dflags, tmp) <- preprocess sess (file, Nothing) #endif - full <- liftIO $ hGetStringBuffer tmp + full <- hGetStringBuffer tmp when (".hscpp" `isSuffixOf` tmp) $ liftIO . removeFile $ tmp let pragmas = getOptions dflags full file loc = mkRealSrcLoc (mkFastString file) 1 1 - -- FIXME strip out any GHC_OPTIONS that use -pgmF so we don't call external - -- tools. This also means we can lose the .ghc.path feature from the - -- plugin. (dflags', _, _) <- parseDynamicFilePragma dflags pragmas - case unP parseHeader (mkPState dflags' full loc) of + pure $ (mkPState dflags' full loc, pragmas) + +parseHeader' :: GHC.GhcMonad m => FilePath -> m ([String], GHC.HsModule GHC.GhcPs) +parseHeader' file = do + sess <- GHC.getSession + (pstate, pragmas) <- liftIO $ mkCppState sess file + case unP parseHeader pstate of POk _ (L _ hsmod) -> pure (unLoc <$> pragmas, hsmod) _ -> error $ "parseHeader failed for " <> file