{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes, TemplateHaskell, OverloadedStrings, CPP, PackageImports #-}

module HsDev.Tools.Ghc.Types (
	TypedExpr(..), typedExpr, typedType,
	moduleTypes, fileTypes,
	setModuleTypes, inferTypes
	) where

import Control.DeepSeq
import Control.Lens (over, view, set, each, preview, makeLenses, _Just)
import Control.Monad
import Control.Monad.Fail (MonadFail)
import Control.Monad.IO.Class
import Data.Aeson
import Data.Generics
import Data.List (find)
import Data.Maybe
import Data.String (fromString)
import Data.Text (Text)
import System.Log.Simple (MonadLog(..), scope)

import "ghc" GHC hiding (exprType, Module, moduleName)
import "ghc" CoreUtils as C
import "ghc" NameSet (NameSet)
import "ghc" Desugar (deSugarExpr)
import "ghc" TcHsSyn (hsPatType)
import "ghc" Outputable
import "ghc" PprTyThing
import qualified "ghc" SrcLoc
import qualified "ghc" Pretty

import System.Directory.Paths
import HsDev.Error
import HsDev.Symbols
import HsDev.Tools.Ghc.Worker as Ghc
import HsDev.Tools.Ghc.Compat
import HsDev.Tools.Types
import HsDev.Util

class HasType a where
	getType :: GhcMonad m => a -> m (Maybe (SrcSpan, Type))

instance HasType (LHsExpr TcId) where
	getType :: LHsExpr TcId -> m (Maybe (SrcSpan, Type))
getType LHsExpr TcId
e = do
		HscEnv
env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
		Maybe CoreExpr
mbe <- IO (Maybe CoreExpr) -> m (Maybe CoreExpr)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe CoreExpr) -> m (Maybe CoreExpr))
-> IO (Maybe CoreExpr) -> m (Maybe CoreExpr)
forall a b. (a -> b) -> a -> b
$ ((Messages, Maybe CoreExpr) -> Maybe CoreExpr)
-> IO (Messages, Maybe CoreExpr) -> IO (Maybe CoreExpr)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Messages, Maybe CoreExpr) -> Maybe CoreExpr
forall a b. (a, b) -> b
snd (IO (Messages, Maybe CoreExpr) -> IO (Maybe CoreExpr))
-> IO (Messages, Maybe CoreExpr) -> IO (Maybe CoreExpr)
forall a b. (a -> b) -> a -> b
$ HscEnv -> LHsExpr TcId -> IO (Messages, Maybe CoreExpr)
deSugarExpr HscEnv
env LHsExpr TcId
e
		Maybe (SrcSpan, Type) -> m (Maybe (SrcSpan, Type))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (SrcSpan, Type) -> m (Maybe (SrcSpan, Type)))
-> Maybe (SrcSpan, Type) -> m (Maybe (SrcSpan, Type))
forall a b. (a -> b) -> a -> b
$ do
			CoreExpr
ex <- Maybe CoreExpr
mbe
			(SrcSpan, Type) -> Maybe (SrcSpan, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr TcId -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr TcId
e, CoreExpr -> Type
C.exprType CoreExpr
ex)

instance HasType (LHsBind TcId) where
	getType :: LHsBind TcId -> m (Maybe (SrcSpan, Type))
getType (L SrcSpan
_ FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = Located (IdP TcId)
fid, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup TcId (LHsExpr TcId)
m}) = Maybe (SrcSpan, Type) -> m (Maybe (SrcSpan, Type))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (SrcSpan, Type) -> m (Maybe (SrcSpan, Type)))
-> Maybe (SrcSpan, Type) -> m (Maybe (SrcSpan, Type))
forall a b. (a -> b) -> a -> b
$ do
		[Type]
argTys <- MatchGroup TcId (LHsExpr TcId) -> Maybe [Type]
mgArgTys MatchGroup TcId (LHsExpr TcId)
m
		Type
resTy <- MatchGroup TcId (LHsExpr TcId) -> Maybe Type
mgResTy MatchGroup TcId (LHsExpr TcId)
m
		(SrcSpan, Type) -> Maybe (SrcSpan, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located Id -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located (IdP TcId)
Located Id
fid, [Type] -> Type -> Type
mkFunTys [Type]
argTys Type
resTy)
	getType LHsBind TcId
