module Hhp.Browse (
    browseModule
  , browse
  ) where

import Exception (ghandle)
import FastString (mkFastString)
import GHC (Ghc, GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon)
import qualified GHC as G
import Name (getOccString)
import Outputable (ppr, Outputable)
import TyCon (isAlgTyCon)
import Type (dropForAlls, splitFunTy_maybe, isPredTy)

import Control.Exception (SomeException(..))
import Data.Char (isAlpha)
import Data.List (sort)
import Data.Maybe (catMaybes)

import Hhp.Doc (showPage, styleUnqualified)
import Hhp.Gap
import Hhp.GHCApi
import Hhp.Things
import Hhp.Types

----------------------------------------------------------------

-- | Getting functions, classes, etc from a module.
--   If 'detailed' is 'True', their types are also obtained.
--   If 'operators' is 'True', operators are also returned.
browseModule :: Options
             -> Cradle
             -> ModuleString -- ^ A module name. (e.g. \"Data.List\")
             -> IO String
browseModule :: Options -> Cradle -> ModuleString -> IO ModuleString
browseModule Options
opt Cradle
cradle ModuleString
pkgmdl = Ghc ModuleString -> IO ModuleString
forall a. Ghc a -> IO a
withGHC' (Ghc ModuleString -> IO ModuleString)
-> Ghc ModuleString -> IO ModuleString
forall a b. (a -> b) -> a -> b
$ do
    Options -> Cradle -> Ghc ()
initializeFlagsWithCradle Options
opt Cradle
cradle
    Options -> ModuleString -> Ghc ModuleString
browse Options
opt ModuleString
pkgmdl

-- | Getting functions, classes, etc from a module.
--   If 'detailed' is 'True', their types are also obtained.
--   If 'operators' is 'True', operators are also returned.
browse :: Options
       -> ModuleString -- ^ A module name. (e.g. \"Data.List\")
       -> Ghc String
browse :: Options -> ModuleString -> Ghc ModuleString
browse Options
opt ModuleString
pkgmdl = do
    Options -> [ModuleString] -> ModuleString
forall a. ToString a => Options -> a -> ModuleString
convert Options
opt ([ModuleString] -> ModuleString)
-> ([ModuleString] -> [ModuleString])
-> [ModuleString]
-> ModuleString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ModuleString] -> [ModuleString]
forall a. Ord a => [a] -> [a]
sort ([ModuleString] -> ModuleString)
-> Ghc [ModuleString] -> Ghc ModuleString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ghc (Maybe ModuleInfo)
getModule Ghc (Maybe ModuleInfo)
-> (Maybe ModuleInfo -> Ghc [ModuleString]) -> Ghc [ModuleString]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe ModuleInfo -> Ghc [ModuleString]
listExports)
  where
    (Maybe ModuleString
mpkg,ModuleString
mdl) = ModuleString -> (Maybe ModuleString, ModuleString)
splitPkgMdl ModuleString
pkgmdl
    mdlname :: ModuleName
mdlname = ModuleString -> ModuleName
G.mkModuleName ModuleString
mdl
    mpkgid :: Maybe FastString
mpkgid = ModuleString -> FastString
mkFastString (ModuleString -> FastString)
-> Maybe ModuleString -> Maybe FastString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ModuleString
mpkg
    listExports :: Maybe ModuleInfo -> Ghc [ModuleString]
listExports Maybe ModuleInfo
Nothing       = [ModuleString] -> Ghc [ModuleString]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    listExports (Just ModuleInfo
mdinfo) = Options -> ModuleInfo -> Ghc [ModuleString]
processExports Options
opt ModuleInfo
mdinfo
    -- findModule works only for package modules, moreover,
    -- you cannot load a package module. On the other hand,
    -- to browse a local module you need to load it first.
    -- If CmdLineError is signalled, we assume the user
    -- tried browsing a local module.
    getModule :: Ghc (Maybe ModuleInfo)
