{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric #-}

module Language.Haskell.Liquid.GHC.Plugin.Types
    ( SpecComment(..)

    -- * Dealing with specs and their dependencies
    , LiquidLib
    , mkLiquidLib
    , mkSpecComment
    , libTarget
    , libDeps
    , allDeps
    , addLibDependencies

    -- * Carrying data across stages of the compilation pipeline
    , PipelineData(..)

    -- * Acquiring and manipulating data from the typechecking phase
    , TcData
    , tcAllImports
    , tcQualifiedImports
    , tcResolvedNames
    , tcAvailableTyCons
    , tcAvailableVars
    , mkTcData
    ) where

import           Data.Binary                             as B
import           Data.Foldable
import           GHC.Generics                      hiding ( moduleName )

import qualified Data.HashSet        as HS

import           Language.Haskell.Liquid.Types.Specs
import           Liquid.GHC.API         as GHC
import qualified Language.Haskell.Liquid.GHC.Interface   as LH
import           Language.Haskell.Liquid.GHC.Misc (realSrcLocSourcePos)
import           Language.Fixpoint.Types.Names            ( Symbol )
import           Language.Fixpoint.Types.Spans            ( SourcePos, dummyPos )


data LiquidLib = LiquidLib
  {  LiquidLib -> LiftedSpec
llTarget :: LiftedSpec
  -- ^ The target /LiftedSpec/.
  ,  LiquidLib -> TargetDependencies
llDeps   :: TargetDependencies
  -- ^ The specs which were necessary to produce the target 'BareSpec'.
  } deriving (Int -> LiquidLib -> ShowS
[LiquidLib] -> ShowS
LiquidLib -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LiquidLib] -> ShowS
$cshowList :: [LiquidLib] -> ShowS
show :: LiquidLib -> String
$cshow :: LiquidLib -> String
showsPrec :: Int -> LiquidLib -> ShowS
$cshowsPrec :: Int -> LiquidLib -> ShowS
Show, forall x. Rep LiquidLib x -> LiquidLib
forall x. LiquidLib -> Rep LiquidLib x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LiquidLib x -> LiquidLib
$cfrom :: forall x. LiquidLib -> Rep LiquidLib x
Generic)

instance B.Binary LiquidLib

-- | Creates a new 'LiquidLib' with no dependencies.
mkLiquidLib :: LiftedSpec -> LiquidLib
mkLiquidLib :: LiftedSpec -> LiquidLib
mkLiquidLib LiftedSpec
s = LiftedSpec -> TargetDependencies -> LiquidLib
LiquidLib LiftedSpec
s forall a. Monoid a => a
mempty

-- | Adds a set of dependencies to the input 'LiquidLib'.
addLibDependencies :: TargetDependencies -> LiquidLib -> LiquidLib
addLibDependencies :: TargetDependencies -> LiquidLib -> LiquidLib
addLibDependencies TargetDependencies
deps LiquidLib
lib = LiquidLib
lib { llDeps :: TargetDependencies
llDeps = TargetDependencies
deps forall a. Semigroup a => a -> a -> a
<> LiquidLib -> TargetDependencies
llDeps LiquidLib
lib }

-- | Returns the target 'LiftedSpec' of this 'LiquidLib'.
libTarget :: LiquidLib -> LiftedSpec
libTarget :: LiquidLib -> LiftedSpec
libTarget = LiquidLib -> LiftedSpec
llTarget

-- | Returns all the dependencies of this 'LiquidLib'.
libDeps :: LiquidLib -> TargetDependencies
libDeps :: LiquidLib -> TargetDependencies
libDeps = LiquidLib -> TargetDependencies
llDeps

-- | Extracts all the dependencies from a collection of 'LiquidLib's.
allDeps :: Foldable f => f LiquidLib -> TargetDependencies
allDeps :: forall (f :: * -> *).
Foldable f =>
f LiquidLib -> TargetDependencies
allDeps = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\TargetDependencies
acc LiquidLib
lib -> TargetDependencies
acc forall a. Semigroup a => a -> a -> a
<> LiquidLib -> TargetDependencies
llDeps LiquidLib
lib) forall a. Monoid a => a
mempty

-- | Just a small wrapper around the 'SourcePos' and the text fragment of a LH spec comment.
newtype SpecComment =
    SpecComment (SourcePos, String)
    deriving Int -> SpecComment -> ShowS
[SpecComment] -> ShowS
SpecComment -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SpecComment] -> ShowS
$cshowList :: [SpecComment] -> ShowS
show :: SpecComment -> String
$cshow :: SpecComment -> String
showsPrec :: Int -> SpecComment -> ShowS
$cshowsPrec :: Int -> SpecComment -> ShowS
Show

mkSpecComment :: (Maybe RealSrcLoc, String) -> SpecComment
mkSpecComment :: (Maybe RealSrcLoc, String) -> SpecComment
mkSpecComment (Maybe RealSrcLoc
m, String
s) = (SourcePos, String) -> SpecComment
SpecComment (Maybe RealSrcLoc -> SourcePos
sourcePos Maybe RealSrcLoc
m, String
s)
  where
    sourcePos :: Maybe RealSrcLoc -> SourcePos
