Private.hs

{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric #-}
-- | The private types
module IdeSession.Types.Private (
    -- * Types without a public counterpart
    FilePathPtr(..)
  , IdPropPtr(..)
  , UseSites
    -- * Types with a public counterpart
  , Public.IdNameSpace(..)
  , IdInfo(..)
  , IdProp(..)
  , IdScope(..)
  , SourceSpan(..)
  , EitherSpan(..)
  , SourceError(..)
  , Public.SourceErrorKind(..)
  , Public.ModuleName
  , ModuleId(..)
  , PackageId(..)
  , IdList
  , IdMap(..)
  , ExpMap(..)
  , SpanInfo(..)
  , ImportEntities(..)
  , Import(..)
  , RunResult(..)
  , BreakInfo(..)
    -- * Cache
  , ExplicitSharingCache(..)
  , unionCache
    -- * Util
  , mkIdMap
  , mkExpMap
  , dominators
  ) where

import Prelude hiding (span, mod)
import Data.Text (Text)
import Data.ByteString (ByteString)
import Control.Applicative ((<$>), (<*>))
import Control.Arrow (first)
import Data.Binary (Binary(..), getWord8, putWord8)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)

import qualified IdeSession.Types.Public as Public
import IdeSession.Strict.Container
import IdeSession.Strict.IntervalMap (StrictIntervalMap, Interval(..))
import qualified IdeSession.Strict.IntervalMap as IntervalMap
import qualified IdeSession.Strict.IntMap      as IntMap
import IdeSession.Util.PrettyVal

newtype FilePathPtr = FilePathPtr { filePathPtr :: Int }
  deriving (Eq, Ord, Show, Generic)

newtype IdPropPtr = IdPropPtr { idPropPtr :: Int }
  deriving (Eq, Ord, Show, Generic)