getModule = Ghc (Maybe ModuleInfo)
browsePackageModule Ghc (Maybe ModuleInfo)
-> (GhcException -> Ghc (Maybe ModuleInfo))
-> Ghc (Maybe ModuleInfo)
forall (m :: * -> *) e a.
(ExceptionMonad m, Exception e) =>
m a -> (e -> m a) -> m a
`G.gcatch` GhcException -> Ghc (Maybe ModuleInfo)
fallback Ghc (Maybe ModuleInfo)
-> (SomeException -> Ghc (Maybe ModuleInfo))
-> Ghc (Maybe ModuleInfo)
forall (m :: * -> *) e a.
(ExceptionMonad m, Exception e) =>
m a -> (e -> m a) -> m a
`G.gcatch` SomeException -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *) a. Monad m => SomeException -> m (Maybe a)
handler
    browsePackageModule :: Ghc (Maybe ModuleInfo)
browsePackageModule = ModuleName -> Maybe FastString -> Ghc Module
forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
G.findModule ModuleName
mdlname Maybe FastString
mpkgid Ghc Module
-> (Module -> Ghc (Maybe ModuleInfo)) -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *). GhcMonad m => Module -> m (Maybe ModuleInfo)
G.getModuleInfo
    browseLocalModule :: Ghc (Maybe ModuleInfo)
browseLocalModule = (SomeException -> Ghc (Maybe ModuleInfo))
-> Ghc (Maybe ModuleInfo) -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *) e a.
(ExceptionMonad m, Exception e) =>
(e -> m a) -> m a -> m a
ghandle SomeException -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *) a. Monad m => SomeException -> m (Maybe a)
handler (Ghc (Maybe ModuleInfo) -> Ghc (Maybe ModuleInfo))
-> Ghc (Maybe ModuleInfo) -> Ghc (Maybe ModuleInfo)
forall a b. (a -> b) -> a -> b
$ do
      [ModuleString] -> Ghc ()
setTargetFiles [ModuleString
mdl]
      ModuleName -> Maybe FastString -> Ghc Module
forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
G.findModule ModuleName
mdlname Maybe FastString
forall a. Maybe a
Nothing Ghc Module
-> (Module -> Ghc (Maybe ModuleInfo)) -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *). GhcMonad m => Module -> m (Maybe ModuleInfo)
G.getModuleInfo
    fallback :: GhcException -> Ghc (Maybe ModuleInfo)
fallback (CmdLineError ModuleString
_) = Ghc (Maybe ModuleInfo)
browseLocalModule
    fallback GhcException
_                = Maybe ModuleInfo -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModuleInfo
forall a. Maybe a
Nothing
    handler :: SomeException -> m (Maybe a)
handler (SomeException e
_) = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
-- |
--
-- >>> splitPkgMdl "base:Prelude"
-- (Just "base","Prelude")
-- >>> splitPkgMdl "Prelude"
-- (Nothing,"Prelude")
splitPkgMdl :: String -> (Maybe String,String)
splitPkgMdl :: ModuleString -> (Maybe ModuleString, ModuleString)
splitPkgMdl ModuleString
pkgmdl = case (Char -> Bool) -> ModuleString -> (ModuleString, ModuleString)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':') ModuleString
pkgmdl of
    (ModuleString
mdl,ModuleString
"")    -> (Maybe ModuleString
forall a. Maybe a
Nothing,ModuleString
mdl)
    (ModuleString
pkg,Char
_:ModuleString
mdl) -> (ModuleString -> Maybe ModuleString
forall a. a -> Maybe a
Just ModuleString
pkg,ModuleString
mdl)

