{-# LANGUAGE CPP              #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms  #-}
{-# LANGUAGE ViewPatterns     #-}

module Ide.Plugin.Tactic.GHC where

import           Control.Monad.State
import qualified Data.Map as M
import           Data.Maybe (isJust)
import           Data.Traversable
import qualified DataCon as DataCon
import           Development.IDE.GHC.Compat
import           Generics.SYB (mkT, everywhere)
import           Ide.Plugin.Tactic.Types
import           OccName
import           TcType
import           TyCoRep
import           Type
import           TysWiredIn (intTyCon, floatTyCon, doubleTyCon, charTyCon)
import           Unique
import           Var

tcTyVar_maybe :: Type -> Maybe Var
tcTyVar_maybe :: Type -> Maybe Var
tcTyVar_maybe Type
ty | Just Type
ty' <- Type -> Maybe Type
tcView Type
ty = Type -> Maybe Var
tcTyVar_maybe Type
ty'
tcTyVar_maybe (CastTy Type
ty KindCoercion
_) = Type -> Maybe Var
tcTyVar_maybe Type
ty  -- look through casts, as
                                                -- this is only used for
                                                -- e.g., FlexibleContexts
tcTyVar_maybe (TyVarTy Var
v)   = Var -> Maybe Var
forall a. a -> Maybe a
Just Var
v
tcTyVar_maybe Type
_             = Maybe Var
forall a. Maybe a
Nothing


instantiateType :: Type -> ([TyVar], Type)
instantiateType :: Type -> ([Var], Type)
instantiateType Type
t = do
  let vs :: [Var]
vs  = Type -> [Var]
tyCoVarsOfTypeList Type
t
      vs' :: [Var]
vs' = (Var -> Var) -> [Var] -> [Var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Var -> Var
cloneTyVar [Var]
vs
      subst :: TCvSubst
subst = ((Var, Var) -> TCvSubst -> TCvSubst)
-> TCvSubst -> [(Var, Var)] -> TCvSubst
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Var
v,Var
t) TCvSubst
a -> TCvSubst -> Var -> Type -> TCvSubst
extendTCvSubst TCvSubst
a Var
v (Type -> TCvSubst) -> Type -> TCvSubst
forall a b. (a -> b) -> a -> b
$ Var -> Type
TyVarTy Var
t) TCvSubst
emptyTCvSubst
            ([(Var, Var)] -> TCvSubst) -> [(Var, Var)] -> TCvSubst
