{-# LANGUAGE BlockArguments #-}
-- @head@/@last cons@ are guarded by the caller's
-- enum-or-single-constructor contract and the class always having its methods.
{-# OPTIONS_GHC -Wno-x-partial -Wno-unused-imports #-}

-- | @Bounded@ via the SOP-EDSL.  @minBound@\/@maxBound@ are values, so this is
-- pure 'injectSOP' (no @matchSOP@): an enumeration injects its first\/last
-- (nullary) constructor; a single-constructor product injects that constructor
-- with each field set to its own @minBound@\/@maxBound@ ('pureFields' +
-- 'field').  A clean demonstration that the SDK alone expresses a real
-- synthesizer — this module needs nothing from the plugin substrate.
module Stock.Bounded (boundedDeriver) where

import GHC.Plugins
import GHC.Core.Class (classMethods)
import Stock.Derive

-- | The caller guarantees the type is an enumeration or a single constructor
-- (GHC's @Bounded@ deriving has the same restriction).
boundedDeriver :: Deriver
boundedDeriver :: Deriver
boundedDeriver = (Class -> Datatype -> Synth EvTerm) -> Deriver
Deriver \Class
cls Datatype
dt -> do
  let cons :: [Constructor]
cons   = Datatype -> [Constructor]
dtCons Datatype
dt
      minSel :: Id
minSel = String -> Class -> Id
classMethod String
"minBound" Class
cls
      maxSel :: Id
maxSel = String -> Class -> Id
classMethod String
"maxBound" Class
cls
      bound :: Id -> Type -> Arg b -> Arg b
bound Id
sel 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
sel) [Type -> Arg b
forall b. Type -> Expr b
Type Type
ft, Arg b
d]
  if (Constructor -> Bool) -> [Constructor] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Type] -> Bool) -> (Constructor -> [Type]) -> Constructor -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constructor -> [Type]
conFields) [Constructor]
cons
    then                                     -- enumeration: first / last constructor
      EvTerm -> Synth EvTerm
forall a. a -> Synth a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Class -> Type -> [CoreExpr] -> EvTerm
classDict Class
cls (Datatype -> Type
dtVia Datatype
dt) [ Datatype -> Constructor -> [CoreExpr] -> CoreExpr
injectSOP Datatype
dt ([Constructor] -> Constructor
forall a. HasCallStack => [a] -> a
head [Constructor]
cons) []
                                     , Datatype -> Constructor -> [CoreExpr] -> CoreExpr
injectSOP Datatype
dt ([Constructor] -> Constructor
forall a. HasCallStack => [a] -> a
last [Constructor]
cons) [] ])
    else do                                  -- single product: each field at its bound
      let con :: Constructor
con = Datatype -> Constructor
productCon Datatype
dt
      [(Type, CoreExpr)]
fds <- (Type -> Synth (Type, CoreExpr))
-> Constructor -> Synth [(Type, CoreExpr)]
forall a. (Type -> Synth a) -> Constructor -> Synth [a]
pureFields (\Type
ft -> do CoreExpr
d <- Class -> Type -> Synth CoreExpr
field Class
cls Type
ft; (Type, CoreExpr) -> Synth (Type, CoreExpr)
forall a. a -> Synth a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
ft, CoreExpr
d)) Constructor
con
      EvTerm -> Synth EvTerm
forall a. a -> Synth a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Class -> Type -> [CoreExpr] -> EvTerm
classDict Class
cls (Datatype -> Type
dtVia Datatype
dt)
              [ Datatype -> Constructor -> [CoreExpr] -> CoreExpr
injectSOP Datatype
dt Constructor
con [ Id -> Type -> CoreExpr -> CoreExpr
forall {b}. Id -> Type -> Arg b -> Arg b
bound Id
minSel Type
ft CoreExpr
d | (Type
ft, CoreExpr
d) <- [(Type, CoreExpr)]
fds ]
              , Datatype -> Constructor -> [CoreExpr] -> CoreExpr
injectSOP Datatype
dt Constructor
con [ Id -> Type -> CoreExpr -> CoreExpr
forall {b}. Id -> Type -> Arg b -> Arg b
bound Id
maxSel Type
ft CoreExpr
d | (Type
ft, CoreExpr
d) <- [(Type, CoreExpr)]
fds ] ])