{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DerivingVia #-}
{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}
-- | @Semigroup@ \/ @Monoid@ synthesizers: pointwise over a single-constructor product.
module Stock.Semigroup where
-- Most names below (data-con/type builders, coercion builders, occ-name
-- helpers, …) are re-exported by 'GHC.Plugins', so we only import explicitly
-- the ones it does not provide.
import GHC.Plugins hiding (TcPlugin)
import GHC.Tc.Plugin
import GHC.Tc.Types
import GHC.Tc.Types.Constraint
#if MIN_VERSION_ghc(9,12,0)
import GHC.Tc.Types.CtLoc (CtLoc)
#else
import GHC.Tc.Types.Constraint (CtLoc)
#endif
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad (addErrTc)
import GHC.Tc.Errors.Types (mkTcRnUnknownMessage)
import GHC.Types.Error (mkPlainError, noHints)
import GHC.Core.Class (Class, className, classMethods, classOpItems, classTyCon)
import GHC.Core.Predicate (classifyPredType, Pred(ClassPred), mkClassPred)
import GHC.Builtin.Types.Prim (intPrimTy)
import GHC.Builtin.PrimOps (PrimOp(TagToEnumOp))
import GHC.Builtin.PrimOps.Ids (primOpId)
import GHC.Builtin.Names ( eqClassName, ordClassName, appendName
                         , enumClassName, mapName, numClassName
                         , enumFromToName, enumFromThenToName
                         , eqStringName
                         , genClassName, repTyConName, u1TyConName, k1TyConName
                         , prodTyConName, sumTyConName
                         , monoidClassName, foldableClassName, functorClassName
                         , semigroupClassName )
import Stock.Compat ( gHC_INTERNAL_SHOW, gHC_INTERNAL_READ
                    , gHC_INTERNAL_LIST, gHC_INTERNAL_GENERICS )
import GHC.Core.Reduction (mkReduction)
import GHC.Core.TyCo.Rep (UnivCoProvenance(PluginProv))
import GHC.Rename.Fixity (lookupFixityRn)
import GHC.Types.Fixity (Fixity(..), defaultFixity)
import GHC.Core.TyCo.Compare (eqType)
import GHC.Core.Multiplicity (scaledThing)
import GHC.Core.SimpleOpt (defaultSimpleOpts)
import GHC.Core.Unfold.Make (mkInlineUnfoldingWithArity)
import GHC.Core.InstEnv (classInstances, is_dfun, is_tys)
import GHC.Runtime.Loader (getValueSafely)
import Stock.Derive
import Data.Maybe (catMaybes, fromJust, isJust, fromMaybe)
import qualified Data.Monoid as Mon (Alt(..))  -- 'Alt' clashes with GHC.Core's case-alt 'Alt'
import Stock.Trans (MaybeT(..))
import Control.Monad (forM, zipWithM, unless, guard)
import Data.IORef (IORef, newIORef, readIORef, modifyIORef')
import Stock.Internal
-- @gmappend x y = productTypeTo (cliftA2_NP (Proxy \@Semigroup) (mapIII (<>))
--                                            (productTypeFrom x) (productTypeFrom y))@
semigroupDeriver :: Deriver
semigroupDeriver :: Deriver
semigroupDeriver = (Class -> Datatype -> Synth EvTerm) -> Deriver
Deriver \Class
cls Datatype
dt -> do
  let via :: Type
via       = Datatype -> Type
dtVia Datatype
dt
      sappSel :: Id
sappSel   = String -> Class -> Id
classMethod String
"<>" Class
cls                 -- (<>)
      mapSapp :: Type -> Arg b -> Arg b -> Arg b -> Arg b
mapSapp Type
ft Arg b
d Arg b
x Arg b
y = Arg b -> [Arg b] -> Arg b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Arg b
forall b. Id -> Expr b
Var Id
sappSel) [Type -> Arg b
forall b. Type -> Expr b
Type Type
ft, Arg b
d, Arg b
x, Arg b
y]
  Id
aId <- Type -> String -> Synth Id
fresh Type
via String
"a" ; Id
bId <- Type -> String -> Synth Id
fresh Type
via String
"b"
  CoreExpr
body <- Datatype
-> Type
-> CoreExpr
-> ([CoreExpr] -> Synth CoreExpr)
-> Synth CoreExpr
fromProduct Datatype
dt Type
via (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
aId) \[CoreExpr]
xs ->
          Datatype
-> Type
-> CoreExpr
-> ([CoreExpr] -> Synth CoreExpr)
-> Synth CoreExpr
fromProduct Datatype
dt Type
via (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
bId) \[CoreExpr]
ys ->
          Datatype -> [CoreExpr] -> CoreExpr
toProduct Datatype
dt ([CoreExpr] -> CoreExpr) -> Synth [CoreExpr] -> Synth CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Class
-> (Type -> CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr)
-> Constructor
-> [CoreExpr]
-> [CoreExpr]
-> Synth [CoreExpr]
czipFields Class
cls Type -> CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
forall {b}. Type -> Arg b -> Arg b -> Arg b -> Arg b
mapSapp (Datatype -> Constructor
productCon Datatype
dt) [CoreExpr]
xs [CoreExpr]
ys
  CoreExpr
dict <- TcPluginM CoreExpr -> Synth CoreExpr
forall a. TcPluginM a -> Synth a
liftTc (Class
-> Type -> [CoreExpr] -> [(Int, CoreExpr)] -> TcPluginM CoreExpr
recDictWith Class
cls Type
via [] [(Int
0, [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
aId, Id
bId] CoreExpr
body)])
  EvTerm -> Synth EvTerm
forall a. a -> Synth a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> EvTerm
EvExpr CoreExpr
dict)