forall a b. (a -> b) -> a -> b
$ [Var] -> [Var] -> [(Var, Var)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
vs [Var]
vs'
   in ([Var]
vs', HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
t)


cloneTyVar :: TyVar -> TyVar
cloneTyVar :: Var -> Var
cloneTyVar Var
t =
  let uniq :: Unique
uniq = Var -> Unique
forall a. Uniquable a => a -> Unique
getUnique Var
t
      some_magic_number :: Int
some_magic_number = Int
49
   in Var -> Unique -> Var
setVarUnique Var
t (Unique -> Var) -> Unique -> Var
forall a b. (a -> b) -> a -> b
$ Unique -> Int -> Unique
deriveUnique Unique
uniq Int
some_magic_number


------------------------------------------------------------------------------
-- | Is this a function type?
isFunction :: Type -> Bool
isFunction :: Type -> Bool
isFunction (Type -> ([Var], ThetaType, ThetaType, Type)
tacticsSplitFunTy -> ([Var]
_, ThetaType
_, [], Type
_)) = Bool
False
isFunction Type
_ = Bool
True


------------------------------------------------------------------------------
-- | Split a function, also splitting out its quantified variables and theta
-- context.
tacticsSplitFunTy :: Type -> ([TyVar], ThetaType, [Type], Type)
tacticsSplitFunTy :: Type -> ([Var], ThetaType, ThetaType, Type)
tacticsSplitFunTy Type
t
  = let ([Var]
vars, ThetaType
theta, Type
t') = Type -> ([Var], ThetaType, Type)
tcSplitSigmaTy Type
t
        (ThetaType
args, Type
res) = Type -> (ThetaType, Type)
tcSplitFunTys Type
t'
     in ([Var]
vars, ThetaType
theta, ThetaType
args, Type
res)


------------------------------------------------------------------------------
-- | Rip the theta context out of a regular type.
tacticsThetaTy :: Type -> ThetaType
tacticsThetaTy :: Type -> ThetaType
tacticsThetaTy (Type -> ([Var], ThetaType, Type)
tcSplitSigmaTy -> ([Var]
_, ThetaType
theta,  Type
_)) = ThetaType
theta


------------------------------------------------------------------------------
-- | Instantiate all of the quantified type variables in a type with fresh
-- skolems.
freshTyvars :: MonadState TacticState m => Type -> m Type
freshTyvars :: Type -> m Type
freshTyvars Type
t = do
  let ([Var]
tvs, ThetaType
_, ThetaType
_, Type
_) = Type -> ([Var], ThetaType, ThetaType, Type)
tacticsSplitFunTy Type
t
  Map Var Var
reps <- ([(Var, Var)] -> Map Var Var) -> m [(Var, Var)] -> m (Map Var Var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Var, Var)] -> Map Var Var
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
        (m [(Var, Var)] -> m (Map Var Var))
-> m [(Var, Var)] -> m (Map Var Var)
forall a b. (a -> b) -> a -> b
$ [Var] -> (Var -> m (Var, Var)) -> m [(Var, Var)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Var]
tvs ((Var -> m (Var, Var)) -> m [(Var, Var)])
-> (Var -> m (Var, Var)) -> m [(Var, Var)]
forall a b. (a -> b) -> a -> b
$ \Var
tv -> do
            Unique
uniq <- m Unique
forall (m :: * -> *). MonadState TacticState m => m Unique
freshUnique
            (Var, Var) -> m (Var, Var)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Var, Var) -> m (Var, Var)) -> (Var, Var) -> m (Var, Var)
forall a b. (a -> b) -> a -> b
$ (Var
tv, Var -> Unique -> Var
setTyVarUnique Var
tv Unique
uniq)
  Type -> m Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$
    (forall a. Data a => a -> a) -> Type -> Type
(forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere
      ((Var -> Var) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT ((Var -> Var) -> a -> a) -> (Var -> Var) -> a -> a
forall a b. (a -> b) -> a -> b
$ \Var
tv ->
        case Var -> Map Var Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
tv Map Var Var
reps of
          Just Var
tv' -> Var
tv'
          Maybe Var
Nothing -> Var
tv
      ) Type
t


------------------------------------------------------------------------------
-- | Is this an algebraic type?
algebraicTyCon :: Type -> Maybe TyCon
algebraicTyCon :: Type -> Maybe TyCon
algebraicTyCon (HasDebugCallStack => Type -> Maybe (TyCon, ThetaType)
Type -> Maybe (TyCon, ThetaType)
splitTyConApp_maybe -> Just (TyCon
tycon, ThetaType
_))
  | TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
intTyCon    = Maybe TyCon
forall a. Maybe a
Nothing
  | TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
floatTyCon  = Maybe TyCon
forall a. Maybe a
Nothing
  | TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
doubleTyCon = Maybe TyCon
forall a. Maybe a
Nothing
  | TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
charTyCon   = Maybe TyCon
forall a. Maybe a
Nothing
  | TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
funTyCon    = Maybe TyCon
forall a. Maybe a
Nothing
  | Bool
otherwise = TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tycon
algebraicTyCon Type
_ = Maybe TyCon
forall a. Maybe a
Nothing

------------------------------------------------------------------------------
-- | Can ths type be lambda-cased?
--
-- Return: 'Nothing' if no
--         @Just False@ if it can't be homomorphic
--         @Just True@ if it can
lambdaCaseable :: Type -> Maybe Bool
lambdaCaseable :: Type -> Maybe Bool
lambdaCaseable (Type -> Maybe (Type, Type)
splitFunTy_maybe -> Just (Type
arg, Type
res))
  | Maybe TyCon -> Bool
forall a. Maybe a -> Bool
isJust (Type -> Maybe TyCon
algebraicTyCon Type
arg)
  = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Maybe TyCon -> Bool
forall a. Maybe a -> Bool
isJust (Maybe TyCon -> Bool) -> Maybe TyCon -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Maybe TyCon
algebraicTyCon Type
res
lambdaCaseable Type
_ = Maybe Bool
forall a. Maybe a
Nothing

fromPatCompat :: PatCompat GhcTc -> Pat GhcTc
#if __GLASGOW_HASKELL__ == 808
type PatCompat pass = Pat pass
fromPatCompat = id
#else
type PatCompat pass = LPat pass
fromPatCompat :: PatCompat GhcTc -> Pat GhcTc
fromPatCompat = PatCompat GhcTc -> Pat GhcTc
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc
#endif

------------------------------------------------------------------------------
-- | Should make sure it's a fun bind
pattern TopLevelRHS :: OccName -> [PatCompat GhcTc] -> LHsExpr GhcTc -> Match GhcTc (LHsExpr GhcTc)
pattern $mTopLevelRHS :: forall r.
Match GhcTc (LHsExpr GhcTc)
-> (OccName -> [PatCompat GhcTc] -> LHsExpr GhcTc -> r)
-> (Void# -> r)
-> r
TopLevelRHS name ps body <-
  Match _
    (FunRhs (L _ (occName -> name)) _ _)
    ps
    (GRHSs _
      [L _ (GRHS _ [] body)] _)

getPatName :: PatCompat GhcTc -> Maybe OccName
getPatName :: PatCompat GhcTc -> Maybe OccName
getPatName (PatCompat GhcTc -> Pat GhcTc
fromPatCompat -> Pat GhcTc
p0) =
  case Pat GhcTc
p0 of
    VarPat  XVarPat GhcTc
_ Located (IdP GhcTc)
x   -> OccName -> Maybe OccName
forall a. a -> Maybe a
Just (OccName -> Maybe OccName) -> OccName -> Maybe OccName
forall a b. (a -> b) -> a -> b
$ Var -> OccName
forall name. HasOccName name => name -> OccName
occName (Var -> OccName) -> Var -> OccName
forall a b. (a -> b) -> a -> b
$ Located Var -> SrcSpanLess (Located Var)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP GhcTc)
Located Var
x
    LazyPat XLazyPat GhcTc
_ PatCompat GhcTc
p   -> PatCompat GhcTc -> Maybe OccName
getPatName PatCompat GhcTc
p
    AsPat   XAsPat GhcTc
_ Located (IdP GhcTc)
x PatCompat GhcTc
_ -> OccName -> Maybe OccName
forall a. a -> Maybe a
Just (OccName -> Maybe OccName) -> OccName -> Maybe OccName
forall a b. (a -> b) -> a -> b
$ Var -> OccName
forall name. HasOccName name => name -> OccName
occName (Var -> OccName) -> Var -> OccName
forall a b. (a -> b) -> a -> b
$ Located Var -> SrcSpanLess (Located Var)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP GhcTc)
Located Var
x
    ParPat  XParPat GhcTc
_ PatCompat GhcTc
p   -> PatCompat GhcTc -> Maybe OccName
getPatName PatCompat GhcTc
p
    BangPat XBangPat GhcTc
_ PatCompat GhcTc
p   -> PatCompat GhcTc -> Maybe OccName
getPatName PatCompat GhcTc
p
    ViewPat XViewPat GhcTc
_ LHsExpr GhcTc
_ PatCompat GhcTc
p -> PatCompat GhcTc -> Maybe OccName
getPatName PatCompat GhcTc
p
#if __GLASGOW_HASKELL__ >= 808
    SigPat  XSigPat GhcTc
_ PatCompat GhcTc
p LHsSigWcType (NoGhcTc GhcTc)
_ -> PatCompat GhcTc -> Maybe OccName
getPatName PatCompat GhcTc
p
#endif
#if __GLASGOW_HASKELL__ == 808
    XPat   p      -> getPatName $ unLoc p
#endif
    Pat GhcTc
_             -> Maybe OccName
forall a. Maybe a
Nothing

dataConExTys :: DataCon -> [TyCoVar]
#if __GLASGOW_HASKELL__ >= 808
dataConExTys :: DataCon -> [Var]
dataConExTys = DataCon -> [Var]
DataCon.dataConExTyCoVars
#else
dataConExTys = DataCon.dataConExTyVars
#endif