content: {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, RankNTypes,
    StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell,
    GeneralizedNewtypeDeriving #-}
  {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
  module GhcMod.Types (
      module 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 Pretty (Doc)
  import Prelude
  
  import GhcMod.Caching.Types
  
  -- | 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)
  
  
  -- 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
  
  -- | Output style.
  data OutputStyle = LispStyle  -- ^ S expression style.
                   | PlainStyle -- ^ Plain textstyle.
                     deriving (Show)
  
  -- | The type for line separator. Historically, a Null string is used.
  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 {
    -- | @ghc@ program name.
      ghcProgram    :: FilePath
    -- | @ghc-pkg@ program name.
    , ghcPkgProgram :: FilePath
    -- | @cabal@ program name.
    , cabalProgram  :: FilePath
    -- | @stack@ program name.
    , stackProgram   :: FilePath
    } deriving (Show)
  
  data OutputOpts = OutputOpts {
    -- | Verbosity
      ooptLogLevel      :: GmLogLevel
    , ooptStyle         :: OutputStyle
    -- | Line separator string.
    , ooptLineSeparator :: LineSeparator
    -- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout,
    -- @snd@ is stderr prefix.
    , ooptLinePrefix    :: Maybe (String, String)
    } deriving (Show)
  
  data Options = Options {
      optOutput         :: OutputOpts
    , optPrograms       :: Programs
      -- | GHC command line options set on the @ghc-mod@ command line
    , optGhcUserOptions :: [GHCOption]
    , optFileMappings   :: [(FilePath, Maybe FilePath)]
    , optEncoding       :: String
    , optStackBuildDeps :: Bool
    } deriving (Show)
  
  -- | A default 'Options'.
  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"
    , optStackBuildDeps = False
    }
  
  ----------------------------------------------------------------
  
  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)
  
  -- | The environment where this library is used.
  data Cradle = Cradle {
      cradleProject    :: Project
    -- | The directory where this library is executed.
    , cradleCurrentDir :: FilePath
    -- | The project root directory.
    , cradleRootDir    :: FilePath
    -- | Per-Project temporary directory
    , cradleTempDir    :: FilePath
    -- | The file name of the found cabal file.
    , cradleCabalFile  :: Maybe FilePath
    -- | The build info directory.
    , 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 {
        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
    , gmcGhcOpts         :: [GHCOption]
    , gmcGhcPkgOpts      :: [GHCOption]
    , gmcGhcSrcOpts      :: [GHCOption]
    , gmcGhcLangOpts     :: [GHCOption]
    , gmcRawEntrypoints  :: ChEntrypoint
    , gmcEntrypoints     :: eps
    , gmcSourceDirs      :: [FilePath]
    , gmcName            :: ChComponentName  
    } 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
  