-- | Pointwise @Monoid@ for a single-constructor product: @mempty = C mempty..@.
-- Its @Semigroup@ superclass is the 'semigroupDeriver' dictionary;
-- @mappend@\/@mconcat@ come from the class defaults.
--
-- @gmempty = productTypeTo (cpure_NP (Proxy \@Monoid) (I mempty))@
monoidDeriver :: Deriver
monoidDeriver :: Deriver
monoidDeriver = (Class -> Datatype -> Synth EvTerm) -> Deriver
Deriver \Class
cls Datatype
dt -> do
  Class
semigroupCls <- TcPluginM Class -> Synth Class
forall a. TcPluginM a -> Synth a
liftTc (Name -> TcPluginM Class
tcLookupClass Name
semigroupClassName)
  EvTerm
superEv      <- Deriver -> Class -> Datatype -> Synth EvTerm
runDeriver Deriver
semigroupDeriver Class
semigroupCls Datatype
dt
  let via :: Type
via       = Datatype -> Type
dtVia Datatype
dt
      memptySel :: Id
memptySel = String -> Class -> Id
classMethod String
"mempty" Class
cls                 -- mempty
      mapMempty :: Type -> Arg b -> Arg b
mapMempty Type
ft Arg b
d = Arg b -> [Arg b] -> Arg b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Arg b
forall b. Id -> Expr b
Var Id
memptySel) [Type -> Arg b
forall b. Type -> Expr b
Type Type
ft, Arg b
d]
  CoreExpr
memptyVal <- Datatype -> [CoreExpr] -> CoreExpr
toProduct Datatype
dt ([CoreExpr] -> CoreExpr) -> Synth [CoreExpr] -> Synth CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Class
-> (Type -> CoreExpr -> CoreExpr)
-> Constructor
-> Synth [CoreExpr]
cpureFields Class
cls Type -> CoreExpr -> CoreExpr
forall {b}. Type -> Arg b -> Arg b
mapMempty (Datatype -> Constructor
productCon Datatype
dt)
  CoreExpr
dict <- TcPluginM CoreExpr -> Synth CoreExpr
forall a. TcPluginM a -> Synth a
liftTc (Class
-> Type -> [CoreExpr] -> [(Int, CoreExpr)] -> TcPluginM CoreExpr
recDictWith Class
cls Type
via [EvTerm -> CoreExpr
unwrapEv EvTerm
superEv] [(Int
0, CoreExpr
memptyVal)])
  EvTerm -> Synth EvTerm
forall a. a -> Synth a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> EvTerm
EvExpr CoreExpr
dict)