2015-04-02 23:15:12 +00:00
|
|
|
{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric,
|
|
|
|
StandaloneDeriving, DefaultSignatures, FlexibleInstances #-}
|
2015-03-11 12:17:24 +00:00
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
|
2015-03-03 20:12:43 +00:00
|
|
|
module Language.Haskell.GhcMod.Types (
|
|
|
|
module Language.Haskell.GhcMod.Types
|
|
|
|
, ModuleName
|
|
|
|
, mkModuleName
|
|
|
|
, moduleNameString
|
|
|
|
) where
|
2010-04-30 09:36:31 +00:00
|
|
|
|
2014-08-28 09:54:01 +00:00
|
|
|
import Control.Monad.Trans.Control (MonadBaseControl)
|
2015-03-03 20:12:43 +00:00
|
|
|
import Control.Monad.Error (Error(..))
|
2015-04-02 23:15:12 +00:00
|
|
|
import qualified Control.Monad.IO.Class as MTL
|
2015-03-03 20:12:43 +00:00
|
|
|
import Control.Exception (Exception)
|
2015-03-28 01:30:51 +00:00
|
|
|
import Control.Applicative
|
|
|
|
import Control.Arrow
|
|
|
|
import Data.Serialize
|
|
|
|
import Data.Version
|
2015-03-04 15:45:26 +00:00
|
|
|
import Data.List (intercalate)
|
2015-03-03 20:12:43 +00:00
|
|
|
import Data.Map (Map)
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
import Data.Set (Set)
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import Data.Monoid
|
2015-03-28 01:30:51 +00:00
|
|
|
import Data.Maybe
|
2015-03-03 20:12:43 +00:00
|
|
|
import Data.Typeable (Typeable)
|
2015-03-15 19:48:55 +00:00
|
|
|
import Distribution.Helper
|
2014-08-28 09:54:01 +00:00
|
|
|
import Exception (ExceptionMonad)
|
2015-04-02 23:15:12 +00:00
|
|
|
#if __GLASGOW_HASKELL__ < 708
|
|
|
|
import qualified MonadUtils as GHC (MonadIO(..))
|
|
|
|
#endif
|
2015-03-03 20:12:43 +00:00
|
|
|
import GHC (ModuleName, moduleNameString, mkModuleName)
|
2014-07-11 08:43:51 +00:00
|
|
|
import PackageConfig (PackageConfig)
|
2015-03-28 01:30:51 +00:00
|
|
|
import GHC.Generics
|
2014-04-17 21:40:11 +00:00
|
|
|
|
2014-08-28 09:54:01 +00:00
|
|
|
-- | A constraint alias (-XConstraintKinds) to make functions dealing with
|
|
|
|
-- 'GhcModT' somewhat cleaner.
|
|
|
|
--
|
|
|
|
-- Basicially an @IOish m => m@ is a 'Monad' supporting arbitrary 'IO' and
|
|
|
|
-- exception handling. Usually this will simply be 'IO' but we parametrise it in
|
|
|
|
-- the exported API so users have the option to use a custom inner monad.
|
|
|
|
type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m)
|
2014-08-12 16:08:28 +00:00
|
|
|
|
2015-04-02 23:15:12 +00:00
|
|
|
|
|
|
|
-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.
|
|
|
|
-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.
|
|
|
|
#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
|
|
|
|
|
2013-05-20 05:28:56 +00:00
|
|
|
-- | Output style.
|
2013-09-05 05:35:28 +00:00
|
|
|
data OutputStyle = LispStyle -- ^ S expression style.
|
|
|
|
| PlainStyle -- ^ Plain textstyle.
|
2014-10-22 22:53:41 +00:00
|
|
|
deriving (Show)
|
2012-02-14 01:21:48 +00:00
|
|
|
|
2013-09-05 05:35:28 +00:00
|
|
|
-- | The type for line separator. Historically, a Null string is used.
|
2014-10-22 22:53:41 +00:00
|
|
|
newtype LineSeparator = LineSeparator String deriving (Show)
|
2013-09-03 05:40:51 +00:00
|
|
|
|
2010-04-30 09:36:31 +00:00
|
|
|
data Options = Options {
|
2013-09-03 05:40:51 +00:00
|
|
|
outputStyle :: OutputStyle
|
2014-09-18 08:05:47 +00:00
|
|
|
-- | Line separator string.
|
|
|
|
, lineSeparator :: LineSeparator
|
2015-03-03 20:12:43 +00:00
|
|
|
-- | Verbosity
|
|
|
|
, logLevel :: GmLogLevel
|
2015-03-07 18:23:55 +00:00
|
|
|
-- | @ghc@ program name.
|
|
|
|
, ghcProgram :: FilePath
|
|
|
|
-- | @ghc-pkg@ program name.
|
|
|
|
, ghcPkgProgram :: FilePath
|
2014-09-18 08:05:47 +00:00
|
|
|
-- | @cabal@ program name.
|
|
|
|
, cabalProgram :: FilePath
|
2014-08-13 16:40:01 +00:00
|
|
|
-- | GHC command line options set on the @ghc-mod@ command line
|
|
|
|
, ghcUserOptions:: [GHCOption]
|
2013-09-05 05:35:28 +00:00
|
|
|
-- | If 'True', 'browse' also returns operators.
|
2013-09-03 05:40:51 +00:00
|
|
|
, operators :: Bool
|
2013-05-20 05:28:56 +00:00
|
|
|
-- | If 'True', 'browse' also returns types.
|
2013-09-03 05:40:51 +00:00
|
|
|
, detailed :: Bool
|
2013-11-17 18:31:47 +00:00
|
|
|
-- | If 'True', 'browse' will return fully qualified name
|
|
|
|
, qualified :: Bool
|
2014-09-18 08:05:47 +00:00
|
|
|
, hlintOpts :: [String]
|
2014-10-22 22:53:41 +00:00
|
|
|
} deriving (Show)
|
2012-02-27 02:23:56 +00:00
|
|
|
|
2014-09-18 08:05:47 +00:00
|
|
|
|
2013-05-20 05:28:56 +00:00
|
|
|
-- | A default 'Options'.
|
2012-02-27 02:23:56 +00:00
|
|
|
defaultOptions :: Options
|
|
|
|
defaultOptions = Options {
|
2013-09-03 05:40:51 +00:00
|
|
|
outputStyle = PlainStyle
|
2015-03-03 20:12:43 +00:00
|
|
|
, lineSeparator = LineSeparator "\0"
|
2015-03-07 18:23:55 +00:00
|
|
|
, logLevel = GmInfo
|
|
|
|
, ghcProgram = "ghc"
|
|
|
|
, ghcPkgProgram = "ghc-pkg"
|
2014-09-18 08:05:47 +00:00
|
|
|
, cabalProgram = "cabal"
|
2014-08-13 16:40:01 +00:00
|
|
|
, ghcUserOptions= []
|
2013-09-03 05:40:51 +00:00
|
|
|
, operators = False
|
|
|
|
, detailed = False
|
2013-11-17 18:31:47 +00:00
|
|
|
, qualified = False
|
2015-03-03 20:12:43 +00:00
|
|
|
, hlintOpts = []
|
2010-04-30 09:36:31 +00:00
|
|
|
}
|
|
|
|
|
2012-02-14 02:33:27 +00:00
|
|
|
----------------------------------------------------------------
|
2012-02-14 07:09:53 +00:00
|
|
|
|
2013-09-05 05:35:28 +00:00
|
|
|
-- | The environment where this library is used.
|
2013-03-02 03:18:55 +00:00
|
|
|
data Cradle = Cradle {
|
2013-09-05 05:35:28 +00:00
|
|
|
-- | The directory where this library is executed.
|
2014-03-30 08:28:57 +00:00
|
|
|
cradleCurrentDir :: FilePath
|
|
|
|
-- | The project root directory.
|
|
|
|
, cradleRootDir :: FilePath
|
2014-10-14 17:52:58 +00:00
|
|
|
-- | Per-Project temporary directory
|
|
|
|
, cradleTempDir :: FilePath
|
2013-09-05 05:35:28 +00:00
|
|
|
-- | The file name of the found cabal file.
|
2014-03-30 08:28:57 +00:00
|
|
|
, cradleCabalFile :: Maybe FilePath
|
2014-04-15 03:13:10 +00:00
|
|
|
-- | Package database stack
|
|
|
|
, cradlePkgDbStack :: [GhcPkgDb]
|
2013-03-05 01:22:33 +00:00
|
|
|
} deriving (Eq, Show)
|
2013-03-02 03:18:55 +00:00
|
|
|
|
|
|
|
----------------------------------------------------------------
|
|
|
|
|
2015-03-04 15:45:26 +00:00
|
|
|
-- | GHC package database flags.
|
|
|
|
data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show)
|
|
|
|
|
|
|
|
-- | A single GHC command line option.
|
|
|
|
type GHCOption = String
|
|
|
|
|
|
|
|
-- | An include directory for modules.
|
|
|
|
type IncludeDir = FilePath
|
|
|
|
|
|
|
|
-- | A package name.
|
|
|
|
type PackageBaseName = String
|
|
|
|
|
|
|
|
-- | A package version.
|
|
|
|
type PackageVersion = String
|
|
|
|
|
|
|
|
-- | A package id.
|
|
|
|
type PackageId = String
|
|
|
|
|
|
|
|
-- | A package's name, verson and id.
|
|
|
|
type Package = (PackageBaseName, PackageVersion, PackageId)
|
|
|
|
|
|
|
|
pkgName :: Package -> PackageBaseName
|
|
|
|
pkgName (n,_,_) = n
|
|
|
|
|
|
|
|
pkgVer :: Package -> PackageVersion
|
|
|
|
pkgVer (_,v,_) = v
|
|
|
|
|
|
|
|
pkgId :: Package -> PackageId
|
|
|
|
pkgId (_,_,i) = i
|
|
|
|
|
|
|
|
showPkg :: Package -> String
|
|
|
|
showPkg (n,v,_) = intercalate "-" [n,v]
|
|
|
|
|
|
|
|
showPkgId :: Package -> String
|
|
|
|
showPkgId (n,v,i) = intercalate "-" [n,v,i]
|
|
|
|
|
|
|
|
-- | Haskell expression.
|
|
|
|
type Expression = String
|
|
|
|
|
|
|
|
-- | Module name.
|
|
|
|
type ModuleString = String
|
|
|
|
|
|
|
|
-- | A Module
|
|
|
|
type Module = [String]
|
|
|
|
|
|
|
|
|
2015-03-03 20:12:43 +00:00
|
|
|
data GmLogLevel = GmPanic
|
|
|
|
| GmException
|
|
|
|
| GmError
|
|
|
|
| GmWarning
|
|
|
|
| GmInfo
|
|
|
|
| GmDebug
|
|
|
|
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
2013-04-01 05:16:34 +00:00
|
|
|
|
2014-07-11 08:43:51 +00:00
|
|
|
-- | Collection of packages
|
2015-03-03 20:12:43 +00:00
|
|
|
type PkgDb = (Map Package PackageConfig)
|
|
|
|
|
|
|
|
data GmModuleGraph = GmModuleGraph {
|
|
|
|
gmgFileMap :: Map FilePath ModulePath,
|
|
|
|
gmgModuleMap :: Map ModuleName ModulePath,
|
|
|
|
gmgGraph :: Map ModulePath (Set ModulePath)
|
2015-03-28 01:30:51 +00:00
|
|
|
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
|
|
|
|
|
|
|
instance Serialize GmModuleGraph where
|
|
|
|
put GmModuleGraph {..} = let
|
|
|
|
mpim :: Map ModulePath Integer
|
|
|
|
graph :: Map Integer (Set Integer)
|
|
|
|
|
|
|
|
mpim = Map.fromList $
|
|
|
|
(Map.keys gmgGraph) `zip` [0..]
|
|
|
|
mpToInt :: ModulePath -> Integer
|
|
|
|
mpToInt mp = fromJust $ Map.lookup mp mpim
|
|
|
|
|
|
|
|
graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph
|
|
|
|
in put (mpim, graph)
|
|
|
|
|
|
|
|
get = do
|
|
|
|
(mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get
|
|
|
|
let
|
|
|
|
swapMap = Map.fromList . map swap . Map.toList
|
|
|
|
swap (a,b) = (b,a)
|
|
|
|
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
|
|
|
|
mpFm = Map.fromList $ map (mpPath &&& id) $ Map.keys mpim
|
|
|
|
mpMn = Map.fromList $ map (mpModule &&& id) $ Map.keys mpim
|
|
|
|
return $ GmModuleGraph mpFm mpMn mpGraph
|
2015-03-03 20:12:43 +00:00
|
|
|
|
|
|
|
instance Monoid GmModuleGraph where
|
|
|
|
mempty = GmModuleGraph mempty mempty mempty
|
|
|
|
mappend (GmModuleGraph a b c) (GmModuleGraph a' b' c') =
|
|
|
|
GmModuleGraph (a <> a') (b <> b') (Map.unionWith Set.union c c')
|
|
|
|
|
2015-03-28 01:30:51 +00:00
|
|
|
data GmComponentType = GMCRaw
|
|
|
|
| GMCResolved
|
|
|
|
data GmComponent (t :: GmComponentType) eps = GmComponent {
|
2015-03-15 19:48:55 +00:00
|
|
|
gmcName :: ChComponentName,
|
2015-03-03 20:12:43 +00:00
|
|
|
gmcGhcOpts :: [GHCOption],
|
|
|
|
gmcGhcSrcOpts :: [GHCOption],
|
2015-03-15 19:48:55 +00:00
|
|
|
gmcRawEntrypoints :: ChEntrypoint,
|
2015-03-03 20:12:43 +00:00
|
|
|
gmcEntrypoints :: eps,
|
|
|
|
gmcSourceDirs :: [FilePath],
|
|
|
|
gmcHomeModuleGraph :: GmModuleGraph
|
2015-04-02 23:15:12 +00:00
|
|
|
} deriving (Eq, Ord, Show, Read, Generic, Functor)
|
2015-03-28 01:30:51 +00:00
|
|
|
|
|
|
|
instance Serialize eps => Serialize (GmComponent t eps)
|
2015-03-03 20:12:43 +00:00
|
|
|
|
|
|
|
data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath }
|
2015-03-28 01:30:51 +00:00
|
|
|
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
|
|
|
instance Serialize ModulePath
|
|
|
|
|
|
|
|
instance Serialize ModuleName where
|
|
|
|
get = mkModuleName <$> get
|
|
|
|
put mn = put (moduleNameString mn)
|
2015-03-03 20:12:43 +00:00
|
|
|
|
|
|
|
instance Show ModuleName where
|
|
|
|
show mn = "ModuleName " ++ show (moduleNameString mn)
|
|
|
|
|
|
|
|
instance Read ModuleName where
|
|
|
|
readsPrec d r = readParen (d > app_prec)
|
|
|
|
(\r' -> [(mkModuleName m,t) |
|
|
|
|
("ModuleName",s) <- lex r',
|
|
|
|
(m,t) <- readsPrec (app_prec+1) s]) r
|
|
|
|
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.
|
|
|
|
|
|
|
|
| GMECabalFlags GhcModError
|
|
|
|
-- ^ Retrieval of the cabal configuration flags failed.
|
|
|
|
|
2015-03-15 19:48:55 +00:00
|
|
|
| GMECabalComponent ChComponentName
|
2015-03-03 20:12:43 +00:00
|
|
|
-- ^ Cabal component could not be found
|
|
|
|
|
2015-03-15 19:48:55 +00:00
|
|
|
| GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
|
2015-03-03 20:12:43 +00:00
|
|
|
-- ^ Could not find a consistent component assignment for modules
|
|
|
|
|
|
|
|
| GMEProcess String [String] (Either (String, String, Int) GhcModError)
|
|
|
|
-- ^ Launching an operating system process failed. Fields in
|
|
|
|
-- order: command, arguments, (stdout, stderr, exitcode)
|
|
|
|
|
|
|
|
| GMENoCabalFile
|
|
|
|
-- ^ No cabal file found.
|
|
|
|
|
|
|
|
| GMETooManyCabalFiles [FilePath]
|
|
|
|
-- ^ Too many cabal files found.
|
|
|
|
|
|
|
|
| GMECabalStateFile GMConfigStateFileError
|
|
|
|
-- ^ Reading Cabal's state configuration file falied somehow.
|
|
|
|
deriving (Eq,Show,Typeable)
|
|
|
|
|
|
|
|
instance Error GhcModError where
|
|
|
|
noMsg = GMENoMsg
|
|
|
|
strMsg = GMEString
|
|
|
|
|
|
|
|
instance Exception GhcModError
|
|
|
|
|
|
|
|
data GMConfigStateFileError
|
|
|
|
= GMConfigStateFileNoHeader
|
|
|
|
| GMConfigStateFileBadHeader
|
|
|
|
| GMConfigStateFileNoParse
|
|
|
|
| GMConfigStateFileMissing
|
|
|
|
-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
|
|
|
|
deriving (Eq, Show, Read, Typeable)
|
2015-03-28 01:30:51 +00:00
|
|
|
|
|
|
|
|
|
|
|
deriving instance Generic Version
|
|
|
|
instance Serialize Version
|
|
|
|
|
|
|
|
instance Serialize Programs
|
|
|
|
instance Serialize ChModuleName
|
|
|
|
instance Serialize ChComponentName
|
|
|
|
instance Serialize ChEntrypoint
|