_ = Maybe (SrcSpan, Type) -> m (Maybe (SrcSpan, Type))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (SrcSpan, Type)
forall a. Maybe a
Nothing

#if __GLASGOW_HASKELL__ >= 810
instance HasType (Located (Pat GhcTcId)) where
#else
instance HasType (LPat TcId) where
#endif
#if __GLASGOW_HASKELL__ >= 808
	getType :: Located (Pat TcId) -> m (Maybe (SrcSpan, Type))
getType = Located (Pat TcId) -> m (Maybe (SrcSpan, Type))
forall (m :: * -> *) a.
Monad m =>
GenLocated a (Pat TcId) -> m (Maybe (a, Type))
go (Located (Pat TcId) -> m (Maybe (SrcSpan, Type)))
-> (Located (Pat TcId) -> Located (Pat TcId))
-> Located (Pat TcId)
-> m (Maybe (SrcSpan, Type))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (Pat TcId) -> Located (Pat TcId)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
SrcLoc.decomposeSrcSpan where
#else
	getType = go where
#endif
		go :: GenLocated a (Pat TcId) -> m (Maybe (a, Type))
go (L a
spn Pat TcId
pat) = Maybe (a, Type) -> m (Maybe (a, Type))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (a, Type) -> m (Maybe (a, Type)))
-> Maybe (a, Type) -> m (Maybe (a, Type))
forall a b. (a -> b) -> a -> b
$ (a, Type) -> Maybe (a, Type)
forall a. a -> Maybe a
Just (a
spn, Pat TcId -> Type
hsPatType Pat TcId
pat)

locatedTypes :: Typeable a => TypecheckedSource -> [Located a]
locatedTypes :: TypecheckedSource -> [Located a]
locatedTypes = (Located a -> Bool) -> GenericQ [Located a]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
types' Located a -> Bool
forall e. GenLocated SrcSpan e -> Bool
p where
	types' :: Typeable r => (r -> Bool) -> GenericQ [r]
	types' :: (r -> Bool) -> GenericQ [r]
