{-# LANGUAGE OverloadedStrings #-}

module HsDev.Tools.Ghc.Check (
	check,

	Ghc,
	module HsDev.Tools.Types,
	module HsDev.Symbols.Types,
	PackageDb(..), PackageDbStack(..), Project(..),

	module Control.Monad.Except
	) where

import Control.Lens (view, (^.))
import Control.Monad.Except
import qualified Data.Map as M
import Data.Text (Text)
import System.Log.Simple (MonadLog(..), scope, sendLog, Level(Trace))

import GHC hiding (Warning, Module)

import HsDev.Error
import HsDev.PackageDb
import HsDev.Symbols.Location
import HsDev.Symbols.Types
import HsDev.Tools.Base
import HsDev.Tools.Ghc.Worker
import HsDev.Tools.Types
import HsDev.Tools.Tabs
import System.Directory.Paths

-- | Check module source
check :: (MonadLog m, GhcMonad m) => Module -> Maybe Text -> m [Note OutputMessage]
check :: Module -> Maybe Text -> m [Note OutputMessage]
check Module
m Maybe Text
msrc = Text -> m [Note OutputMessage] -> m [Note OutputMessage]
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
scope Text
"check" (m [Note OutputMessage] -> m [Note OutputMessage])
-> m [Note OutputMessage] -> m [Note OutputMessage]
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 Text
file Maybe Project
_ -> do
		let
			dir :: Text
dir = ModuleId -> Text
sourceRoot_ (Module
m Module -> Getting ModuleId Module ModuleId -> ModuleId
forall s a. s -> Getting a s a -> a
^. Getting ModuleId Module ModuleId
Lens' Module ModuleId
moduleId)
			-- FIXME: There can be dependent modules with modified file contents
			-- Their contents should be set here too
			srcs :: Map Text Text
srcs = Map Text Text
-> (Text -> Map Text Text) -> Maybe Text -> Map Text Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map Text Text
forall a. Monoid a => a
mempty (Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
M.singleton Text
file) Maybe Text
msrc
		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
$ Text -> IO Bool
dirExists Text
dir
		Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
sendLog Level
Trace Text
"loading targets"
		[Note OutputMessage]
notes <- m [Note OutputMessage] -> m [Note OutputMessage]
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withFlags (m [Note OutputMessage] -> m [Note OutputMessage])
-> m [Note OutputMessage] -> m [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$ (if Bool
ex then FilePath -> m [Note OutputMessage] -> m [Note OutputMessage]
forall (m :: * -> *) a. GhcMonad m => FilePath -> m a -> m a
withCurrentDirectory (Text
dir Text -> Getting FilePath Text FilePath -> FilePath
forall s a. s -> Getting a s a -> a
^. Getting FilePath Text FilePath
Lens' Text FilePath
path) else m [Note OutputMessage] -> m [Note OutputMessage]
forall a. a -> a
id) (m [Note OutputMessage] -> m [Note OutputMessage])
-> m [Note OutputMessage] -> m [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$ m () -> m [Note OutputMessage]
forall (m :: * -> *). GhcMonad m => m () -> m [Note OutputMessage]
collectMessages_ (m () -> m [Note OutputMessage]) -> m () -> m [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$ do
			Target
target <- Text -> Maybe Text -> m Target
forall (m :: * -> *). GhcMonad m => Text -> Maybe Text -> m Target
makeTarget (Text -> Text -> Text
relPathTo Text
dir Text
file) Maybe Text
msrc
			[Target] -> m ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
loadTargets [Target
target]
		Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
sendLog Level
Trace Text
"targets checked"
		IO [Note OutputMessage] -> m [Note OutputMessage]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Note OutputMessage] -> m [Note OutputMessage])
-> IO [Note OutputMessage] -> m [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$ Map Text Text -> [Note OutputMessage] -> IO [Note OutputMessage]
forall a. Map Text Text -> [Note a] -> IO [Note a]
recalcNotesTabs Map Text Text
srcs [Note OutputMessage]
notes
	ModuleLocation
_ -> Text -> m [Note OutputMessage] -> m [Note OutputMessage]
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
scope Text
"check" (m [Note OutputMessage] -> m [Note OutputMessage])
-> m [Note OutputMessage] -> m [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$ HsDevError -> m [Note OutputMessage]
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> m [Note OutputMessage])
-> HsDevError -> m [Note OutputMessage]
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)