data IdInfo = IdInfo {
    idProp  :: {-# UNPACK #-} !IdPropPtr
  , idScope :: !IdScope
  }
  deriving (Show, Typeable, Generic)

data IdProp = IdProp {
    idName       :: !Text
  , idSpace      :: !Public.IdNameSpace
  , idType       :: !(Strict Maybe Public.Type)
  , idDefinedIn  :: {-# UNPACK #-} !ModuleId
  , idDefSpan    :: !EitherSpan
  , idHomeModule :: !(Strict Maybe ModuleId)
  }
  deriving (Show, Generic)

data IdScope =
    -- | This is a binding occurrence (@f x = ..@, @\x -> ..@, etc.)
    Binder
    -- | Defined within this module
  | Local
    -- | Imported from a different module
  | Imported {
        idImportedFrom :: {-# UNPACK #-} !ModuleId
      , idImportSpan   :: !EitherSpan
        -- | Qualifier used for the import
        --
        -- > IMPORTED AS                       idImportQual
        -- > import Data.List                  ""
        -- > import qualified Data.List        "Data.List."
        -- > import qualified Data.List as L   "L."
      , idImportQual   :: !Text
      }
    -- | Wired into the compiler (@()@, @True@, etc.)
  | WiredIn
  deriving (Show, Generic)

data SourceSpan = SourceSpan
  { spanFilePath   :: {-# UNPACK #-} !FilePathPtr
  , spanFromLine   :: {-# UNPACK #-} !Int
  , spanFromColumn :: {-# UNPACK #-} !Int
  , spanToLine     :: {-# UNPACK #-} !Int
  , spanToColumn   :: {-# UNPACK #-} !Int
  }
  deriving (Eq, Ord, Show, Generic)

data EitherSpan =
    ProperSpan {-# UNPACK #-} !SourceSpan
  | TextSpan !Text
  deriving (Show, Generic)

data SourceError = SourceError
  { errorKind :: !Public.SourceErrorKind
  , errorSpan :: !EitherSpan
  , errorMsg  :: !Text
  }
  deriving (Show, Generic)

data ModuleId = ModuleId
  { moduleName    :: !Public.ModuleName
  , modulePackage :: {-# UNPACK #-} !PackageId
  }
  deriving (Show, Eq, Generic)

data PackageId = PackageId
  { packageName    :: !Text
  , packageVersion :: !(Strict Maybe Text)
  , packageKey     :: !Text
  }
  deriving (Show, Eq, Ord, Generic)

-- | Used before we convert it to an IdMap
type IdList = [(SourceSpan, SpanInfo)]

data SpanInfo =
   SpanId IdInfo
 | SpanQQ IdInfo
   -- We use 'SpanInSplice' for prioritization only (see 'internalGetSpanInfo').
   -- It gets translated to 'Public.SpanId'
 | SpanInSplice IdInfo
 deriving (Show, Generic)

newtype IdMap = IdMap { idMapToMap :: StrictIntervalMap (FilePathPtr, Int, Int) SpanInfo }
  deriving (Show, Generic)

newtype ExpMap = ExpMap { expMapToMap :: StrictIntervalMap (FilePathPtr, Int, Int) Text }
  deriving (Show, Generic)

type UseSites = Strict (Map IdPropPtr) [SourceSpan]

data ImportEntities =
    ImportOnly   !(Strict [] Text)
  | ImportHiding !(Strict [] Text)
  | ImportAll
  deriving (Show, Eq, Generic)

data Import = Import {
    importModule    :: !ModuleId
  -- | Used only for ghc's PackageImports extension
  , importPackage   :: !(Strict Maybe Text)
  , importQualified :: !Bool
  , importImplicit  :: !Bool
  , importAs        :: !(Strict Maybe Public.ModuleName)
  , importEntities  :: !ImportEntities
  }
  deriving (Show, Eq, Generic)

-- | The outcome of running code
data RunResult =
    -- | The code terminated okay
    RunOk
    -- | The code threw an exception
  | RunProgException String
    -- | GHC itself threw an exception when we tried to run the code
  | RunGhcException String
    -- | Execution was paused because of a breakpoint
  | RunBreak BreakInfo
  deriving (Typeable, Show, Generic)

-- | Information about a triggered breakpoint
data BreakInfo = BreakInfo {
    breakInfoModule      :: Public.ModuleName
  , breakInfoSpan        :: SourceSpan
  , breakInfoResultType  :: Public.Type
  , breakInfoVariableEnv :: Public.VariableEnv
  }
  deriving (Typeable, Show, Generic)

{------------------------------------------------------------------------------
  Cache
------------------------------------------------------------------------------}

-- TODO: Since the ExplicitSharingCache contains internal types, resolving
-- references to the cache means we lose implicit sharing because we need
-- to translate on every lookup. To avoid this, we'd have to introduce two
-- versions of the cache and translate the entire cache first.
data ExplicitSharingCache = ExplicitSharingCache {
    filePathCache :: !(Strict IntMap ByteString)
  , idPropCache   :: !(Strict IntMap IdProp)
  }
  deriving (Show, Generic)

unionCache :: ExplicitSharingCache -> ExplicitSharingCache -> ExplicitSharingCache
unionCache a b = ExplicitSharingCache {
    filePathCache = IntMap.union (filePathCache a) (filePathCache b)
  , idPropCache   = IntMap.union (idPropCache   a) (idPropCache   b)
  }

{------------------------------------------------------------------------------
  Binary instances
------------------------------------------------------------------------------}

instance Binary FilePathPtr where
  put = put . filePathPtr
  get = FilePathPtr <$> get

instance Binary SourceSpan where
  put SourceSpan{..} = do
    put spanFilePath
    put spanFromLine
    put spanFromColumn
    put spanToLine
    put spanToColumn
  get = SourceSpan <$> get <*> get <*> get <*> get <*> get

instance Binary EitherSpan where
  put (ProperSpan span) = putWord8 0 >> put span
  put (TextSpan text)   = putWord8 1 >> put text

  get = do
    header <- getWord8
    case header of
      0 -> ProperSpan <$> get
      1 -> TextSpan <$> get
      _ -> fail "EitherSpan.get: invalid header"

instance Binary SourceError where
  put SourceError{..} = do
    put errorKind
    put errorSpan
    put errorMsg

  get = SourceError <$> get <*> get <*> get

instance Binary IdInfo where
  put IdInfo{..} = put idProp >> put idScope
  get = IdInfo <$> get <*> get

instance Binary IdScope where
  put Binder       = putWord8 0
  put Local        = do putWord8 1
  put Imported{..} = do putWord8 2
                        put idImportedFrom
                        put idImportSpan
                        put idImportQual
  put WiredIn      = putWord8 3

  get = do
    header <- getWord8
    case header of
      0 -> return Binder
      1 -> return Local
      2 -> Imported <$> get <*> get <*> get
      3 -> return WiredIn
      _ -> fail "IdScope.get: invalid header"

instance Binary IdPropPtr where
  put = put . idPropPtr
  get = IdPropPtr <$> get

instance Binary ModuleId where
  put ModuleId{..} = put moduleName >> put modulePackage
  get = ModuleId <$> get <*> get

instance Binary PackageId where
  put PackageId{..} = do
    put packageName
    put packageVersion
    put packageKey
  get = PackageId <$> get <*> get <*> get

instance Binary IdProp where
  put IdProp{..} = do
    put idName
    put idSpace
    put idType
    put idDefinedIn
    put idDefSpan
    put idHomeModule

  get = IdProp <$> get <*> get <*> get <*> get <*> get <*> get

{-
instance Binary IdMap where
  put = put . idMapToMap
  get = IdMap <$> get
-}

instance Binary ImportEntities where
  put (ImportOnly names)   = putWord8 0 >> put names
  put (ImportHiding names) = putWord8 1 >> put names
  put ImportAll            = putWord8 2

  get = do
    header <- getWord8
    case header of
      0 -> ImportOnly   <$> get
      1 -> ImportHiding <$> get
      2 -> return ImportAll
      _ -> fail "ImportEntities.get: invalid header"

instance Binary Import where
  put Import{..} = do
    put importModule
    put importPackage
    put importQualified
    put importImplicit
    put importAs
    put importEntities

  get = Import <$> get <*> get <*> get <*> get <*> get <*> get

instance Binary ExplicitSharingCache where
  put ExplicitSharingCache{..} = do
    put filePathCache
    put idPropCache

  get = ExplicitSharingCache <$> get <*> get

instance Binary SpanInfo where
  put (SpanId idInfo)       = putWord8 0 >> put idInfo
  put (SpanQQ idInfo)       = putWord8 1 >> put idInfo
  put (SpanInSplice idInfo) = putWord8 2 >> put idInfo

  get = do
    header <- getWord8
    case header of
      0 -> SpanId       <$> get
      1 -> SpanQQ       <$> get
      2 -> SpanInSplice <$> get
      _ -> fail "SpanInfo.get: invalid header"

instance Binary RunResult where
  put RunOk                  = putWord8 0
  put (RunProgException str) = putWord8 1 >> put str
  put (RunGhcException str)  = putWord8 2 >> put str
  put (RunBreak info)        = putWord8 3 >> put info

  get = do
    header <- getWord8
    case header of
      0 -> return RunOk
      1 -> RunProgException <$> get
      2 -> RunGhcException <$> get
      3 -> RunBreak <$> get
      _ -> fail "RunResult.get: invalid header"

instance Binary BreakInfo where
  put (BreakInfo{..}) = do
    put breakInfoModule
    put breakInfoSpan
    put breakInfoResultType
    put breakInfoVariableEnv

  get = BreakInfo <$> get <*> get <*> get <*> get

{------------------------------------------------------------------------------
  PrettyVal instances (these rely on Generics)
------------------------------------------------------------------------------}

instance PrettyVal FilePathPtr
instance PrettyVal IdPropPtr
instance PrettyVal IdInfo
instance PrettyVal IdProp
instance PrettyVal IdScope
instance PrettyVal SourceSpan
instance PrettyVal EitherSpan
instance PrettyVal SourceError
instance PrettyVal ModuleId
instance PrettyVal PackageId
instance PrettyVal SpanInfo
instance PrettyVal IdMap
instance PrettyVal ExpMap
instance PrettyVal ImportEntities
instance PrettyVal Import
instance PrettyVal RunResult
instance PrettyVal BreakInfo
instance PrettyVal ExplicitSharingCache

{------------------------------------------------------------------------------
  Util
------------------------------------------------------------------------------}

mkIdMap :: IdList -> IdMap
mkIdMap = IdMap . IntervalMap.fromList . map (first spanToInterval)

mkExpMap :: [(SourceSpan, Text)] -> ExpMap
mkExpMap = ExpMap . IntervalMap.fromList . map (first spanToInterval)

dominators :: SourceSpan -> StrictIntervalMap (FilePathPtr, Int, Int) a -> [(SourceSpan, a)]
dominators span ivalmap =
    map (\(ival, idInfo) -> (intervalToSpan ival, idInfo))
        (IntervalMap.dominators (spanToInterval span) ivalmap)

spanToInterval :: SourceSpan -> Interval (FilePathPtr, Int, Int)
spanToInterval SourceSpan{..} =
  Interval (spanFilePath, spanFromLine, spanFromColumn)
           (spanFilePath, spanToLine, spanToColumn)

intervalToSpan :: Interval (FilePathPtr, Int, Int) -> SourceSpan
intervalToSpan (Interval (spanFilePath, spanFromLine, spanFromColumn)
                         (_,            spanToLine, spanToColumn)) =
  SourceSpan{..}