sourcePos Maybe RealSrcLoc
Nothing = String -> SourcePos
dummyPos String
"<no source information>"
    sourcePos (Just RealSrcLoc
sp) = RealSrcLoc -> SourcePos
realSrcLocSourcePos RealSrcLoc
sp

--
-- Passing data between stages of the pipeline
--
-- The plugin architecture doesn't provide a default system to \"thread\" data across stages of the
-- compilation pipeline, which means that plugin implementors have two choices:
--
-- 1. Serialise any data they want to carry around inside annotations, but this can be potentially costly;
-- 2. Pass data inside IORefs.

data PipelineData = PipelineData {
    PipelineData -> ModGuts
pdUnoptimisedCore :: ModGuts
  , PipelineData -> TcData
pdTcData :: TcData
  , PipelineData -> [SpecComment]
pdSpecComments :: [SpecComment]
  }

-- | Data which can be \"safely\" passed to the \"Core\" stage of the pipeline.
-- The notion of \"safely\" here is a bit vague: things like imports are somewhat
-- guaranteed not to change, but things like identifiers might, so they shouldn't
-- land here.
data TcData = TcData {
    TcData -> HashSet Symbol
tcAllImports       :: HS.HashSet Symbol
  , TcData -> QImports
tcQualifiedImports :: QImports
  , TcData -> [(Name, Maybe TyThing)]
tcResolvedNames    :: [(Name, Maybe TyThing)]
  , TcData -> [TyCon]
tcAvailableTyCons  :: [GHC.TyCon]
  -- ^ Sometimes we might be in a situation where we have \"wrapper\" modules that
  -- simply re-exports everything from the original module, and therefore when LH
  -- tries to resolve the GHC identifier associated to a data constructor in scope
  -- (from the call to 'lookupTyThings') we might not be able to find a match because
  -- the 'mg_tcs' for the input 'ModGuts' is empty (because the type constructor are not
  -- defined in the /wrapper/ module, but rather in the /wrapped/ module itself). This is
  -- why we look at the 'ModGuts' 's 'AvailInfo' to extract any re-exported 'TyCon' out of that.
  , TcData -> [Var]
tcAvailableVars    :: [Var]
  -- ^ Ditto as for 'reflectedTyCons', but for identifiers.
  }

instance Outputable TcData where
    ppr :: TcData -> SDoc
ppr (TcData{[(Name, Maybe TyThing)]
[TyCon]
[Var]
HashSet Symbol
QImports
tcAvailableVars :: [Var]
tcAvailableTyCons :: [TyCon]
tcResolvedNames :: [(Name, Maybe TyThing)]
tcQualifiedImports :: QImports
tcAllImports :: HashSet Symbol
tcAvailableVars :: TcData -> [Var]
tcAvailableTyCons :: TcData -> [TyCon]
tcResolvedNames :: TcData -> [(Name, Maybe TyThing)]
tcQualifiedImports :: TcData -> QImports
tcAllImports :: TcData -> HashSet Symbol
..}) =
          String -> SDoc
text String
"TcData { imports     = " SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a. HashSet a -> [a]
HS.toList HashSet Symbol
tcAllImports)
      SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"       , qImports    = " SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (forall a. Show a => a -> String
show QImports
tcQualifiedImports)
      SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"       , names       = " SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [(Name, Maybe TyThing)]
tcResolvedNames
      SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"       , availTyCons = " SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyCon]
tcAvailableTyCons
      SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
" }"

-- | Constructs a 'TcData' out of a 'TcGblEnv'.
mkTcData :: [LImportDecl GhcRn]
         -> [(Name, Maybe TyThing)]
         -> [TyCon]
         -> [Var]
         -> TcData
mkTcData :: [LImportDecl GhcRn]
-> [(Name, Maybe TyThing)] -> [TyCon] -> [Var] -> TcData
mkTcData [LImportDecl GhcRn]
imps [(Name, Maybe TyThing)]
resolvedNames [TyCon]
availTyCons [Var]
availVars = TcData {
    tcAllImports :: HashSet Symbol
tcAllImports       = [LImportDecl GhcRn] -> HashSet Symbol
LH.allImports       [LImportDecl GhcRn]
imps
  , tcQualifiedImports :: QImports
tcQualifiedImports = [LImportDecl GhcRn] -> QImports
LH.qualifiedImports [LImportDecl GhcRn]
imps
  , tcResolvedNames :: [(Name, Maybe TyThing)]
tcResolvedNames    = [(Name, Maybe TyThing)]
resolvedNames
  , tcAvailableTyCons :: [TyCon]
tcAvailableTyCons  = [TyCon]
availTyCons
  , tcAvailableVars :: [Var]
tcAvailableVars    = [Var]
availVars
  }