hsinspect 0.0.14 → 0.0.15
raw patch · 10 files changed
+334/−159 lines, 10 filesdep +transformers
Dependencies added: transformers
Files
- exe/Main.hs +35/−66
- hsinspect.cabal +10/−4
- library/HsInspect/Context.hs +62/−0
- library/HsInspect/Json.hs +1/−0
- library/HsInspect/Packages.hs +0/−1
- library/HsInspect/Runner.hs +76/−0
- library/HsInspect/Sexp.hs +12/−0
- library/HsInspect/TypeParser.hs +0/−88
- library/HsInspect/Types.hs +132/−0
- library/HsInspect/Util.hs +6/−0
exe/Main.hs view
@@ -6,20 +6,15 @@ import qualified Config as GHC import Control.Monad import Control.Monad.IO.Class-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+import DynFlags (unsafeGlobalDynFlags) import HsInspect.Imports import HsInspect.Index import HsInspect.Json import HsInspect.Packages+import HsInspect.Runner import HsInspect.Sexp as S-import HsInspect.Util-import HsInspect.Workarounds+import HsInspect.Types import System.Environment (getArgs) import System.Exit @@ -32,78 +27,52 @@ help :: String help =- "hsinspect command ARGS [--json|help|version|ghc-version] -- [ghcflags]\n\n" +++ "hsinspect command ARGS [--json|ghcflags|help|version|ghc-version] -- [ghcflags]\n\n" ++ " `command ARGS' can be:\n\n" ++ " imports /path/to/file.hs - list the qualified imports for the file\n" ++ " along with their locally qualified (and\n" ++ " unqualified) names.\n" ++ " 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"---- TODO support an option to search for .ghc.{flags, path} files and use them+ " packages /path/to/dir - list all packages that are referenced by sources in this dir.\n\n" +++ " If --ghcflags is used, the flags and path will be automatically inferred from\n" +++ " .ghc.flags and .ghc.path files based on the file and current directory. Otherwise the\n" +++ " PATH, PWD and ghcflags must be provided." main :: IO () main = do- (break ("--" ==) -> (args, filterFlags -> flags)) <- getArgs+ (break ("--" ==) -> (args, explicit_flags)) <- getArgs when (elem "--help" args) $ (putStrLn help) >> exitWith ExitSuccess when (elem "--version" args) $ (putStrLn version) >> exitWith ExitSuccess when (elem "--ghc-version" args) $ (putStrLn GHC.cProjectVersion) >> exitWith ExitSuccess- let libdir = (drop 2) <$> find ("-B" `isPrefixOf`) flags- flags' = filter (not . ("-B" `isPrefixOf`)) flags- GHC.runGhc libdir $ do- dflags <- GHC.getSessionDynFlags- (updOptLevel 0 -> dflags', (GHC.unLoc <$>) -> _ghcargs, _) <-- liftIO $ parseDynamicFlagsCmdLine dflags (GHC.noLoc <$> flags')- void $ GHC.setSessionDynFlags dflags'- { GHC.hscTarget = GHC.HscInterpreted -- HscNothing compiles home modules, dunno why- , GHC.ghcLink = GHC.LinkInMemory -- required by HscInterpreted- , GHC.ghcMode = GHC.MkDepend -- prefer .hi to .hs for dependencies- , GHC.warningFlags = EnumSet.empty- , GHC.fatalWarningFlags = EnumSet.empty- } - -- The caller may have provided a list of home modules, but we do not trust- -- them because the ghcflags plugin does not keep the flags up to date for- -- incremental compiles.- let mkTarget m = GHC.Target (GHC.TargetModule m) True Nothing- homeModules <- inferHomeModules- GHC.setTargets $ mkTarget <$> homeModules-- let respond rest (S.filterNil . S.toSexp -> a) = liftIO $- if (elem "--json" rest)- then case sexpToJson a of- Left err -> error err- Right j -> putStrLn $ encodeJson dflags' j- else T.putStrLn $ S.render a- case args of- "imports" : file : rest -> do- quals <- imports file- respond rest quals- "index" : rest -> do- hits <- index- respond rest hits- "packages" : rest -> do- hits <- packages- respond rest hits- -- TODO make parseTypes available on the command line- _ ->- liftIO $ error "invalid parameters"+ flags <- if (elem "--ghcflags" args)+ then ghcflags_flags $ case args of+ "imports" : file : _ -> Just file+ "types" : file : _ -> Just file+ _ -> Nothing+ else pure explicit_flags -inferHomeModules :: GHC.GhcMonad m => m [GHC.ModuleName]-inferHomeModules = do- files <- homeSources- mmns <- traverse parseModuleName' files- let main' = GHC.mkModuleName "Main"- pure . L.nub . filter (main' /=) $ catMaybes mmns- -- stack often has duplicates+ let respond rest (S.filterNil . S.toSexp -> a) = liftIO $+ if (elem "--json" rest)+ then case sexpToJson a of+ Left err -> error err+ Right j -> putStrLn $ encodeJson unsafeGlobalDynFlags j+ else T.putStrLn $ S.render a --- removes the "+RTS ... -RTS" sections-filterFlags :: [String] -> [String]-filterFlags args = case span ("+RTS" /=) args of- (front, []) -> front- (front, _ : middle) -> case span ("-RTS" /=) middle of- (_, []) -> front -- bad input?- (_, _ : back) -> front <> back+ runGhcAndJamMasterShe flags $ case args of+ "imports" : file : rest -> do+ quals <- imports file+ respond rest quals+ "index" : rest -> do+ hits <- index+ respond rest hits+ "packages" : rest -> do+ hits <- packages+ respond rest hits+ "types" : file : rest -> do+ hits <- types file+ respond rest hits+ _ -> error "invalid parameters"
hsinspect.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: hsinspect-version: 0.0.14+version: 0.0.15 synopsis: Inspect Haskell source files. license: GPL-3.0-or-later license-file: LICENSE@@ -24,7 +24,7 @@ common deps build-depends:- , base >=4.11 && <5+ , base >=4.11 && <5 , containers , directory , filepath@@ -32,8 +32,12 @@ , ghc-boot , text , time+ , transformers - ghc-options: -Wall -Werror=missing-home-modules -Werror=orphans+ ghc-options:+ -Wall -Werror=missing-home-modules -Werror=orphans+ -Wno-name-shadowing+ default-language: Haskell2010 if flag(ghcflags)@@ -53,11 +57,13 @@ -- cabal-fmt: expand library exposed-modules:+ HsInspect.Context HsInspect.Imports HsInspect.Index HsInspect.Json HsInspect.Packages+ HsInspect.Runner HsInspect.Sexp- HsInspect.TypeParser+ HsInspect.Types HsInspect.Util HsInspect.Workarounds
+ library/HsInspect/Context.hs view
@@ -0,0 +1,62 @@+-- Calls to the hsinspect binary must have some context, which typically must be+-- discovered from the file that the user is currently visiting.+--+-- This module gathers the definition of the context and the logic to infer it,+-- which assumes that .cabal (or package.yaml) and .ghc.flags files are present.+module HsInspect.Context where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (ExceptT(..))+import Data.List (isSuffixOf)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import HsInspect.Util (locateDominating, locateDominatingDir)+import System.FilePath++data Context = Context+ { package_dir :: FilePath+ , ghcflags :: [Text]+ , ghcpath :: Text+ , srcdir :: FilePath+ }++findContext :: FilePath -> ExceptT String IO Context+findContext src = do+ ghcflags' <- discoverGhcflags src+ ghcpath' <- discoverGhcpath src+ let readWords file = T.words <$> readFile' file+ readFile' = liftIO . T.readFile+ ghcpath <- readFile' ghcpath'+ Context <$> discoverPackageDir src <*> readWords ghcflags' <*> pure ghcpath <*> pure (takeDirectory ghcflags')++-- c.f. haskell-tng--compile-dominating-package+discoverPackageDir :: FilePath -> ExceptT String IO FilePath+discoverPackageDir file = do+ let dir = takeDirectory file+ isCabal = (".cabal" `isSuffixOf`)+ isHpack = ("package.yaml" ==)+ failWithM "There must be a .cabal or package.yaml" $+ locateDominatingDir (\f -> isCabal f || isHpack f) dir++discoverGhcflags :: FilePath -> ExceptT String IO FilePath+discoverGhcflags file = do+ let dir = takeDirectory file+ failWithM ("There must be a .ghc.flags file. " ++ help_ghcflags) $+ locateDominating (".ghc.flags" ==) dir++discoverGhcpath :: FilePath -> ExceptT String IO FilePath+discoverGhcpath file = do+ let dir = takeDirectory file+ failWithM ("There must be a .ghc.path file. " ++ help_ghcflags) $+ locateDominating (".ghc.path" ==) dir++-- note that any formatting in these messages are stripped+help_ghcflags :: String+help_ghcflags = "The cause of this error could be that this package has not been compiled yet, \+ \or the ghcflags compiler plugin has not been installed for this package. \+ \See https://gitlab.com/tseenshe/hsinspect#installation for more details."++-- from Control.Error.Util+failWithM :: Applicative m => e -> m (Maybe a) -> ExceptT e m a+failWithM e ma = ExceptT $ (maybe (Left e) Right) <$> ma
library/HsInspect/Json.hs view
@@ -20,4 +20,5 @@ sexpToJson (SexpCons _ _) = Left $ "cons cell has no JSON equivalent" sexpToJson (SexpString s) = Right . JSString $ T.unpack s sexpToJson (SexpSymbol s) = Right . JSString $ T.unpack s -- nobody said it had to roundtrip+sexpToJson (SexpInt i) = Right $ JSInt i -- TODO write our own JSON repr to avoid a ghc dep and improve perf
library/HsInspect/Packages.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}
+ library/HsInspect/Runner.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}++module HsInspect.Runner (runGhcAndJamMasterShe, ghcflags_flags) where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Except (runExceptT)+import Data.List (find, isPrefixOf)+import qualified Data.List as L+import Data.Maybe (catMaybes)+import qualified Data.Text as T+import DynFlags (parseDynamicFlagsCmdLine, updOptLevel)+import qualified EnumSet as EnumSet+import GHC (Ghc, GhcMonad, getSessionDynFlags)+import qualified GHC as GHC+import HsInspect.Context+import HsInspect.Util (homeSources)+import HsInspect.Workarounds (parseModuleName')+import System.Directory (getCurrentDirectory, setCurrentDirectory)+import System.Environment (setEnv)++-- expects the PWD to be the same as the .cabal file and the PATH to be what the+-- build tool sees.+runGhcAndJamMasterShe :: [String] -> Ghc a -> IO a+runGhcAndJamMasterShe (filterFlags -> flags) work =+ let libdir = (drop 2) <$> find ("-B" `isPrefixOf`) flags+ flags' = filter (not . ("-B" `isPrefixOf`)) flags+ in GHC.runGhc libdir $ do+ dflags <- GHC.getSessionDynFlags+ (updOptLevel 0 -> dflags', (GHC.unLoc <$>) -> _ghcargs, _) <-+ liftIO $ parseDynamicFlagsCmdLine dflags (GHC.noLoc <$> flags')+ void $ GHC.setSessionDynFlags dflags'+ { GHC.hscTarget = GHC.HscInterpreted -- HscNothing compiles home modules, dunno why+ , GHC.ghcLink = GHC.LinkInMemory -- required by HscInterpreted+ , GHC.ghcMode = GHC.MkDepend -- prefer .hi to .hs for dependencies+ , GHC.warningFlags = EnumSet.empty+ , GHC.fatalWarningFlags = EnumSet.empty+ }++ -- The caller may have provided a list of home modules, but we do not trust+ -- them because the ghcflags plugin does not keep the flags up to date for+ -- incremental compiles.+ let mkTarget m = GHC.Target (GHC.TargetModule m) True Nothing+ homeModules <- inferHomeModules+ GHC.setTargets $ mkTarget <$> homeModules+ work++-- gets the flags (and sets the environment) from the output of the ghcflags plugin+ghcflags_flags :: Maybe FilePath -> IO [String]+ghcflags_flags mf = do+ from <- maybe getCurrentDirectory pure mf+ ctx <- runExceptT $ findContext from+ case ctx of+ Left err -> error err+ Right Context{package_dir, ghcflags, ghcpath} -> do+ setCurrentDirectory package_dir+ setEnv "PATH" (T.unpack ghcpath)+ pure $ T.unpack <$> ghcflags++inferHomeModules :: GHC.GhcMonad m => m [GHC.ModuleName]+inferHomeModules = do+ files <- homeSources+ mmns <- traverse parseModuleName' files+ let main' = GHC.mkModuleName "Main"+ pure . L.nub . filter (main' /=) $ catMaybes mmns+ -- stack often has duplicates++-- removes the "+RTS ... -RTS" sections+filterFlags :: [String] -> [String]+filterFlags args = case span ("+RTS" /=) args of+ (front, []) -> front+ (front, _ : middle) -> case span ("-RTS" /=) middle of+ (_, []) -> front -- bad input?+ (_, _ : back) -> front <> back+
library/HsInspect/Sexp.hs view
@@ -17,6 +17,7 @@ | SexpNil | SexpString Text | SexpSymbol Text+ | SexpInt Int list :: [Sexp] -> Sexp list = foldr SexpCons SexpNil@@ -52,9 +53,18 @@ toSexp False = SexpNil toSexp True = SexpSymbol "t" +instance ToSexp Int where+ toSexp = SexpInt+ instance ToSexp a => ToSexp [a] where toSexp as = list $ toSexp <$> as +instance (ToSexp a1, ToSexp a2) => ToSexp (a1, a2) where+ toSexp (a1, a2) = list [toSexp a1, toSexp a2]++instance (ToSexp a1, ToSexp a2, ToSexp a3) => ToSexp (a1, a2, a3) where+ toSexp (a1, a2, a3) = list [toSexp a1, toSexp a2, toSexp a3]+ instance ToSexp a => ToSexp (Maybe a) where toSexp (Just a) = toSexp a toSexp Nothing = SexpNil@@ -74,6 +84,7 @@ filterNil (SexpCons car cdr) = (SexpCons (filterNil car) (filterNil cdr)) filterNil (SexpString s) = SexpString s filterNil (SexpSymbol s) = SexpSymbol s+filterNil (SexpInt i) = SexpInt i render :: Sexp -> Text render SexpNil = "nil"@@ -81,4 +92,5 @@ 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+render (SexpInt i) = T.pack $ show i -- TODO write our own escapeString to avoid a ghc dep and improve perf
− library/HsInspect/TypeParser.hs
@@ -1,88 +0,0 @@-{-# 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 _)) = "<unsupported>"-- 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
+ library/HsInspect/Types.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module HsInspect.Types where++import Control.Exception (throwIO)+import Control.Monad.IO.Class (liftIO)+import Data.List (sortOn)+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import qualified DynFlags as GHC+import GHC (HscEnv)+import qualified GHC as GHC+import HsInspect.Sexp+import qualified HsInspect.Util as H+import HsInspect.Workarounds (mkCppState)+import qualified Lexer as GHC+import qualified Outputable as GHC+import qualified Parser+import qualified RnTypes as GHC++data Type = ProductType Text [Text] Bool Text [(Text, [Text])] -- ^^ type tparams newtype cons [(param types, [typarams])]+ | RecordType Text [Text] Bool Text [(Text, Text, [Text])] -- ^^ type tparams newtype cons [(fieldname, param type, [typarams])]+ | SumType Text [Text] [(Text, [(Text, [Text])])] -- ^^ type tparams [(cons, [param types, [typarams]])] (no records)+ deriving (Eq, Show)+{- BOILERPLATE Type ToSexp+ field={ProductType:[type,tparams,newtype,cons,params],+ RecordType:[type,tparams,newtype,cons,fields],+ SumType:[type,tparams,data]}+ class={ProductType:product,+ RecordType:record,+ SumType:sum}+-}+{- BOILERPLATE START -}+instance ToSexp Type where+ toSexp (ProductType p_1_1 p_1_2 p_1_3 p_1_4 p_1_5) = alist $ ("class", "product") : [("type", toSexp p_1_1), ("tparams", toSexp p_1_2), ("newtype", toSexp p_1_3), ("cons", toSexp p_1_4), ("params", toSexp p_1_5)]+ toSexp (RecordType p_1_1 p_1_2 p_1_3 p_1_4 p_1_5) = alist $ ("class", "record") : [("type", toSexp p_1_1), ("tparams", toSexp p_1_2), ("newtype", toSexp p_1_3), ("cons", toSexp p_1_4), ("fields", toSexp p_1_5)]+ toSexp (SumType p_1_1 p_1_2 p_1_3) = alist $ ("class", "sum") : [("type", toSexp p_1_1), ("tparams", toSexp p_1_2), ("data", toSexp p_1_3)]+{- BOILERPLATE END -}++-- line, col (1-indexed)+data Pos = Pos Int Int+ deriving (Eq, Ord, Show)+{- BOILERPLATE Pos ToSexp field=[line,col] -}+{- BOILERPLATE START -}+instance ToSexp Pos where+ toSexp (Pos p_1_1 p_1_2) = alist [("line", toSexp p_1_1), ("col", toSexp p_1_2)]+{- BOILERPLATE END -}++data Comment = Comment Text Pos Pos -- text start end+ deriving (Eq, Show)+{- BOILERPLATE Comment ToSexp field=[text,start,end] -}+{- BOILERPLATE START -}+instance ToSexp Comment where+ toSexp (Comment p_1_1 p_1_2 p_1_3) = alist [("text", toSexp p_1_1), ("start", toSexp p_1_2), ("end", toSexp p_1_3)]+{- BOILERPLATE END -}++types :: GHC.GhcMonad m => FilePath -> m ([Type], [Comment])+types file = do+ dflags <- GHC.getSessionDynFlags+ _ <- GHC.setSessionDynFlags $ GHC.gopt_set dflags GHC.Opt_KeepRawTokenStream+ env <- GHC.getSession+ liftIO $ parseTypes env file++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'+ nt = case GHC.dd_ND ddn of+ GHC.NewType -> True+ GHC.DataType -> False+ renderTyParams :: GHC.LHsType GHC.GhcPs -> [Text]+ renderTyParams tpe = showGhc <$> (GHC.freeKiTyVarsTypeVars $ GHC.extractHsTyRdrTyVars tpe)+ renderField :: GHC.GenLocated l (GHC.ConDeclField GHC.GhcPs) -> (Text, Text, [Text]) -- (name, type, [typarams])+ renderField (GHC.L _ field) =+ let tpe = GHC.cd_fld_type field+ in (showGhc . head $ GHC.cd_fld_names field, showGhc tpe, renderTyParams tpe)+ renderArg :: GHC.LBangType GHC.GhcPs -> (Text, [Text]) -- (type, typarams)+ renderArg t@(GHC.L _ arg) = (showGhc arg, renderTyParams t)+ -- rhs is (cons, [(field name, field type, [typarams])] | [(parameter type, [typarams])])+ rhs = do+ (GHC.L _ ddl) <- GHC.dd_cons ddn+ case ddl of+ -- http://hackage.haskell.org/package/ghc-8.8.3/docs/HsDecls.html#t:ConDecl+ 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, 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 nt cons tpes+ [(cons, Left fields)] -> Just $ RecordType tycon tparams nt cons fields+ mult -> Just . SumType tycon tparams $ render <$> mult+ where+ render (cons, Right args) = (cons, args)+ render (cons, Left fargs) = (cons, (\(_, tpes, typs) -> (tpes, typs)) <$> 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 _)) = "<unsupported>"++ 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
library/HsInspect/Util.hs view
@@ -45,6 +45,12 @@ then pure Nothing else locateDominating p parent +-- the first parent directory where a file or directory name matches the predicate+locateDominatingDir :: (String -> Bool) -> FilePath -> IO (Maybe FilePath)+locateDominatingDir p dir = do+ file' <- locateDominating p dir+ pure $ takeDirectory <$> file'+ walkSuffix :: String -> FilePath -> IO [FilePath] walkSuffix suffix dir = filter (suffix `isSuffixOf`) <$> walk dir