processExports :: Options -> ModuleInfo -> Ghc [String]
processExports :: Options -> ModuleInfo -> Ghc [ModuleString]
processExports Options
opt ModuleInfo
minfo = (Name -> Ghc ModuleString) -> [Name] -> Ghc [ModuleString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Options -> ModuleInfo -> Name -> Ghc ModuleString
showExport Options
opt ModuleInfo
minfo) ([Name] -> Ghc [ModuleString]) -> [Name] -> Ghc [ModuleString]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
removeOps ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> [Name]
G.modInfoExports ModuleInfo
minfo
  where
    removeOps :: [Name] -> [Name]
removeOps
      | Options -> Bool
operators Options
opt = [Name] -> [Name]
forall a. a -> a
id
      | Bool
otherwise = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Bool
isAlpha (Char -> Bool) -> (Name -> Char) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleString -> Char
forall a. [a] -> a
head (ModuleString -> Char) -> (Name -> ModuleString) -> Name -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> ModuleString
forall a. NamedThing a => a -> ModuleString
getOccString)

showExport :: Options -> ModuleInfo -> Name -> Ghc String
showExport :: Options -> ModuleInfo -> Name -> Ghc ModuleString
showExport Options
opt ModuleInfo
minfo Name
e = do
  Maybe ModuleString
mtype' <- Ghc (Maybe ModuleString)
mtype
  ModuleString -> Ghc ModuleString
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleString -> Ghc ModuleString)
-> ModuleString -> Ghc ModuleString
forall a b. (a -> b) -> a -> b
$ [ModuleString] -> ModuleString
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([ModuleString] -> ModuleString) -> [ModuleString] -> ModuleString
forall a b. (a -> b) -> a -> b
$ [Maybe ModuleString] -> [ModuleString]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ModuleString
mqualified, ModuleString -> Maybe ModuleString
forall a. a -> Maybe a
Just (ModuleString -> Maybe ModuleString)
-> ModuleString -> Maybe ModuleString
forall a b. (a -> b) -> a -> b
$ ModuleString -> ModuleString
formatOp (ModuleString -> ModuleString) -> ModuleString -> ModuleString
forall a b. (a -> b) -> a -> b
$ Name -> ModuleString
forall a. NamedThing a => a -> ModuleString
getOccString Name
e, Maybe ModuleString
mtype']
  where
    mqualified :: Maybe ModuleString
mqualified = (ModuleName -> ModuleString
G.moduleNameString (Module -> ModuleName
G.moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
G.nameModule Name
e) ModuleString -> ModuleString -> ModuleString
forall a. [a] -> [a] -> [a]
++ ModuleString
".") ModuleString -> Bool -> Maybe ModuleString
forall a. a -> Bool -> Maybe a
`justIf` Options -> Bool
qualified Options
opt
    mtype :: Ghc (Maybe ModuleString)
mtype
      | Options -> Bool
detailed Options
opt = do
        Maybe TyThing
tyInfo <- ModuleInfo -> Name -> Ghc (Maybe TyThing)
forall (m :: * -> *).
GhcMonad m =>
ModuleInfo -> Name -> m (Maybe TyThing)
G.modInfoLookupName ModuleInfo
minfo Name
e
        -- If nothing found, load dependent module and lookup global
        Maybe TyThing
tyResult <- Ghc (Maybe TyThing)
-> (TyThing -> Ghc (Maybe TyThing))
-> Maybe TyThing
-> Ghc (Maybe TyThing)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> Ghc (Maybe TyThing)
inOtherModule Name
e) (Maybe TyThing -> Ghc (Maybe TyThing)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TyThing -> Ghc (Maybe TyThing))
-> (TyThing -> Maybe TyThing) -> TyThing -> Ghc (Maybe TyThing)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just) Maybe TyThing
tyInfo
        DynFlags
dflag <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
G.getSessionDynFlags
        Maybe ModuleString -> Ghc (Maybe ModuleString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ModuleString -> Ghc (Maybe ModuleString))
-> Maybe ModuleString -> Ghc (Maybe ModuleString)
forall a b. (a -> b) -> a -> b
$ do
          ModuleString
