module Language.Haskell.Refact.Utils.Monad
( ParseResult
, VerboseLevel(..)
, RefactSettings(..)
, RefactState(..)
, RefactModule(..)
, RefactStashId(..)
, RefactFlags(..)
, StateStorage(..)
, RefactGhc
, runRefactGhc
, getRefacSettings
, defaultSettings
, logSettings
, initGhcSession
) where
import Control.Monad.State
import Exception
import qualified Control.Monad.IO.Class as MU
import qualified GHC as GHC
import qualified GHC.Paths as GHC
import qualified GhcMonad as GHC
import qualified MonadUtils as GHC
import Data.List
import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal
import Language.Haskell.Refact.Utils.TokenUtilsTypes
import Language.Haskell.Refact.Utils.TypeSyn
data VerboseLevel = Debug | Normal | Off
deriving (Eq,Show)
data RefactSettings = RefSet
{ rsetGhcOpts :: ![String]
, rsetImportPaths :: ![FilePath]
, rsetExpandSplice :: Bool
, rsetMainFile :: Maybe FilePath
, rsetSandbox :: Maybe FilePath
, rsetCheckTokenUtilsInvariant :: !Bool
, rsetVerboseLevel :: !VerboseLevel
} deriving (Show)
defaultSettings :: RefactSettings
defaultSettings = RefSet [] [] False Nothing Nothing False Normal
logSettings :: RefactSettings
logSettings = defaultSettings { rsetVerboseLevel = Debug }
data RefactStashId = Stash !String deriving (Show,Eq,Ord)
data RefactModule = RefMod
{ rsTypecheckedMod :: !GHC.TypecheckedModule
, rsOrigTokenStream :: ![PosToken]
, rsTokenCache :: !TokenCache
, rsStreamModified :: !Bool
}
data RefactFlags = RefFlags
{ rsDone :: !Bool
}
data RefactState = RefSt
{ rsSettings :: !RefactSettings
, rsUniqState :: !Int
, rsFlags :: !RefactFlags
, rsStorage :: !StateStorage
, rsModule :: !(Maybe RefactModule)
}
type ParseResult = GHC.TypecheckedModule
data StateStorage = StorageNone
| StorageBind (GHC.LHsBind GHC.Name)
| StorageSig (GHC.LSig GHC.Name)
instance Show StateStorage where
show StorageNone = "StorageNone"
show (StorageBind _bind) = "(StorageBind " ++ ")"
show (StorageSig _sig) = "(StorageSig " ++ ")"
type RefactGhc a = GHC.GhcT (StateT RefactState IO) a
instance (MU.MonadIO (GHC.GhcT (StateT RefactState IO))) where
liftIO = GHC.liftIO
instance GHC.MonadIO (StateT RefactState IO) where
liftIO f = MU.liftIO f
instance ExceptionMonad m => ExceptionMonad (StateT s m) where
gcatch f h = StateT $ \s -> gcatch (runStateT f s) (\e -> runStateT (h e) s)
gblock = mapStateT gblock
gunblock = mapStateT gunblock
instance (MonadState RefactState (GHC.GhcT (StateT RefactState IO))) where
get = lift get
put = lift . put
instance (MonadTrans GHC.GhcT) where
lift = GHC.liftGhcT
instance (MonadPlus m,Functor m,GHC.MonadIO m,ExceptionMonad m) => MonadPlus (GHC.GhcT m) where
mzero = GHC.GhcT $ \_s -> mzero
x `mplus` y = GHC.GhcT $ \_s -> (GHC.runGhcT (Just GHC.libdir) x) `mplus` (GHC.runGhcT (Just GHC.libdir) y)
initGhcSession :: Cradle -> [FilePath] -> RefactGhc ()
initGhcSession cradle importDirs = do
settings <- getRefacSettings
let ghcOptsDirs =
case importDirs of
[] -> (rsetGhcOpts settings)
_ -> ("-i" ++ (intercalate ":" importDirs)):(rsetGhcOpts settings)
let opt = Options {
outputStyle = PlainStyle
, hlintOpts = []
, ghcOpts = ghcOptsDirs
, operators = False
, detailed = False
, expandSplice = False
, sandbox = (rsetSandbox settings)
, lineSeparator = LineSeparator "\n"
}
_readLog <- initializeFlagsWithCradle opt cradle (options settings) True
void $ GHC.load GHC.LoadAllTargets
return ()
where
options opt
| rsetExpandSplice opt = "-w:" : rsetGhcOpts opt
| otherwise = "-Wall" : rsetGhcOpts opt
runRefactGhc ::
RefactGhc a -> RefactState -> IO (a, RefactState)
runRefactGhc comp initState = do
runStateT (GHC.runGhcT (Just GHC.libdir) comp) initState
getRefacSettings :: RefactGhc RefactSettings
getRefacSettings = do
s <- get
return (rsSettings s)