{-# 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]
  aId <- Type -> String -> Synth Id
fresh Type
via String
"a" ; bId <- fresh via "b"
  body <- fromProduct dt via (Var 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
  dict <- liftTc (recDictWith cls via [] [(0, mkLams [aId, bId] body)])
  pure (EvExpr 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
  semigroupCls <- TcPluginM Class -> Synth Class
forall a. TcPluginM a -> Synth a
liftTc (Name -> TcPluginM Class
tcLookupClass Name
semigroupClassName)
  superEv      <- runDeriver semigroupDeriver semigroupCls dt
  let via       = Datatype -> Type
dtVia Datatype
dt
      memptySel = String -> Class -> Id
classMethod String
"mempty" Class
cls                 -- mempty
      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]
  memptyVal <- toProduct dt <$> cpureFields cls mapMempty (productCon dt)
  dict <- liftTc (recDictWith cls via [unwrapEv superEv] [(0, memptyVal)])
  pure (EvExpr dict)