typeName <- Maybe TyThing
tyResult Maybe TyThing
-> (TyThing -> Maybe ModuleString) -> Maybe ModuleString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DynFlags -> TyThing -> Maybe ModuleString
showThing DynFlags
dflag
          (ModuleString
" :: " ModuleString -> ModuleString -> ModuleString
forall a. [a] -> [a] -> [a]
++ ModuleString
typeName) ModuleString -> Bool -> Maybe ModuleString
forall a. a -> Bool -> Maybe a
`justIf` Options -> Bool
detailed Options
opt
      | Bool
otherwise = Maybe ModuleString -> Ghc (Maybe ModuleString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModuleString
forall a. Maybe a
Nothing
    formatOp :: ModuleString -> ModuleString
formatOp nm :: ModuleString
nm@(Char
n:ModuleString
_)
      | Char -> Bool
isAlpha Char
n = ModuleString
nm
      | Bool
otherwise = ModuleString
"(" ModuleString -> ModuleString -> ModuleString
forall a. [a] -> [a] -> [a]
++ ModuleString
nm ModuleString -> ModuleString -> ModuleString
forall a. [a] -> [a] -> [a]
++ ModuleString
")"
    formatOp ModuleString
"" = ModuleString -> ModuleString
forall a. HasCallStack => ModuleString -> a
error ModuleString
"formatOp"
    inOtherModule :: Name -> Ghc (Maybe TyThing)
    inOtherModule :: Name -> Ghc (Maybe TyThing)
inOtherModule Name
nm = Module -> Ghc (Maybe ModuleInfo)
forall (m :: * -> *). GhcMonad m => Module -> m (Maybe ModuleInfo)
G.getModuleInfo (HasDebugCallStack => Name -> Module
Name -> Module
G.nameModule Name
nm) Ghc (Maybe ModuleInfo)
-> Ghc (Maybe TyThing) -> Ghc (Maybe TyThing)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Name -> Ghc (Maybe TyThing)
forall (m :: * -> *). GhcMonad m => Name -> m (Maybe TyThing)
G.lookupGlobalName Name
nm
    justIf :: a -> Bool -> Maybe a
    justIf :: a -> Bool -> Maybe a
justIf a
x Bool
True = a -> Maybe a
forall a. a -> Maybe a
Just a
x
    justIf a
_ Bool
False = Maybe a
forall a. Maybe a
Nothing

showThing :: DynFlags -> TyThing -> Maybe String
showThing :: DynFlags -> TyThing -> Maybe ModuleString
showThing DynFlags
dflag TyThing
tything = DynFlags -> GapThing -> Maybe ModuleString
showThing' DynFlags
dflag (TyThing -> GapThing
fromTyThing TyThing
tything)

showThing' :: DynFlags -> GapThing -> Maybe String
showThing' :: DynFlags -> GapThing -> Maybe ModuleString
showThing' DynFlags
dflag (GtA Type
a) = ModuleString -> Maybe ModuleString
forall a. a -> Maybe a
Just (ModuleString -> Maybe ModuleString)
-> ModuleString -> Maybe ModuleString
forall a b. (a -> b) -> a -> b
$ DynFlags -> Type -> ModuleString
formatType DynFlags
dflag Type
a
showThing' DynFlags
_     (GtT TyCon
t) = [ModuleString] -> ModuleString
unwords ([ModuleString] -> ModuleString)
-> (ModuleString -> [ModuleString]) -> ModuleString -> ModuleString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleString -> [ModuleString]
toList (ModuleString -> ModuleString)
-> Maybe ModuleString -> Maybe ModuleString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyCon -> Maybe ModuleString
tyType TyCon
t
  where
    toList :: ModuleString -> [ModuleString]
toList ModuleString
t' = ModuleString
t' ModuleString -> [ModuleString] -> [ModuleString]
forall a. a -> [a] -> [a]
: TyCon -> ModuleString
forall a. NamedThing a => a -> ModuleString
getOccString TyCon
t ModuleString -> [ModuleString] -> [ModuleString]
forall a. a -> [a] -> [a]
: (TyVar -> ModuleString) -> [TyVar] -> [ModuleString]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> ModuleString
forall a. NamedThing a => a -> ModuleString
getOccString (TyCon -> [TyVar]
G.tyConTyVars TyCon
t)
showThing' DynFlags
_     GapThing
_       = Maybe ModuleString
forall a. Maybe a
Nothing

formatType :: DynFlags -> Type -> String
formatType :: DynFlags -> Type -> ModuleString
formatType DynFlags
dflag Type
a = DynFlags -> Type -> ModuleString
forall a. Outputable a => DynFlags -> a -> ModuleString
showOutputable DynFlags
dflag (Type -> Type
removeForAlls Type
a)

tyType :: TyCon -> Maybe String
tyType :: TyCon -> Maybe ModuleString
tyType TyCon
typ
    | TyCon -> Bool
isAlgTyCon TyCon
typ
      Bool -> Bool -> Bool
&& Bool -> Bool
not (TyCon -> Bool
G.isNewTyCon TyCon
typ)
      Bool -> Bool -> Bool
&& Bool -> Bool
not (TyCon -> Bool
G.isClassTyCon TyCon
typ) = ModuleString -> Maybe ModuleString
forall a. a -> Maybe a
Just ModuleString
"data"
    | TyCon -> Bool
G.isNewTyCon TyCon
typ            = ModuleString -> Maybe ModuleString
forall a. a -> Maybe a
Just ModuleString
"newtype"
    | TyCon -> Bool
G.isClassTyCon TyCon
typ          = ModuleString -> Maybe ModuleString
forall a. a -> Maybe a
Just ModuleString
"class"
--    | G.isSynTyCon typ            = Just "type" -- fixme
    | TyCon -> Bool
G.isTypeSynonymTyCon TyCon
typ    = ModuleString -> Maybe ModuleString
forall a. a -> Maybe a
Just ModuleString
"type"
    | Bool
otherwise                   = Maybe ModuleString
forall a. Maybe a
Nothing

removeForAlls :: Type -> Type
removeForAlls :: Type -> Type
removeForAlls Type
ty = Type -> Maybe (Type, Type) -> Type
removeForAlls' Type
ty' Maybe (Type, Type)
tty'
  where
    ty' :: Type
ty'  = Type -> Type
dropForAlls Type
ty
    tty' :: Maybe (Type, Type)
tty' = Type -> Maybe (Type, Type)
splitFunTy_maybe Type
ty'

removeForAlls' :: Type -> Maybe (Type, Type) -> Type
removeForAlls' :: Type -> Maybe (Type, Type) -> Type
removeForAlls' Type
ty Maybe (Type, Type)
Nothing = Type
ty
removeForAlls' Type
ty (Just (Type
pre, Type
ftype))
    | HasDebugCallStack => Type -> Bool
Type -> Bool
isPredTy Type
pre        = Type -> Type -> Type
mkFunTy Type
pre (Type -> Type
dropForAlls Type
ftype)
    | Bool
otherwise           = Type
ty

showOutputable :: Outputable a => DynFlags -> a -> String
showOutputable :: DynFlags -> a -> ModuleString
showOutputable DynFlags
dflag = [ModuleString] -> ModuleString
unwords ([ModuleString] -> ModuleString)
-> (a -> [ModuleString]) -> a -> ModuleString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleString -> [ModuleString]
lines (ModuleString -> [ModuleString])
-> (a -> ModuleString) -> a -> [ModuleString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> PprStyle -> SDoc -> ModuleString
showPage DynFlags
dflag (DynFlags -> PprStyle
styleUnqualified DynFlags
dflag) (SDoc -> ModuleString) -> (a -> SDoc) -> a -> ModuleString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr