module Overloaded.Plugin.TcPlugin.Utils where

import Control.Monad              (guard)
import Data.Traversable.WithIndex (itraverse)

import qualified GHC.Compat.All as GHC

import Overloaded.Plugin.V

-------------------------------------------------------------------------------
-- Simple Ct operations
-------------------------------------------------------------------------------

findClassConstraint4 :: GHC.Class -> GHC.Ct -> Maybe (GHC.Ct, V4 GHC.Type)
findClassConstraint4 :: Class -> Ct -> Maybe (Ct, V4 Type)
findClassConstraint4 Class
cls Ct
ct = do
   (Class
cls', [Type
k, Type
x, Type
s, Type
a]) <- Type -> Maybe (Class, [Type])
GHC.getClassPredTys_maybe (Ct -> Type
GHC.ctPred Ct
ct)
   Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Class
cls' Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
cls)
   (Ct, V4 Type) -> Maybe (Ct, V4 Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ct
ct, Type -> Type -> Type -> Type -> V4 Type
forall a. a -> a -> a -> a -> V4 a
V4 Type
k Type
x Type
s Type
a)

-- | Make newtype class evidence
makeEvidence4_1 :: GHC.Class -> GHC.CoreExpr -> V4 GHC.Type -> GHC.EvTerm
makeEvidence4_1 :: Class -> CoreExpr -> V4 Type -> EvTerm
makeEvidence4_1 Class
cls CoreExpr
e (V4 Type
k Type
x Type
s Type
a) = CoreExpr -> EvTerm
GHC.EvExpr CoreExpr
appDc where
    tyCon :: TyCon
tyCon = Class -> TyCon
GHC.classTyCon Class
cls
    dc :: DataCon
dc    = TyCon -> DataCon
GHC.tyConSingleDataCon TyCon
tyCon
    appDc :: CoreExpr
appDc = DataCon -> [CoreExpr] -> CoreExpr
GHC.mkCoreConApps DataCon
dc
        [ Type -> CoreExpr
forall b. Type -> Expr b
GHC.Type Type
k
        , Type -> CoreExpr
forall b. Type -> Expr b
GHC.Type Type
x
        , Type -> CoreExpr
forall b. Type -> Expr b
GHC.Type Type
s
        , Type -> CoreExpr
forall b. Type -> Expr b
GHC.Type Type
a
        , CoreExpr
e
        ]

makeEvidence4_2 :: GHC.Class -> GHC.CoreExpr -> GHC.CoreExpr -> V4 GHC.Type -> GHC.EvTerm
makeEvidence4_2 :: Class -> CoreExpr -> CoreExpr -> V4 Type -> EvTerm
makeEvidence4_2 Class
cls CoreExpr
e1 CoreExpr
e2 (V4 Type
k Type
x Type
s Type
a) = CoreExpr -> EvTerm
GHC.EvExpr CoreExpr
appDc where
    tyCon :: TyCon
tyCon = Class -> TyCon
GHC.classTyCon Class
cls
    dc :: DataCon
dc    = TyCon -> DataCon
GHC.tyConSingleDataCon TyCon
tyCon
    appDc :: CoreExpr
appDc = DataCon -> [CoreExpr] -> CoreExpr
GHC.mkCoreConApps DataCon
dc
        [ Type -> CoreExpr
forall b. Type -> Expr b
GHC.Type Type
k
        , Type -> CoreExpr
forall b. Type -> Expr b
GHC.Type Type
x
        , Type -> CoreExpr
forall b. Type -> Expr b
GHC.Type Type
s
        , Type -> CoreExpr
forall b. Type -> Expr b
GHC.Type Type
a
        , CoreExpr
e1
        , CoreExpr
e2
        ]



-------------------------------------------------------------------------------
-- makeVar
-------------------------------------------------------------------------------

makeVar :: String -> GHC.Type -> GHC.TcPluginM GHC.Var
makeVar :: String -> Type -> TcPluginM Var
makeVar String
n Type
ty = do
    Name
name <- TcM Name -> TcPluginM Name
forall a. TcM a -> TcPluginM a
GHC.unsafeTcPluginTcM (TcM Name -> TcPluginM Name) -> TcM Name -> TcPluginM Name
forall a b. (a -> b) -> a -> b
$ OccName -> TcM Name
GHC.newName (String -> OccName
GHC.mkVarOcc String
n)
    Var -> TcPluginM Var
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type -> Var
GHC.mkLocalMultId Name
name Type
ty)

makeVars :: String -> [GHC.Type] -> GHC.TcPluginM [GHC.Var]
makeVars :: String -> [Type] -> TcPluginM [Var]
makeVars String
n [Type]
tys = (Int -> Type -> TcPluginM Var) -> [Type] -> TcPluginM [Var]
forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
itraverse (\Int
i -> String -> Type -> TcPluginM Var
makeVar (String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)) [Type]
tys

-------------------------------------------------------------------------------
-- Utils
-------------------------------------------------------------------------------

fstOf3 :: (a, b, c) -> a
fstOf3 :: (a, b, c) -> a
fstOf3 (a
a, b
_, c
_) =  a
a