Utils.hs

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 cls ct = do
   (cls', [k, x, s, a]) <- GHC.getClassPredTys_maybe (GHC.ctPred ct)
   guard (cls' == cls)
   return (ct, V4 k x s a)

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

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



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

makeVar :: String -> GHC.Type -> GHC.TcPluginM GHC.Var
makeVar n ty = do
    name <- GHC.unsafeTcPluginTcM $ GHC.newName (GHC.mkVarOcc n)
    return (GHC.mkLocalMultId name ty)

makeVars :: String -> [GHC.Type] -> GHC.TcPluginM [GHC.Var]
makeVars n tys = itraverse (\i -> makeVar (n ++ show i)) tys

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

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