{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module HsDev.Tools.Ghc.Session (
	targetSession, interpretModule,

	module HsDev.Tools.Ghc.Worker
	) where

import Control.Lens
import Data.Maybe (isJust)
import Data.Text (Text, unpack)
import System.Log.Simple

import Control.Concurrent.Worker
import System.Directory.Paths
import HsDev.Symbols.Types
import HsDev.Sandbox (getModuleOpts)
import HsDev.Tools.Ghc.Worker

import qualified GHC

-- | Session for module
targetSession :: [String] -> Module -> GhcM ()
targetSession :: [String] -> Module -> GhcM ()
targetSession [String]
opts Module
m = do
	(PackageDbStack
pdbs, [String]
opts') <- [String] -> Module -> GhcM (PackageDbStack, [String])
getModuleOpts [String]
opts Module
m
	PackageDbStack -> [String] -> GhcM ()
ghcSession PackageDbStack
pdbs (String
"-Wall" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
opts')

-- | Interpret file
interpretModule :: Module -> Maybe Text -> GhcM ()
interpretModule :: Module -> Maybe Text -> GhcM ()
interpretModule Module
m Maybe Text
mcts
	| Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
mpath = do
		let
			rootDir :: Text
rootDir = Text -> (Project -> Text) -> Maybe Project -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Text
takeDir Text
fpath) (Getting Text Project Text -> Project -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Project Text
Lens' Project Text
projectPath) (Module
m Module -> Getting (First Project) Module Project -> Maybe Project
forall s a. s -> Getting (First a) s a -> Maybe a
^? (ModuleId -> Const (First Project) ModuleId)
-> Module -> Const (First Project) Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const (First Project) ModuleId)
 -> Module -> Const (First Project) Module)
-> ((Project -> Const (First Project) Project)
    -> ModuleId -> Const (First Project) ModuleId)
-> Getting (First Project) Module Project
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const (First Project) ModuleLocation)
-> ModuleId -> Const (First Project) ModuleId
Lens' ModuleId ModuleLocation
moduleLocation ((ModuleLocation -> Const (First Project) ModuleLocation)
 -> ModuleId -> Const (First Project) ModuleId)
-> ((Project -> Const (First Project) Project)
    -> ModuleLocation -> Const (First Project) ModuleLocation)
-> (Project -> Const (First Project) Project)
-> ModuleId
-> Const (First Project) ModuleId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Project -> Const (First Project) (Maybe Project))
-> ModuleLocation -> Const (First Project) ModuleLocation
Traversal' ModuleLocation (Maybe Project)
moduleProject ((Maybe Project -> Const (First Project) (Maybe Project))
 -> ModuleLocation -> Const (First Project) ModuleLocation)
-> ((Project -> Const (First Project) Project)
    -> Maybe Project -> Const (First Project) (Maybe Project))
-> (Project -> Const (First Project) Project)
-> ModuleLocation
-> Const (First Project) ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Project -> Const (First Project) Project)
-> Maybe Project -> Const (First Project) (Maybe Project)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
		String -> GhcM () -> GhcM ()
forall (m :: * -> *) a. GhcMonad m => String -> m a -> m a
withCurrentDirectory (Getting String Text String -> Text -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Text String
Lens' Text String
path Text
rootDir) (GhcM () -> GhcM ()) -> GhcM () -> GhcM ()
forall a b. (a -> b) -> a -> b
$ do
			Target
t <- Text
-> Maybe Text
-> MGhcT SessionConfig (First DynFlags) (LogT IO) Target
forall (m :: * -> *). GhcMonad m => Text -> Maybe Text -> m Target
makeTarget (Text -> Text -> Text
relPathTo Text
rootDir Text
fpath) Maybe Text
mcts
			[Target] -> GhcM ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
loadTargets [Target
t]
			[InteractiveImport] -> GhcM ()
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
GHC.setContext [ModuleName -> InteractiveImport
GHC.IIModule (ModuleName -> InteractiveImport)
-> (Module -> ModuleName) -> Module -> InteractiveImport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ModuleName
GHC.mkModuleName (String -> ModuleName)
-> (Module -> String) -> Module -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack (Text -> String) -> (Module -> Text) -> Module -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Text Module Text -> Module -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ModuleId -> Const Text ModuleId) -> Module -> Const Text Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const Text ModuleId) -> Module -> Const Text Module)
-> ((Text -> Const Text Text) -> ModuleId -> Const Text ModuleId)
-> Getting Text Module Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text) -> ModuleId -> Const Text ModuleId
Lens' ModuleId Text
moduleName) (Module -> InteractiveImport) -> Module -> InteractiveImport
forall a b. (a -> b) -> a -> b
$ Module
m]
	| Bool
otherwise = () -> GhcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
	where
		mpath :: Maybe Text
mpath = Module
m Module -> Getting (First Text) Module Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? (ModuleId -> Const (First Text) ModuleId)
-> Module -> Const (First Text) Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const (First Text) ModuleId)
 -> Module -> Const (First Text) Module)
-> ((Text -> Const (First Text) Text)
    -> ModuleId -> Const (First Text) ModuleId)
-> Getting (First Text) Module Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const (First Text) ModuleLocation)
-> ModuleId -> Const (First Text) ModuleId
Lens' ModuleId ModuleLocation
moduleLocation ((ModuleLocation -> Const (First Text) ModuleLocation)
 -> ModuleId -> Const (First Text) ModuleId)
-> ((Text -> Const (First Text) Text)
    -> ModuleLocation -> Const (First Text) ModuleLocation)
-> (Text -> Const (First Text) Text)
-> ModuleId
-> Const (First Text) ModuleId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (First Text) Text)
-> ModuleLocation -> Const (First Text) ModuleLocation
Traversal' ModuleLocation Text
moduleFile
		Just Text
fpath = Maybe Text
mpath