{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, RankNTypes,
StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell,
GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
module Language.Haskell.GhcMod.Types (
module Language.Haskell.GhcMod.Types
, ModuleName
, mkModuleName
, moduleNameString
) where
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Error (Error(..))
import qualified Control.Monad.IO.Class as MTL
import Control.Exception (Exception)
import Control.Applicative
import Control.Concurrent
import Control.Monad
import Control.DeepSeq
import Data.Binary
import Data.Binary.Generic
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Monoid
import Data.Maybe
import Data.Typeable (Typeable)
import Data.IORef
import Data.Label.Derive
import Distribution.Helper hiding (Programs(..))
import qualified Distribution.Helper as CabalHelper
import Exception (ExceptionMonad)
#if __GLASGOW_HASKELL__ < 708
import qualified MonadUtils as GHC (MonadIO(..))
#endif
import GHC (ModuleName, moduleNameString, mkModuleName)
import HscTypes (HscEnv)
import GHC.Generics
import Text.PrettyPrint (Doc)
import Prelude
import Language.Haskell.GhcMod.Caching.Types
type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m)
#if __GLASGOW_HASKELL__ < 708
type MonadIOC m = (GHC.MonadIO m, MTL.MonadIO m)
#else
type MonadIOC m = (MTL.MonadIO m)
#endif
class MonadIOC m => MonadIO m where
liftIO :: IO a -> m a
data OutputStyle = LispStyle
| PlainStyle
deriving (Show)
newtype LineSeparator = LineSeparator String deriving (Show)
data FileMapping = FileMapping {fmPath :: FilePath, fmTemp :: Bool}
deriving (Eq, Show)
type FileMappingMap = Map FilePath FileMapping
data ProgramSource = ProgramSourceUser | ProgramSourceStack
data Programs = Programs {
ghcProgram :: FilePath
, ghcPkgProgram :: FilePath
, cabalProgram :: FilePath
, stackProgram :: FilePath
} deriving (Show)
data OutputOpts = OutputOpts {
ooptLogLevel :: GmLogLevel
, ooptStyle :: OutputStyle
, ooptLineSeparator :: LineSeparator
, ooptLinePrefix :: Maybe (String, String)
} deriving (Show)
data Options = Options {
optOutput :: OutputOpts
, optPrograms :: Programs
, optGhcUserOptions :: [GHCOption]
, optFileMappings :: [(FilePath, Maybe FilePath)]
, optEncoding :: String
} deriving (Show)
defaultOptions :: Options
defaultOptions = Options {
optOutput = OutputOpts {
ooptLogLevel = GmWarning
, ooptStyle = PlainStyle
, ooptLineSeparator = LineSeparator "\0"
, ooptLinePrefix = Nothing
}
, optPrograms = Programs {
ghcProgram = "ghc"
, ghcPkgProgram = "ghc-pkg"
, cabalProgram = "cabal"
, stackProgram = "stack"
}
, optGhcUserOptions = []
, optFileMappings = []
, optEncoding = "UTF-8"
}
data Project = CabalProject
| SandboxProject
| PlainProject
| StackProject StackEnv
deriving (Eq, Show, Ord)
isCabalHelperProject :: Project -> Bool
isCabalHelperProject StackProject {} = True
isCabalHelperProject CabalProject {} = True
isCabalHelperProject _ = False
data StackEnv = StackEnv {
seDistDir :: FilePath
, seBinPath :: [FilePath]
, seSnapshotPkgDb :: FilePath
, seLocalPkgDb :: FilePath
} deriving (Eq, Show, Ord)
data Cradle = Cradle {
cradleProject :: Project
, cradleCurrentDir :: FilePath
, cradleRootDir :: FilePath
, cradleTempDir :: FilePath
, cradleCabalFile :: Maybe FilePath
, cradleDistDir :: FilePath
} deriving (Eq, Show, Ord)
data GmStream = GmOutStream | GmErrStream
deriving (Show)
data GhcModEnv = GhcModEnv {
gmOptions :: Options
, gmCradle :: Cradle
}
data GhcModOut = GhcModOut {
gmoOptions :: OutputOpts
, gmoChan :: Chan (Either (MVar ()) (GmStream, String))
}
data GhcModLog = GhcModLog {
gmLogLevel :: Maybe GmLogLevel,
gmLogVomitDump :: Last Bool,
gmLogMessages :: [(GmLogLevel, String, Doc)]
} deriving (Show)
instance Monoid GhcModLog where
mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty
GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' =
GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls')
data GmGhcSession = GmGhcSession {
gmgsOptions :: ![GHCOption],
gmgsSession :: !(IORef HscEnv)
}
data GhcModCaches = GhcModCaches {
gmcPackageDbStack :: CacheContents ChCacheData [GhcPkgDb]
, gmcMergedPkgOptions :: CacheContents ChCacheData [GHCOption]
, gmcComponents :: CacheContents ChCacheData [GmComponent 'GMCRaw ChEntrypoint]
, gmcResolvedComponents :: CacheContents
[GmComponent 'GMCRaw (Set.Set ModulePath)]
(Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath)))
}
data GhcModState = GhcModState {
gmGhcSession :: !(Maybe GmGhcSession)
, gmCaches :: !GhcModCaches
, gmMMappedFiles :: !FileMappingMap
}
defaultGhcModState :: GhcModState
defaultGhcModState =
GhcModState n (GhcModCaches n n n n) Map.empty
where n = Nothing
----------------------------------------------------------------
-- | GHC package database flags.
data GhcPkgDb = GlobalDb
| UserDb
| PackageDb String
deriving (Eq, Show, Generic)
instance Binary GhcPkgDb where
put = ggput . from
get = to `fmap` ggget
-- | A single GHC command line option.
type GHCOption = String
-- | An include directory for modules.
type IncludeDir = FilePath
-- | Haskell expression.
newtype Expression = Expression { getExpression :: String }
deriving (Show, Eq, Ord)
-- | Module name.
newtype ModuleString = ModuleString { getModuleString :: String }
deriving (Show, Eq, Ord, Binary, NFData)
data GmLogLevel =
GmSilent
| GmPanic
| GmException
| GmError
| GmWarning
| GmInfo
| GmDebug
| GmVomit
deriving (Eq, Ord, Enum, Bounded, Show, Read)
data GmModuleGraph = GmModuleGraph {
gmgGraph :: Map ModulePath (Set ModulePath)
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Binary GmModuleGraph where
put GmModuleGraph {..} = put (mpim, graph)
where
mpim :: Map ModulePath Integer
mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..]
graph :: Map Integer (Set Integer)
graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph
mpToInt :: ModulePath -> Integer
mpToInt mp = fromJust $ Map.lookup mp mpim
get = do
(mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get
let impm = swapMap mpim
intToMp i = fromJust $ Map.lookup i impm
mpGraph :: Map ModulePath (Set ModulePath)
mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph
return $ GmModuleGraph mpGraph
where
swapMap :: Ord v => Map k v -> Map v k
swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList
instance Monoid GmModuleGraph where
mempty = GmModuleGraph mempty
mappend (GmModuleGraph a) (GmModuleGraph a') =
GmModuleGraph (Map.unionWith Set.union a a')
data GmComponentType = GMCRaw
| GMCResolved
data GmComponent (t :: GmComponentType) eps = GmComponent {
gmcHomeModuleGraph :: GmModuleGraph
, gmcName :: ChComponentName
, gmcGhcOpts :: [GHCOption]
, gmcGhcPkgOpts :: [GHCOption]
, gmcGhcSrcOpts :: [GHCOption]
, gmcGhcLangOpts :: [GHCOption]
, gmcRawEntrypoints :: ChEntrypoint
, gmcEntrypoints :: eps
, gmcSourceDirs :: [FilePath]
} deriving (Eq, Ord, Show, Read, Generic, Functor)
instance Binary eps => Binary (GmComponent t eps) where
put = ggput . from
get = to `fmap` ggget
data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath }
deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Binary ModulePath where
put = ggput . from
get = to `fmap` ggget
instance Binary ModuleName where
get = mkModuleName <$> get
put mn = put (moduleNameString mn)
instance Show ModuleName where
show mn = "ModuleName " ++ show (moduleNameString mn)
instance Read ModuleName where
readsPrec d =
readParen
(d > app_prec)
(\r' -> [ (mkModuleName m, t)
| ("ModuleName", s) <- lex r'
, (m, t) <- readsPrec (app_prec + 1) s
])
where
app_prec = 10
data GhcModError
= GMENoMsg
-- ^ Unknown error
| GMEString String
-- ^ Some Error with a message. These are produced mostly by
-- 'fail' calls on GhcModT.
| GMECabalConfigure GhcModError
-- ^ Configuring a cabal project failed.
| GMEStackConfigure GhcModError
-- ^ Configuring a stack project failed.
| GMEStackBootstrap GhcModError
-- ^ Bootstrapping @stack@ environment failed (process exited with failure)
| GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
-- ^ Could not find a consistent component assignment for modules
| GMEProcess String String [String] (Either Int GhcModError)
-- ^ Launching an operating system process failed. Fields in
-- order: function, command, arguments, (stdout, stderr, exitcode)
| GMENoCabalFile
-- ^ No cabal file found.
| GMETooManyCabalFiles [FilePath]
-- ^ Too many cabal files found.
deriving (Eq,Show,Typeable)
instance Error GhcModError where
noMsg = GMENoMsg
strMsg = GMEString
instance Exception GhcModError
instance Binary CabalHelper.Programs where
put = ggput . from
get = to `fmap` ggget
instance Binary ChModuleName where
put = ggput . from
get = to `fmap` ggget
instance Binary ChComponentName where
put = ggput . from
get = to `fmap` ggget
instance Binary ChEntrypoint where
put = ggput . from
get = to `fmap` ggget
-- | Options for "lintWith" function
data LintOpts = LintOpts {
optLintHlintOpts :: [String]
-- ^ options that will be passed to hlint executable
} deriving (Show)
-- | Default "LintOpts" instance
defaultLintOpts :: LintOpts
defaultLintOpts = LintOpts []
-- | Options for "browseWith" function
data BrowseOpts = BrowseOpts {
optBrowseOperators :: Bool
-- ^ If 'True', "browseWith" also returns operators.
, optBrowseDetailed :: Bool
-- ^ If 'True', "browseWith" also returns types.
, optBrowseParents :: Bool
-- ^ If 'True', "browseWith" also returns parents.
, optBrowseQualified :: Bool
-- ^ If 'True', "browseWith" will return fully qualified name
} deriving (Show)
-- | Default "BrowseOpts" instance
defaultBrowseOpts :: BrowseOpts
defaultBrowseOpts = BrowseOpts False False False False
mkLabel ''GhcModCaches
mkLabel ''GhcModState
mkLabel ''Options
mkLabel ''OutputOpts
mkLabel ''Programs