types' r -> Bool
p' = ([r] -> [r] -> [r]) -> [r] -> GenericQ [r] -> GenericQ [r]
forall r. (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingTyped [r] -> [r] -> [r]
forall a. [a] -> [a] -> [a]
(++) [] ([] [r] -> (r -> [r]) -> a -> [r]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` (\r
x -> [r
x | r -> Bool
p' r
x]))
	p :: GenLocated SrcSpan e -> Bool
p (L SrcSpan
spn e
_) = SrcSpan -> Bool
isGoodSrcSpan SrcSpan
spn

#if __GLASGOW_HASKELL__ >= 808
typeableTypes :: Typeable a => TypecheckedSource -> [a]
typeableTypes :: TypecheckedSource -> [a]
typeableTypes = (a -> Bool) -> GenericQ [a]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
types' (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True) where
	types' :: Typeable r => (r -> Bool) -> GenericQ [r]
	types' :: (r -> Bool) -> GenericQ [r]
types' r -> Bool
p' = ([r] -> [r] -> [r]) -> [r] -> GenericQ [r] -> GenericQ [r]
forall r. (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingTyped [r] -> [r] -> [r]
forall a. [a] -> [a] -> [a]
(++) [] ([] [r] -> (r -> [r]) -> a -> [r]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` (\r
x -> [r
x | r -> Bool
p' r
x]))

locatedPats :: TypecheckedSource -> [LPat TcId]
locatedPats :: TypecheckedSource -> [LPat TcId]
locatedPats = TypecheckedSource -> [LPat TcId]
forall a. Typeable a => TypecheckedSource -> [a]
typeableTypes
#else
locatedPats :: TypecheckedSource -> [LPat TcId]
locatedPats = locatedTypes
#endif

everythingTyped :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingTyped :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingTyped r -> r -> r
k r
z GenericQ r
f a
x
	| (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
False (a -> Bool) -> (NameSet -> Bool) -> a -> Bool
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` NameSet -> Bool
nameSet) a
x = r
z
	| Bool
otherwise = (r -> r -> r) -> r -> [r] -> r
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl r -> r -> r
k (a -> r
GenericQ r
f a
x) (GenericQ r -> a -> [r]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ ((r -> r -> r) -> r -> GenericQ r -> GenericQ r
forall r. (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingTyped r -> r -> r
k r
z GenericQ r
f) a
x)
	where
		nameSet :: NameSet -> Bool
		nameSet :: NameSet -> Bool
nameSet = Bool -> NameSet -> Bool
forall a b. a -> b -> a
const Bool
True

moduleTypes :: (MonadFail m, GhcMonad m) => Path -> m [(SrcSpan, Type)]
moduleTypes :: Path -> m [(SrcSpan, Type)]
moduleTypes Path
fpath = do
	Path
fpath' <- IO Path -> m Path
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Path -> m Path) -> IO Path -> m Path
forall a b. (a -> b) -> a -> b
$ Path -> IO Path
forall a. Paths a => a -> IO a
canonicalize Path
fpath
	ModuleGraph
mg <- m ModuleGraph
forall (m :: * -> *). GhcMonad m => m ModuleGraph
getModuleGraph
	[ModSummary
m] <- IO [ModSummary] -> m [ModSummary]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ModSummary] -> m [ModSummary])
-> IO [ModSummary] -> m [ModSummary]
forall a b. (a -> b) -> a -> b
$ ((ModSummary -> IO Bool) -> [ModSummary] -> IO [ModSummary])
-> [ModSummary] -> (ModSummary -> IO Bool) -> IO [ModSummary]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModSummary -> IO Bool) -> [ModSummary] -> IO [ModSummary]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (ModuleGraph -> [ModSummary]
modSummaries ModuleGraph
mg) ((ModSummary -> IO Bool) -> IO [ModSummary])
-> (ModSummary -> IO Bool) -> IO [ModSummary]
forall a b. (a -> b) -> a -> b
$ \ModSummary
m -> do
		Maybe FilePath
mfile <- (FilePath -> IO FilePath) -> Maybe FilePath -> IO (Maybe FilePath)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (IO FilePath -> IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> IO FilePath)
-> (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO FilePath
forall a. Paths a => a -> IO a
canonicalize) (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
m)
		Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path Path
fpath') Maybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe FilePath
mfile)
	ParsedModule
p <- ModSummary -> m ParsedModule
forall (m :: * -> *). GhcMonad m => ModSummary -> m ParsedModule
parseModule ModSummary
m
	TypecheckedModule
tm <- ParsedModule -> m TypecheckedModule
forall (m :: * -> *).
GhcMonad m =>
ParsedModule -> m TypecheckedModule
typecheckModule ParsedModule
p
	let
		ts :: TypecheckedSource
ts = TypecheckedModule -> TypecheckedSource
tm_typechecked_source TypecheckedModule
tm
	([[Maybe (SrcSpan, Type)]] -> [(SrcSpan, Type)])
-> m [[Maybe (SrcSpan, Type)]] -> m [(SrcSpan, Type)]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([Maybe (SrcSpan, Type)] -> [(SrcSpan, Type)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (SrcSpan, Type)] -> [(SrcSpan, Type)])
-> ([[Maybe (SrcSpan, Type)]] -> [Maybe (SrcSpan, Type)])
-> [[Maybe (SrcSpan, Type)]]
-> [(SrcSpan, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Maybe (SrcSpan, Type)]] -> [Maybe (SrcSpan, Type)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (m [[Maybe (SrcSpan, Type)]] -> m [(SrcSpan, Type)])
-> m [[Maybe (SrcSpan, Type)]] -> m [(SrcSpan, Type)]
forall a b. (a -> b) -> a -> b
$ [m [Maybe (SrcSpan, Type)]] -> m [[Maybe (SrcSpan, Type)]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
		(LHsExpr TcId -> m (Maybe (SrcSpan, Type)))
-> [LHsExpr TcId] -> m [Maybe (SrcSpan, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsExpr TcId -> m (Maybe (SrcSpan, Type))
forall a (m :: * -> *).
(HasType a, GhcMonad m) =>
a -> m (Maybe (SrcSpan, Type))
getType (TypecheckedSource -> [LHsExpr TcId]
forall a. Typeable a => TypecheckedSource -> [Located a]
locatedTypes TypecheckedSource
ts :: [LHsExpr TcId]),
		(LHsBind TcId -> m (Maybe (SrcSpan, Type)))
-> [LHsBind TcId] -> m [Maybe (SrcSpan, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsBind TcId -> m (Maybe (SrcSpan, Type))
forall a (m :: * -> *).
(HasType a, GhcMonad m) =>
a -> m (Maybe (SrcSpan, Type))
getType (TypecheckedSource -> [LHsBind TcId]
forall a. Typeable a => TypecheckedSource -> [Located a]
locatedTypes TypecheckedSource
ts :: [LHsBind TcId]),
		(Located (Pat TcId) -> m (Maybe (SrcSpan, Type)))
-> [Located (Pat TcId)] -> m [Maybe (SrcSpan, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located (Pat TcId) -> m (Maybe (SrcSpan, Type))
forall a (m :: * -> *).
(HasType a, GhcMonad m) =>
a -> m (Maybe (SrcSpan, Type))
getType (TypecheckedSource -> [LPat TcId]
locatedPats TypecheckedSource
ts)]

data TypedExpr = TypedExpr {
	TypedExpr -> Maybe Path
_typedExpr :: Maybe Text,
	TypedExpr -> Path
_typedType :: Text }
		deriving (TypedExpr -> TypedExpr -> Bool
(TypedExpr -> TypedExpr -> Bool)
-> (TypedExpr -> TypedExpr -> Bool) -> Eq TypedExpr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypedExpr -> TypedExpr -> Bool
$c/= :: TypedExpr -> TypedExpr -> Bool
== :: TypedExpr -> TypedExpr -> Bool
$c== :: TypedExpr -> TypedExpr -> Bool
Eq, Eq TypedExpr
Eq TypedExpr
-> (TypedExpr -> TypedExpr -> Ordering)
-> (TypedExpr -> TypedExpr -> Bool)
-> (TypedExpr -> TypedExpr -> Bool)
-> (TypedExpr -> TypedExpr -> Bool)
-> (TypedExpr -> TypedExpr -> Bool)
-> (TypedExpr -> TypedExpr -> TypedExpr)
-> (TypedExpr -> TypedExpr -> TypedExpr)
-> Ord TypedExpr
TypedExpr -> TypedExpr -> Bool
TypedExpr -> TypedExpr -> Ordering
TypedExpr -> TypedExpr -> TypedExpr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TypedExpr -> TypedExpr -> TypedExpr
$cmin :: TypedExpr -> TypedExpr -> TypedExpr
max :: TypedExpr -> TypedExpr -> TypedExpr
$cmax :: TypedExpr -> TypedExpr -> TypedExpr
>= :: TypedExpr -> TypedExpr -> Bool
$c>= :: TypedExpr -> TypedExpr -> Bool
> :: TypedExpr -> TypedExpr -> Bool
$c> :: TypedExpr -> TypedExpr -> Bool
<= :: TypedExpr -> TypedExpr -> Bool
$c<= :: TypedExpr -> TypedExpr -> Bool
< :: TypedExpr -> TypedExpr -> Bool
$c< :: TypedExpr -> TypedExpr -> Bool
compare :: TypedExpr -> TypedExpr -> Ordering
$ccompare :: TypedExpr -> TypedExpr -> Ordering
$cp1Ord :: Eq TypedExpr
Ord, ReadPrec [TypedExpr]
ReadPrec TypedExpr
Int -> ReadS TypedExpr
ReadS [TypedExpr]
(Int -> ReadS TypedExpr)
-> ReadS [TypedExpr]
-> ReadPrec TypedExpr
-> ReadPrec [TypedExpr]
-> Read TypedExpr
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TypedExpr]
$creadListPrec :: ReadPrec [TypedExpr]
readPrec :: ReadPrec TypedExpr
$creadPrec :: ReadPrec TypedExpr
readList :: ReadS [TypedExpr]
$creadList :: ReadS [TypedExpr]
readsPrec :: Int -> ReadS TypedExpr
$creadsPrec :: Int -> ReadS TypedExpr
Read, Int -> TypedExpr -> ShowS
[TypedExpr] -> ShowS
TypedExpr -> FilePath
(Int -> TypedExpr -> ShowS)
-> (TypedExpr -> FilePath)
-> ([TypedExpr] -> ShowS)
-> Show TypedExpr
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TypedExpr] -> ShowS
$cshowList :: [TypedExpr] -> ShowS
show :: TypedExpr -> FilePath
$cshow :: TypedExpr -> FilePath
showsPrec :: Int -> TypedExpr -> ShowS
$cshowsPrec :: Int -> TypedExpr -> ShowS
Show)

makeLenses ''TypedExpr

instance NFData TypedExpr where
	rnf :: TypedExpr -> ()
rnf (TypedExpr Maybe Path
e Path
t) = Maybe Path -> ()
forall a. NFData a => a -> ()
rnf Maybe Path
e () -> () -> ()
`seq` Path -> ()
forall a. NFData a => a -> ()
rnf Path
t

instance ToJSON TypedExpr where
	toJSON :: TypedExpr -> Value
toJSON (TypedExpr Maybe Path
e Path
t) = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> [Pair]
noNulls [
		Path
"expr" Path -> Maybe Path -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Path -> v -> kv
.= Maybe Path
e,
		Path
"type" Path -> Path -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Path -> v -> kv
.= Path
t]

instance FromJSON TypedExpr where
	parseJSON :: Value -> Parser TypedExpr
parseJSON = FilePath
-> (Object -> Parser TypedExpr) -> Value -> Parser TypedExpr
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"typed-expr" ((Object -> Parser TypedExpr) -> Value -> Parser TypedExpr)
-> (Object -> Parser TypedExpr) -> Value -> Parser TypedExpr
forall a b. (a -> b) -> a -> b
$ \Object
v -> Maybe Path -> Path -> TypedExpr
TypedExpr (Maybe Path -> Path -> TypedExpr)
-> Parser (Maybe Path) -> Parser (Path -> TypedExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
		Object
v Object -> Path -> Parser (Maybe Path)
forall a. FromJSON a => Object -> Path -> Parser (Maybe a)
.::? Path
"expr" Parser (Path -> TypedExpr) -> Parser Path -> Parser TypedExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
		Object
v Object -> Path -> Parser Path
forall a. FromJSON a => Object -> Path -> Parser a
.:: Path
"type"

-- | Get all types in module
fileTypes :: (MonadLog m, MonadFail m, GhcMonad m) => Module -> Maybe Text -> m [Note TypedExpr]
fileTypes :: Module -> Maybe Path -> m [Note TypedExpr]
fileTypes Module
m Maybe Path
msrc = Path -> m [Note TypedExpr] -> m [Note TypedExpr]
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Path -> m a -> m a
scope Path
"types" (m [Note TypedExpr] -> m [Note TypedExpr])
-> m [Note TypedExpr] -> m [Note TypedExpr]
forall a b. (a -> b) -> a -> b
$ case Getting ModuleLocation Module ModuleLocation
-> Module -> ModuleLocation
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ModuleId -> Const ModuleLocation ModuleId)
-> Module -> Const ModuleLocation Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const ModuleLocation ModuleId)
 -> Module -> Const ModuleLocation Module)
-> ((ModuleLocation -> Const ModuleLocation ModuleLocation)
    -> ModuleId -> Const ModuleLocation ModuleId)
-> Getting ModuleLocation Module ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const ModuleLocation ModuleLocation)
-> ModuleId -> Const ModuleLocation ModuleId
Lens' ModuleId ModuleLocation
moduleLocation) Module
m of
	FileModule Path
file Maybe Project
proj -> do
		Path
file' <- IO Path -> m Path
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Path -> m Path) -> IO Path -> m Path
forall a b. (a -> b) -> a -> b
$ Path -> IO Path
forall a. Paths a => a -> IO a
canonicalize Path
file
		Path
cts <- m Path -> (Path -> m Path) -> Maybe Path -> m Path
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO Path -> m Path
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Path -> m Path) -> IO Path -> m Path
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Path
readFileUtf8 (Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path Path
file')) Path -> m Path
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Path
msrc
		let
			dir :: Path
dir = Path -> Maybe Path -> Path
forall a. a -> Maybe a -> a
fromMaybe
				(Path -> Path -> Path
sourceModuleRoot (Getting Path Module Path -> Module -> Path
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ModuleId -> Const Path ModuleId) -> Module -> Const Path Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const Path ModuleId) -> Module -> Const Path Module)
-> ((Path -> Const Path Path) -> ModuleId -> Const Path ModuleId)
-> Getting Path Module Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> Const Path Path) -> ModuleId -> Const Path ModuleId
Lens' ModuleId Path
moduleName) Module
m) Path
file') (Maybe Path -> Path) -> Maybe Path -> Path
forall a b. (a -> b) -> a -> b
$
				Getting (First Path) (Maybe Project) Path
-> Maybe Project -> Maybe Path
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((Project -> Const (First Path) Project)
-> Maybe Project -> Const (First Path) (Maybe Project)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((Project -> Const (First Path) Project)
 -> Maybe Project -> Const (First Path) (Maybe Project))
-> ((Path -> Const (First Path) Path)
    -> Project -> Const (First Path) Project)
-> Getting (First Path) (Maybe Project) Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> Const (First Path) Path)
-> Project -> Const (First Path) Project
Lens' Project Path
projectPath) Maybe Project
proj
		Bool
ex <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Path -> IO Bool
dirExists Path
dir
		(if Bool
ex then FilePath -> m [Note TypedExpr] -> m [Note TypedExpr]
forall (m :: * -> *) a. GhcMonad m => FilePath -> m a -> m a
Ghc.withCurrentDirectory (Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path Path
dir) else m [Note TypedExpr] -> m [Note TypedExpr]
forall a. a -> a
id) (m [Note TypedExpr] -> m [Note TypedExpr])
-> m [Note TypedExpr] -> m [Note TypedExpr]
forall a b. (a -> b) -> a -> b
$ do
			Target
target <- Path -> Maybe Path -> m Target
forall (m :: * -> *). GhcMonad m => Path -> Maybe Path -> m Target
makeTarget (Path -> Path -> Path
relPathTo Path
dir Path
file') Maybe Path
msrc
			[Target] -> m ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
loadTargets [Target
target]
			[(SrcSpan, Type)]
ts <- Path -> m [(SrcSpan, Type)]
forall (m :: * -> *).
(MonadFail m, GhcMonad m) =>
Path -> m [(SrcSpan, Type)]
moduleTypes Path
file'
			DynFlags
df <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
			[Note TypedExpr] -> m [Note TypedExpr]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Note TypedExpr] -> m [Note TypedExpr])
-> [Note TypedExpr] -> m [Note TypedExpr]
forall a b. (a -> b) -> a -> b
$ ((SrcSpan, Type) -> Note TypedExpr)
-> [(SrcSpan, Type)] -> [Note TypedExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Path -> Note Path -> Note TypedExpr
setExpr Path
cts (Note Path -> Note TypedExpr)
-> ((SrcSpan, Type) -> Note Path)
-> (SrcSpan, Type)
-> Note TypedExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Int -> Note Path -> Note Path
forall a. RecalcTabs a => Path -> Int -> a -> a
recalcTabs Path
cts Int
8 (Note Path -> Note Path)
-> ((SrcSpan, Type) -> Note Path) -> (SrcSpan, Type) -> Note Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SrcSpan -> Type -> Note Path) -> (SrcSpan, Type) -> Note Path
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (DynFlags -> SrcSpan -> Type -> Note Path
toNote DynFlags
df)) [(SrcSpan, Type)]
ts
	ModuleLocation
_ -> HsDevError -> m [Note TypedExpr]
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> m [Note TypedExpr])
-> HsDevError -> m [Note TypedExpr]
forall a b. (a -> b) -> a -> b
$ ModuleLocation -> HsDevError
ModuleNotSource (Getting ModuleLocation Module ModuleLocation
-> Module -> ModuleLocation
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ModuleId -> Const ModuleLocation ModuleId)
-> Module -> Const ModuleLocation Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const ModuleLocation ModuleId)
 -> Module -> Const ModuleLocation Module)
-> ((ModuleLocation -> Const ModuleLocation ModuleLocation)
    -> ModuleId -> Const ModuleLocation ModuleId)
-> Getting ModuleLocation Module ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const ModuleLocation ModuleLocation)
-> ModuleId -> Const ModuleLocation ModuleId
Lens' ModuleId ModuleLocation
moduleLocation) Module
m)
	where
		toNote :: DynFlags -> SrcSpan -> Type -> Note Text
		toNote :: DynFlags -> SrcSpan -> Type -> Note Path
toNote DynFlags
df SrcSpan
spn Type
tp = Note :: forall a1.
ModuleLocation -> Region -> Maybe Severity -> a1 -> Note a1
Note {
			_noteSource :: ModuleLocation
_noteSource = ModuleLocation
noLocation,
			_noteRegion :: Region
_noteRegion = SrcSpan -> Region
spanRegion SrcSpan
spn,
			_noteLevel :: Maybe Severity
_noteLevel = Maybe Severity
forall a. Maybe a
Nothing,
			_note :: Path
_note = FilePath -> Path
forall a. IsString a => FilePath -> a
fromString (FilePath -> Path) -> FilePath -> Path
forall a b. (a -> b) -> a -> b
$ DynFlags -> Type -> FilePath
showType DynFlags
df Type
tp }
		setExpr :: Text -> Note Text -> Note TypedExpr
		setExpr :: Path -> Note Path -> Note TypedExpr
setExpr Path
cts Note Path
n = ASetter (Note Path) (Note TypedExpr) Path TypedExpr
-> (Path -> TypedExpr) -> Note Path -> Note TypedExpr
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Note Path) (Note TypedExpr) Path TypedExpr
forall a1 a2. Lens (Note a1) (Note a2) a1 a2
note (Maybe Path -> Path -> TypedExpr
TypedExpr (Path -> Maybe Path
forall a. a -> Maybe a
Just (Region -> Path -> Path
regionStr (Getting Region (Note Path) Region -> Note Path -> Region
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Region (Note Path) Region
forall a1. Lens' (Note a1) Region
noteRegion Note Path
n) Path
cts))) Note Path
n
		showType :: DynFlags -> Type -> String
		showType :: DynFlags -> Type -> FilePath
showType DynFlags
df = Mode -> Int -> Doc -> FilePath
renderStyle Mode
Pretty.OneLineMode Int
80 (Doc -> FilePath) -> (Type -> Doc) -> Type -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> PprStyle -> SDoc -> Doc
withPprStyleDoc DynFlags
df (DynFlags -> PprStyle
unqualStyle DynFlags
df) (SDoc -> Doc) -> (Type -> SDoc) -> Type -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> SDoc
pprTypeForUser

-- | Set types to module
setModuleTypes :: [Note TypedExpr] -> Module -> Module
setModuleTypes :: [Note TypedExpr] -> Module -> Module
setModuleTypes [Note TypedExpr]
ts = ASetter Module Module Symbol Symbol
-> (Symbol -> Symbol) -> Module -> Module
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Map Name [Symbol] -> Identity (Map Name [Symbol]))
-> Module -> Identity Module
Lens' Module (Map Name [Symbol])
moduleScope ((Map Name [Symbol] -> Identity (Map Name [Symbol]))
 -> Module -> Identity Module)
-> ((Symbol -> Identity Symbol)
    -> Map Name [Symbol] -> Identity (Map Name [Symbol]))
-> ASetter Module Module Symbol Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Symbol] -> Identity [Symbol])
-> Map Name [Symbol] -> Identity (Map Name [Symbol])
forall s t a b. Each s t a b => Traversal s t a b
each (([Symbol] -> Identity [Symbol])
 -> Map Name [Symbol] -> Identity (Map Name [Symbol]))
-> ((Symbol -> Identity Symbol) -> [Symbol] -> Identity [Symbol])
-> (Symbol -> Identity Symbol)
-> Map Name [Symbol]
-> Identity (Map Name [Symbol])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Symbol -> Identity Symbol) -> [Symbol] -> Identity [Symbol]
forall s t a b. Each s t a b => Traversal s t a b
each) Symbol -> Symbol
setType (Module -> Module) -> (Module -> Module) -> Module -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter Module Module Symbol Symbol
-> (Symbol -> Symbol) -> Module -> Module
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (([Symbol] -> Identity [Symbol]) -> Module -> Identity Module
Lens' Module [Symbol]
moduleExports (([Symbol] -> Identity [Symbol]) -> Module -> Identity Module)
-> ((Symbol -> Identity Symbol) -> [Symbol] -> Identity [Symbol])
-> ASetter Module Module Symbol Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Symbol -> Identity Symbol) -> [Symbol] -> Identity [Symbol]
forall s t a b. Each s t a b => Traversal s t a b
each) Symbol -> Symbol
setType where
	setType :: Symbol -> Symbol
	setType :: Symbol -> Symbol
setType Symbol
d = Symbol -> Maybe Symbol -> Symbol
forall a. a -> Maybe a -> a
fromMaybe Symbol
d (Maybe Symbol -> Symbol) -> Maybe Symbol -> Symbol
forall a b. (a -> b) -> a -> b
$ do
		Position
pos <- Getting (Maybe Position) Symbol (Maybe Position)
-> Symbol -> Maybe Position
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Position) Symbol (Maybe Position)
Lens' Symbol (Maybe Position)
symbolPosition Symbol
d
		Note TypedExpr
tnote <- (Note TypedExpr -> Bool)
-> [Note TypedExpr] -> Maybe (Note TypedExpr)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
pos) (Position -> Bool)
-> (Note TypedExpr -> Position) -> Note TypedExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Position (Note TypedExpr) Position
-> Note TypedExpr -> Position
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Region -> Const Position Region)
-> Note TypedExpr -> Const Position (Note TypedExpr)
forall a1. Lens' (Note a1) Region
noteRegion ((Region -> Const Position Region)
 -> Note TypedExpr -> Const Position (Note TypedExpr))
-> ((Position -> Const Position Position)
    -> Region -> Const Position Region)
-> Getting Position (Note TypedExpr) Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const Position Position)
-> Region -> Const Position Region
Lens' Region Position
regionFrom)) [Note TypedExpr]
ts
		Symbol -> Maybe Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return (Symbol -> Maybe Symbol) -> Symbol -> Maybe Symbol
forall a b. (a -> b) -> a -> b
$ ASetter Symbol Symbol (Maybe Path) (Maybe Path)
-> Maybe Path -> Symbol -> Symbol
forall s t a b. ASetter s t a b -> b -> s -> t
set ((SymbolInfo -> Identity SymbolInfo) -> Symbol -> Identity Symbol
Lens' Symbol SymbolInfo
symbolInfo ((SymbolInfo -> Identity SymbolInfo) -> Symbol -> Identity Symbol)
-> ((Maybe Path -> Identity (Maybe Path))
    -> SymbolInfo -> Identity SymbolInfo)
-> ASetter Symbol Symbol (Maybe Path) (Maybe Path)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Path -> Identity (Maybe Path))
-> SymbolInfo -> Identity SymbolInfo
Traversal' SymbolInfo (Maybe Path)
functionType) (Path -> Maybe Path
forall a. a -> Maybe a
Just (Path -> Maybe Path) -> Path -> Maybe Path
forall a b. (a -> b) -> a -> b
$ Getting Path (Note TypedExpr) Path -> Note TypedExpr -> Path
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((TypedExpr -> Const Path TypedExpr)
-> Note TypedExpr -> Const Path (Note TypedExpr)
forall a1 a2. Lens (Note a1) (Note a2) a1 a2
note ((TypedExpr -> Const Path TypedExpr)
 -> Note TypedExpr -> Const Path (Note TypedExpr))
-> ((Path -> Const Path Path) -> TypedExpr -> Const Path TypedExpr)
-> Getting Path (Note TypedExpr) Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> Const Path Path) -> TypedExpr -> Const Path TypedExpr
Lens' TypedExpr Path
typedType) Note TypedExpr
tnote) Symbol
d

-- | Infer types in module
inferTypes :: (MonadLog m, MonadFail m, GhcMonad m) => Module -> Maybe Text -> m Module
inferTypes :: Module -> Maybe Path -> m Module
inferTypes Module
m Maybe Path
msrc = Path -> m Module -> m Module
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Path -> m a -> m a
scope Path
"infer" (m Module -> m Module) -> m Module -> m Module
forall a b. (a -> b) -> a -> b
$ ([Note TypedExpr] -> Module) -> m [Note TypedExpr] -> m Module
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([Note TypedExpr] -> Module -> Module
`setModuleTypes` Module
m) (m [Note TypedExpr] -> m Module) -> m [Note TypedExpr] -> m Module
forall a b. (a -> b) -> a -> b
$ Module -> Maybe Path -> m [Note TypedExpr]
forall (m :: * -> *).
(MonadLog m, MonadFail m, GhcMonad m) =>
Module -> Maybe Path -> m [Note TypedExpr]
fileTypes Module
m Maybe Path
msrc