diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -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" 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.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 diff --git a/library/HsInspect/Context.hs b/library/HsInspect/Context.hs new file mode 100644 --- /dev/null +++ b/library/HsInspect/Context.hs @@ -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 diff --git a/library/HsInspect/Json.hs b/library/HsInspect/Json.hs --- a/library/HsInspect/Json.hs +++ b/library/HsInspect/Json.hs @@ -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 diff --git a/library/HsInspect/Packages.hs b/library/HsInspect/Packages.hs --- a/library/HsInspect/Packages.hs +++ b/library/HsInspect/Packages.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/library/HsInspect/Runner.hs b/library/HsInspect/Runner.hs new file mode 100644 --- /dev/null +++ b/library/HsInspect/Runner.hs @@ -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 + diff --git a/library/HsInspect/Sexp.hs b/library/HsInspect/Sexp.hs --- a/library/HsInspect/Sexp.hs +++ b/library/HsInspect/Sexp.hs @@ -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 diff --git a/library/HsInspect/TypeParser.hs b/library/HsInspect/TypeParser.hs deleted file mode 100644 --- a/library/HsInspect/TypeParser.hs +++ /dev/null @@ -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 _)) = "" - - 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/Types.hs b/library/HsInspect/Types.hs new file mode 100644 --- /dev/null +++ b/library/HsInspect/Types.hs @@ -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 _)) = "" + + 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 @@ -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