{- HLINT ignore "Unused LANGUAGE pragma" -} -- HLint doesn't recognize that TypeApplications is used in a pattern
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
module Language.PureScript.TypeChecker.Deriving (deriveInstance) where

import Protolude hiding (Type)

import Control.Monad.Trans.Writer (Writer, WriterT, runWriter, runWriterT)
import Control.Monad.Writer.Class (MonadWriter(..))
import Data.Foldable (foldl1, foldr1)
import Data.List (init, last, zipWith3, (!!))
import qualified Data.Map as M

import Control.Monad.Supply.Class
import Language.PureScript.AST
import Language.PureScript.AST.Utils
import qualified Language.PureScript.Constants.Data.Foldable as Foldable
import qualified Language.PureScript.Constants.Data.Traversable as Traversable
import qualified Language.PureScript.Constants.Prelude as Prelude
import qualified Language.PureScript.Constants.Prim as Prim
import Language.PureScript.Crash
import Language.PureScript.Environment
import Language.PureScript.Errors hiding (nonEmpty)
import Language.PureScript.Label (Label(..))
import Language.PureScript.Names
import Language.PureScript.PSString
import Language.PureScript.Sugar.TypeClasses
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.TypeChecker.Synonyms
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types

-- | Extract the name of the newtype appearing in the last type argument of
-- a derived newtype instance.
--
-- Note: since newtypes in newtype instances can only be applied to type arguments
-- (no flexible instances allowed), we don't need to bother with unification when
-- looking for matching superclass instances, which saves us a lot of work. Instead,
-- we just match the newtype name.
extractNewtypeName :: ModuleName -> [SourceType] -> Maybe (ModuleName, ProperName 'TypeName)
extractNewtypeName :: ModuleName
-> [SourceType] -> Maybe (ModuleName, ProperName 'TypeName)
extractNewtypeName ModuleName
mn
  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Qualified (ProperName 'TypeName)
n, [SourceType]
_, [SourceType]
_) -> forall a. ModuleName -> Qualified a -> (ModuleName, a)
qualify ModuleName
mn Qualified (ProperName 'TypeName)
n)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourceType
-> Maybe
     (Qualified (ProperName 'TypeName), [SourceType], [SourceType])
unwrapTypeConstructor forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. [a] -> Maybe a
lastMay)

deriveInstance
  :: forall m
   . MonadError MultipleErrors m
  => MonadState CheckState m
  => MonadSupply m
  => MonadWriter MultipleErrors m
  => SourceType
  -> Qualified (ProperName 'ClassName)
  -> InstanceDerivationStrategy
  -> m Expr
deriveInstance :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m, MonadWriter MultipleErrors m) =>
SourceType
-> Qualified (ProperName 'ClassName)
-> InstanceDerivationStrategy
-> m Expr
deriveInstance SourceType
instType Qualified (ProperName 'ClassName)
className InstanceDerivationStrategy
strategy = do
  ModuleName
mn <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
m ModuleName
unsafeCheckCurrentModule
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName -> Qualified (ProperName 'ConstructorName)
ctorName, [SourceType]
_, [SourceType]
tys) <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a.
(MonadError MultipleErrors m, HasCallStack) =>
Text -> m a
internalCompilerError Text
"invalid instance type") forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SourceType
-> Maybe
     (Qualified (ProperName 'TypeName), [SourceType], [SourceType])
unwrapTypeConstructor SourceType
instType

  TypeClassData{Bool
[(Text, Maybe SourceType)]
[(Ident, SourceType)]
[SourceConstraint]
[FunctionalDependency]
Set Int
Set (Set Int)
typeClassIsEmpty :: TypeClassData -> Bool
typeClassCoveringSets :: TypeClassData -> Set (Set Int)
typeClassDeterminedArguments :: TypeClassData -> Set Int
typeClassDependencies :: TypeClassData -> [FunctionalDependency]
typeClassSuperclasses :: TypeClassData -> [SourceConstraint]
typeClassMembers :: TypeClassData -> [(Ident, SourceType)]
typeClassArguments :: TypeClassData -> [(Text, Maybe SourceType)]
typeClassIsEmpty :: Bool
typeClassCoveringSets :: Set (Set Int)
typeClassDeterminedArguments :: Set Int
typeClassDependencies :: [FunctionalDependency]
typeClassSuperclasses :: [SourceConstraint]
typeClassMembers :: [(Ident, SourceType)]
typeClassArguments :: [(Text, Maybe SourceType)]
..} <-
    forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
note (SimpleErrorMessage -> MultipleErrors
errorMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Qualified Name -> SimpleErrorMessage
UnknownName forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ProperName 'ClassName -> Name
TyClassName Qualified (ProperName 'ClassName)
className) forall a b. (a -> b) -> a -> b
$
      Qualified (ProperName 'ClassName)
className forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Environment
env

  case InstanceDerivationStrategy
strategy of
    InstanceDerivationStrategy
KnownClassStrategy -> let
      unaryClass :: (ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]) -> m Expr
      unaryClass :: (ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
f = case [SourceType]
tys of
        [SourceType
ty] -> case SourceType
-> Maybe
     (Qualified (ProperName 'TypeName), [SourceType], [SourceType])
unwrapTypeConstructor SourceType
ty of
          Just (Qualified (ByModuleName ModuleName
mn') ProperName 'TypeName
tyCon, [SourceType]
_, [SourceType]
_) | ModuleName
mn forall a. Eq a => a -> a -> Bool
== ModuleName
mn' -> do
            let superclassesDicts :: [Expr]
superclassesDicts = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map [SourceConstraint]
typeClassSuperclasses forall a b. (a -> b) -> a -> b
$ \(Constraint SourceAnn
_ Qualified (ProperName 'ClassName)
superclass [SourceType]
_ [SourceType]
suTyArgs Maybe ConstraintData
_) ->
                  let tyArgs :: [SourceType]
tyArgs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall a. [(Text, Type a)] -> Type a -> Type a
replaceAllTypeVars (forall a b. [a] -> [b] -> [(a, b)]
zip (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. (a, b) -> a
fst [(Text, Maybe SourceType)]
typeClassArguments) [SourceType]
tys)) [SourceType]
suTyArgs
                  in Ident -> Expr -> Expr
lam Ident
UnusedIdent (Qualified (ProperName 'ClassName) -> [SourceType] -> Expr
DeferredDictionary Qualified (ProperName 'ClassName)
superclass [SourceType]
tyArgs)
            let superclasses :: [(PSString, Expr)]
superclasses = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> PSString
mkString (forall a. [Constraint a] -> [Text]
superClassDictionaryNames [SourceConstraint]
typeClassSuperclasses) forall a b. [a] -> [b] -> [(a, b)]
`zip` [Expr]
superclassesDicts
            Expr -> Expr -> Expr
App (SourceSpan -> Qualified (ProperName 'ConstructorName) -> Expr
Constructor SourceSpan
nullSourceSpan Qualified (ProperName 'ConstructorName)
ctorName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal Expr -> Expr
mkLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(PSString, a)] -> Literal a
ObjectLiteral forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ [(PSString, Expr)]
superclasses) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
f ModuleName
mn ProperName 'TypeName
tyCon
          Maybe
  (Qualified (ProperName 'TypeName), [SourceType], [SourceType])
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> [SourceType] -> SourceType -> SimpleErrorMessage
ExpectedTypeConstructor Qualified (ProperName 'ClassName)
className [SourceType]
tys SourceType
ty
        [SourceType]
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> [SourceType] -> Int -> SimpleErrorMessage
InvalidDerivedInstance Qualified (ProperName 'ClassName)
className [SourceType]
tys Int
1

      unaryClass' :: (Qualified (ProperName 'ClassName)
 -> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass' Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
f = (ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass (Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
f Qualified (ProperName 'ClassName)
className)

      in case Qualified (ProperName 'ClassName)
className of
        Qualified (ProperName 'ClassName)
Foldable.Foldable -> (Qualified (ProperName 'ClassName)
 -> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass' forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveFoldable
        Qualified (ProperName 'ClassName)
Prelude.Eq -> (ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveEq
        Qualified (ProperName 'ClassName)
Prelude.Eq1 -> (ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass forall a b. (a -> b) -> a -> b
$ \ModuleName
_ ProperName 'TypeName
_ -> forall (m :: * -> *). Applicative m => m [(PSString, Expr)]
deriveEq1
        Qualified (ProperName 'ClassName)
Prelude.Functor -> (Qualified (ProperName 'ClassName)
 -> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass' forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveFunctor
        Qualified (ProperName 'ClassName)
Prelude.Ord -> (ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveOrd
        Qualified (ProperName 'ClassName)
Prelude.Ord1 -> (ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass forall a b. (a -> b) -> a -> b
$ \ModuleName
_ ProperName 'TypeName
_ -> forall (m :: * -> *). Applicative m => m [(PSString, Expr)]
deriveOrd1
        Qualified (ProperName 'ClassName)
Traversable.Traversable -> (Qualified (ProperName 'ClassName)
 -> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass' forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveTraversable
        -- See L.P.Sugar.TypeClasses.Deriving for the classes that can be
        -- derived prior to type checking.
        Qualified (ProperName 'ClassName)
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> [SourceType] -> SimpleErrorMessage
CannotDerive Qualified (ProperName 'ClassName)
className [SourceType]
tys

    InstanceDerivationStrategy
NewtypeStrategy ->
      case [SourceType]
tys of
        SourceType
_ : [SourceType]
_ | Just (Qualified (ByModuleName ModuleName
mn') ProperName 'TypeName
tyCon, [SourceType]
kargs, [SourceType]
args) <- SourceType
-> Maybe
     (Qualified (ProperName 'TypeName), [SourceType], [SourceType])
unwrapTypeConstructor (forall a. [a] -> a
last [SourceType]
tys)
              , ModuleName
mn forall a. Eq a => a -> a -> Bool
== ModuleName
mn'
              -> forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m, MonadWriter MultipleErrors m) =>
ModuleName
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> ProperName 'TypeName
-> [SourceType]
-> [SourceType]
-> m Expr
deriveNewtypeInstance ModuleName
mn Qualified (ProperName 'ClassName)
className [SourceType]
tys ProperName 'TypeName
tyCon [SourceType]
kargs [SourceType]
args
              | Bool
otherwise -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> [SourceType] -> SourceType -> SimpleErrorMessage
ExpectedTypeConstructor Qualified (ProperName 'ClassName)
className [SourceType]
tys (forall a. [a] -> a
last [SourceType]
tys)
        [SourceType]
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> [SourceType] -> SimpleErrorMessage
InvalidNewtypeInstance Qualified (ProperName 'ClassName)
className [SourceType]
tys

deriveNewtypeInstance
  :: forall m
   . MonadError MultipleErrors m
  => MonadState CheckState m
  => MonadSupply m
  => MonadWriter MultipleErrors m
  => ModuleName
  -> Qualified (ProperName 'ClassName)
  -> [SourceType]
  -> ProperName 'TypeName
  -> [SourceType]
  -> [SourceType]
  -> m Expr
deriveNewtypeInstance :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m, MonadWriter MultipleErrors m) =>
ModuleName
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> ProperName 'TypeName
-> [SourceType]
-> [SourceType]
-> m Expr
deriveNewtypeInstance ModuleName
mn Qualified (ProperName 'ClassName)
className [SourceType]
tys ProperName 'TypeName
tyConNm [SourceType]
dkargs [SourceType]
dargs = do
    m ()
verifySuperclasses
    (Maybe DataDeclType
dtype, [Text]
tyKindNames, [(Text, Maybe SourceType)]
tyArgNames, [(ProperName 'ConstructorName, [SourceType])]
ctors) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> ProperName 'TypeName
-> m (Maybe DataDeclType, [Text], [(Text, Maybe SourceType)],
      [(ProperName 'ConstructorName, [SourceType])])
lookupTypeDecl ModuleName
mn ProperName 'TypeName
tyConNm
    Maybe DataDeclType
-> [Text]
-> [(Text, Maybe SourceType)]
-> [(ProperName 'ConstructorName, [SourceType])]
-> m Expr
go Maybe DataDeclType
dtype [Text]
tyKindNames [(Text, Maybe SourceType)]
tyArgNames [(ProperName 'ConstructorName, [SourceType])]
ctors
  where
    go :: Maybe DataDeclType
-> [Text]
-> [(Text, Maybe SourceType)]
-> [(ProperName 'ConstructorName, [SourceType])]
-> m Expr
go (Just DataDeclType
Newtype) [Text]
tyKindNames [(Text, Maybe SourceType)]
tyArgNames [(ProperName 'ConstructorName
_, [SourceType
wrapped])] = do
      -- The newtype might not be applied to all type arguments.
      -- This is okay as long as the newtype wraps something which ends with
      -- sufficiently many type applications to variables.
      -- For example, we can derive Functor for
      --
      -- newtype MyArray a = MyArray (Array a)
      --
      -- since Array a is a type application which uses the last
      -- type argument
      SourceType
wrapped' <- forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms SourceType
wrapped
      case forall kind. [(Text, Maybe kind)] -> SourceType -> Maybe SourceType
stripRight (forall a. Int -> [a] -> [a]
takeReverse (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Maybe SourceType)]
tyArgNames forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceType]
dargs) [(Text, Maybe SourceType)]
tyArgNames) SourceType
wrapped' of
        Just SourceType
wrapped'' -> do
          let subst :: [(Text, SourceType)]
subst = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Text
name, Maybe SourceType
_) SourceType
t -> (Text
name, SourceType
t)) [(Text, Maybe SourceType)]
tyArgNames [SourceType]
dargs forall a. Semigroup a => a -> a -> a
<> forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
tyKindNames [SourceType]
dkargs
          SourceType
wrapped''' <- forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms forall a b. (a -> b) -> a -> b
$ forall a. [(Text, Type a)] -> Type a -> Type a
replaceAllTypeVars [(Text, SourceType)]
subst SourceType
wrapped''
          [SourceType]
tys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms [SourceType]
tys
          forall (m :: * -> *) a. Monad m => a -> m a
return (Qualified (ProperName 'ClassName) -> [SourceType] -> Expr
DeferredDictionary Qualified (ProperName 'ClassName)
className (forall a. [a] -> [a]
init [SourceType]
tys' forall a. [a] -> [a] -> [a]
++ [SourceType
wrapped''']))
        Maybe SourceType
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> [SourceType] -> SimpleErrorMessage
InvalidNewtypeInstance Qualified (ProperName 'ClassName)
className [SourceType]
tys
    go Maybe DataDeclType
_ [Text]
_ [(Text, Maybe SourceType)]
_ [(ProperName 'ConstructorName, [SourceType])]
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> [SourceType] -> SimpleErrorMessage
InvalidNewtypeInstance Qualified (ProperName 'ClassName)
className [SourceType]
tys

    takeReverse :: Int -> [a] -> [a]
    takeReverse :: forall a. Int -> [a] -> [a]
takeReverse Int
n = forall a. Int -> [a] -> [a]
take Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

    stripRight :: [(Text, Maybe kind)] -> SourceType -> Maybe SourceType
    stripRight :: forall kind. [(Text, Maybe kind)] -> SourceType -> Maybe SourceType
stripRight [] SourceType
ty = forall a. a -> Maybe a
Just SourceType
ty
    stripRight ((Text
arg, Maybe kind
_) : [(Text, Maybe kind)]
args) (TypeApp SourceAnn
_ SourceType
t (TypeVar SourceAnn
_ Text
arg'))
      | Text
arg forall a. Eq a => a -> a -> Bool
== Text
arg' = forall kind. [(Text, Maybe kind)] -> SourceType -> Maybe SourceType
stripRight [(Text, Maybe kind)]
args SourceType
t
    stripRight [(Text, Maybe kind)]
_ SourceType
_ = forall a. Maybe a
Nothing

    verifySuperclasses :: m ()
    verifySuperclasses :: m ()
verifySuperclasses = do
      Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'ClassName)
className (Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Environment
env)) forall a b. (a -> b) -> a -> b
$ \TypeClassData{ typeClassArguments :: TypeClassData -> [(Text, Maybe SourceType)]
typeClassArguments = [(Text, Maybe SourceType)]
args, typeClassSuperclasses :: TypeClassData -> [SourceConstraint]
typeClassSuperclasses = [SourceConstraint]
superclasses } ->
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [SourceConstraint]
superclasses forall a b. (a -> b) -> a -> b
$ \Constraint{[SourceType]
Maybe ConstraintData
SourceAnn
Qualified (ProperName 'ClassName)
constraintData :: forall a. Constraint a -> Maybe ConstraintData
constraintArgs :: forall a. Constraint a -> [Type a]
constraintKindArgs :: forall a. Constraint a -> [Type a]
constraintClass :: forall a. Constraint a -> Qualified (ProperName 'ClassName)
constraintAnn :: forall a. Constraint a -> a
constraintData :: Maybe ConstraintData
constraintArgs :: [SourceType]
constraintKindArgs :: [SourceType]
constraintClass :: Qualified (ProperName 'ClassName)
constraintAnn :: SourceAnn
..} -> do
          let constraintClass' :: (ModuleName, ProperName 'ClassName)
constraintClass' = forall a. ModuleName -> Qualified a -> (ModuleName, a)
qualify (forall a. HasCallStack => String -> a
internalError String
"verifySuperclasses: unknown class module") Qualified (ProperName 'ClassName)
constraintClass
          forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'ClassName)
constraintClass (Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Environment
env)) forall a b. (a -> b) -> a -> b
$ \TypeClassData{ typeClassDependencies :: TypeClassData -> [FunctionalDependency]
typeClassDependencies = [FunctionalDependency]
deps } ->
            -- We need to check whether the newtype is mentioned, because of classes like MonadWriter
            -- with its Monoid superclass constraint.
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, Maybe SourceType)]
args) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((forall a b. (a, b) -> a
fst (forall a. [a] -> a
last [(Text, Maybe SourceType)]
args) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Type a -> [Text]
usedTypeVariables) [SourceType]
constraintArgs) forall a b. (a -> b) -> a -> b
$ do
              -- For now, we only verify superclasses where the newtype is the only argument,
              -- or for which all other arguments are determined by functional dependencies.
              -- Everything else raises a UnverifiableSuperclassInstance warning.
              -- This covers pretty much all cases we're interested in, but later we might want to do
              -- more work to extend this to other superclass relationships.
              let determined :: [SourceType]
determined = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text -> SourceType
srcTypeVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Text, Maybe SourceType)]
args forall a. [a] -> Int -> a
!!)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
ordNub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FunctionalDependency -> [Int]
fdDetermined forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== [forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Maybe SourceType)]
args forall a. Num a => a -> a -> a
- Int
1]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunctionalDependency -> [Int]
fdDeterminers) forall a b. (a -> b) -> a -> b
$ [FunctionalDependency]
deps
              if forall a b. Type a -> Type b -> Bool
eqType (forall a. [a] -> a
last [SourceType]
constraintArgs) (Text -> SourceType
srcTypeVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [(Text, Maybe SourceType)]
args) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SourceType]
determined) (forall a. [a] -> [a]
init [SourceType]
constraintArgs)
                then do
                  -- Now make sure that a superclass instance was derived. Again, this is not a complete
                  -- check, since the superclass might have multiple type arguments, so overlaps might still
                  -- be possible, so we warn again.
                  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (ModuleName
-> [SourceType] -> Maybe (ModuleName, ProperName 'TypeName)
extractNewtypeName ModuleName
mn [SourceType]
tys) forall a b. (a -> b) -> a -> b
$ \(ModuleName, ProperName 'TypeName)
nm -> do
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall {t :: * -> *} {a} {k} {v}.
(Foldable t, Ord a) =>
(ModuleName, a)
-> (ModuleName, ProperName 'TypeName)
-> Map
     QualifiedBy
     (Map (Qualified a) (Map k (t (TypeClassDictionaryInScope v))))
-> Bool
hasNewtypeSuperclassInstance (ModuleName, ProperName 'ClassName)
constraintClass' (ModuleName, ProperName 'TypeName)
nm (Environment
-> Map
     QualifiedBy
     (Map
        (Qualified (ProperName 'ClassName))
        (Map (Qualified Ident) (NonEmpty NamedDict)))
typeClassDictionaries Environment
env)) forall a b. (a -> b) -> a -> b
$
                      forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> SimpleErrorMessage
MissingNewtypeSuperclassInstance Qualified (ProperName 'ClassName)
constraintClass Qualified (ProperName 'ClassName)
className [SourceType]
tys
                else forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> SimpleErrorMessage
UnverifiableSuperclassInstance Qualified (ProperName 'ClassName)
constraintClass Qualified (ProperName 'ClassName)
className [SourceType]
tys

    -- Note that this check doesn't actually verify that the superclass is
    -- newtype-derived; see #3168. The whole verifySuperclasses feature
    -- is pretty sketchy, and could use a thorough review and probably rewrite.
    hasNewtypeSuperclassInstance :: (ModuleName, a)
-> (ModuleName, ProperName 'TypeName)
-> Map
     QualifiedBy
     (Map (Qualified a) (Map k (t (TypeClassDictionaryInScope v))))
-> Bool
hasNewtypeSuperclassInstance (ModuleName
suModule, a
suClass) nt :: (ModuleName, ProperName 'TypeName)
nt@(ModuleName
newtypeModule, ProperName 'TypeName
_) Map
  QualifiedBy
  (Map (Qualified a) (Map k (t (TypeClassDictionaryInScope v))))
dicts =
      let su :: Qualified a
su = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
suModule) a
suClass
          lookIn :: ModuleName -> Bool
lookIn ModuleName
mn'
            = forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (ModuleName, ProperName 'TypeName)
nt
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName
-> [SourceType] -> Maybe (ModuleName, ProperName 'TypeName)
extractNewtypeName ModuleName
mn' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. TypeClassDictionaryInScope v -> [SourceType]
tcdInstanceTypes
                forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
M.elems
                forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified a
su forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn')))
            forall a b. (a -> b) -> a -> b
$ Map
  QualifiedBy
  (Map (Qualified a) (Map k (t (TypeClassDictionaryInScope v))))
dicts
      in ModuleName -> Bool
lookIn ModuleName
suModule Bool -> Bool -> Bool
|| ModuleName -> Bool
lookIn ModuleName
newtypeModule

deriveEq
  :: forall m
   . MonadError MultipleErrors m
  => MonadState CheckState m
  => MonadSupply m
  => ModuleName
  -> ProperName 'TypeName
  -> m [(PSString, Expr)]
deriveEq :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveEq ModuleName
mn ProperName 'TypeName
tyConNm = do
  (Maybe DataDeclType
_, [Text]
_, [(Text, Maybe SourceType)]
_, [(ProperName 'ConstructorName, [SourceType])]
ctors) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> ProperName 'TypeName
-> m (Maybe DataDeclType, [Text], [(Text, Maybe SourceType)],
      [(ProperName 'ConstructorName, [SourceType])])
lookupTypeDecl ModuleName
mn ProperName 'TypeName
tyConNm
  Expr
eqFun <- [(ProperName 'ConstructorName, [SourceType])] -> m Expr
mkEqFunction [(ProperName 'ConstructorName, [SourceType])]
ctors
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. IsString a => a
Prelude.eq, Expr
eqFun)]
  where
    mkEqFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr
    mkEqFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr
mkEqFunction [(ProperName 'ConstructorName, [SourceType])]
ctors = do
      Ident
x <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"x"
      Ident
y <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"y"
      Ident -> Ident -> [CaseAlternative] -> Expr
lamCase2 Ident
x Ident
y forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CaseAlternative] -> [CaseAlternative]
addCatch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ProperName 'ConstructorName, [SourceType]) -> m CaseAlternative
mkCtorClause [(ProperName 'ConstructorName, [SourceType])]
ctors

    preludeConj :: Expr -> Expr -> Expr
    preludeConj :: Expr -> Expr -> Expr
preludeConj = Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App (Maybe ModuleName -> Ident -> Expr
mkVarMn (forall a. a -> Maybe a
Just (Text -> ModuleName
ModuleName Text
"Data.HeytingAlgebra")) (Text -> Ident
Ident forall a. IsString a => a
Prelude.conj))

    preludeEq :: Expr -> Expr -> Expr
    preludeEq :: Expr -> Expr -> Expr
preludeEq = Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App (Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identEq)

    preludeEq1 :: Expr -> Expr -> Expr
    preludeEq1 :: Expr -> Expr -> Expr
preludeEq1 = Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App (Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identEq1)

    addCatch :: [CaseAlternative] -> [CaseAlternative]
    addCatch :: [CaseAlternative] -> [CaseAlternative]
addCatch [CaseAlternative]
xs
      | forall (t :: * -> *) a. Foldable t => t a -> Int
length [CaseAlternative]
xs forall a. Eq a => a -> a -> Bool
/= Int
1 = [CaseAlternative]
xs forall a. [a] -> [a] -> [a]
++ [CaseAlternative
catchAll]
      | Bool
otherwise = [CaseAlternative]
xs -- Avoid redundant case
      where
      catchAll :: CaseAlternative
catchAll = [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
NullBinder, Binder
NullBinder] (Expr -> [GuardedExpr]
unguarded (Literal Expr -> Expr
mkLit (forall a. Bool -> Literal a
BooleanLiteral Bool
False)))

    mkCtorClause :: (ProperName 'ConstructorName, [SourceType]) -> m CaseAlternative
    mkCtorClause :: (ProperName 'ConstructorName, [SourceType]) -> m CaseAlternative
mkCtorClause (ProperName 'ConstructorName
ctorName, [SourceType]
tys) = do
      [Ident]
identsL <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceType]
tys) (forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"l")
      [Ident]
identsR <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceType]
tys) (forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"r")
      [SourceType]
tys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms [SourceType]
tys
      let tests :: [Expr]
tests = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Expr -> Expr -> SourceType -> Expr
toEqTest (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Ident -> Expr
mkVar [Ident]
identsL) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Ident -> Expr
mkVar [Ident]
identsR) [SourceType]
tys'
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [[Ident] -> Binder
caseBinder [Ident]
identsL, [Ident] -> Binder
caseBinder [Ident]
identsR] (Expr -> [GuardedExpr]
unguarded ([Expr] -> Expr
conjAll [Expr]
tests))
      where
      caseBinder :: [Ident] -> Binder
caseBinder [Ident]
idents = ModuleName -> ProperName 'ConstructorName -> [Binder] -> Binder
mkCtorBinder ModuleName
mn ProperName 'ConstructorName
ctorName forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Ident -> Binder
mkBinder [Ident]
idents

    conjAll :: [Expr] -> Expr
    conjAll :: [Expr] -> Expr
conjAll = \case
      [] -> Literal Expr -> Expr
mkLit (forall a. Bool -> Literal a
BooleanLiteral Bool
True)
      [Expr]
xs -> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Expr -> Expr -> Expr
preludeConj [Expr]
xs

    toEqTest :: Expr -> Expr -> SourceType -> Expr
    toEqTest :: Expr -> Expr -> SourceType -> Expr
toEqTest Expr
l Expr
r SourceType
ty
      | Just [(Label, SourceType)]
fields <- SourceType -> Maybe [(Label, SourceType)]
decomposeRec forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. Type a -> Maybe (Type a)
objectType forall a b. (a -> b) -> a -> b
$ SourceType
ty
        = [Expr] -> Expr
conjAll
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(Label PSString
str, SourceType
typ) -> Expr -> Expr -> SourceType -> Expr
toEqTest (PSString -> Expr -> Expr
Accessor PSString
str Expr
l) (PSString -> Expr -> Expr
Accessor PSString
str Expr
r) SourceType
typ)
        forall a b. (a -> b) -> a -> b
$ [(Label, SourceType)]
fields
      | forall a. Type a -> Bool
isAppliedVar SourceType
ty = Expr -> Expr -> Expr
preludeEq1 Expr
l Expr
r
      | Bool
otherwise = Expr -> Expr -> Expr
preludeEq Expr
l Expr
r

deriveEq1 :: forall m. Applicative m => m [(PSString, Expr)]
deriveEq1 :: forall (m :: * -> *). Applicative m => m [(PSString, Expr)]
deriveEq1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. IsString a => a
Prelude.eq1, Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identEq)]

deriveOrd
  :: forall m
   . MonadError MultipleErrors m
  => MonadState CheckState m
  => MonadSupply m
  => ModuleName
  -> ProperName 'TypeName
  -> m [(PSString, Expr)]
deriveOrd :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveOrd ModuleName
mn ProperName 'TypeName
tyConNm = do
  (Maybe DataDeclType
_, [Text]
_, [(Text, Maybe SourceType)]
_, [(ProperName 'ConstructorName, [SourceType])]
ctors) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> ProperName 'TypeName
-> m (Maybe DataDeclType, [Text], [(Text, Maybe SourceType)],
      [(ProperName 'ConstructorName, [SourceType])])
lookupTypeDecl ModuleName
mn ProperName 'TypeName
tyConNm
  Expr
compareFun <- [(ProperName 'ConstructorName, [SourceType])] -> m Expr
mkCompareFunction [(ProperName 'ConstructorName, [SourceType])]
ctors
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. IsString a => a
Prelude.compare, Expr
compareFun)]
  where
    mkCompareFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr
    mkCompareFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr
mkCompareFunction [(ProperName 'ConstructorName, [SourceType])]
ctors = do
      Ident
x <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"x"
      Ident
y <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"y"
      Ident -> Ident -> [CaseAlternative] -> Expr
lamCase2 Ident
x Ident
y forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([CaseAlternative] -> [CaseAlternative]
addCatch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((ProperName 'ConstructorName, [SourceType]), Bool)
-> m [CaseAlternative]
mkCtorClauses (forall a. [a] -> [(a, Bool)]
splitLast [(ProperName 'ConstructorName, [SourceType])]
ctors))

    splitLast :: [a] -> [(a, Bool)]
    splitLast :: forall a. [a] -> [(a, Bool)]
splitLast [] = []
    splitLast [a
x] = [(a
x, Bool
True)]
    splitLast (a
x : [a]
xs) = (a
x, Bool
False) forall a. a -> [a] -> [a]
: forall a. [a] -> [(a, Bool)]
splitLast [a]
xs

    addCatch :: [CaseAlternative] -> [CaseAlternative]
    addCatch :: [CaseAlternative] -> [CaseAlternative]
addCatch [CaseAlternative]
xs
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CaseAlternative]
xs = [CaseAlternative
catchAll] -- No type constructors
      | Bool
otherwise = [CaseAlternative]
xs
      where
      catchAll :: CaseAlternative
catchAll = [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
NullBinder, Binder
NullBinder] (Expr -> [GuardedExpr]
unguarded (Text -> Expr
orderingCtor Text
"EQ"))

    orderingMod :: ModuleName
    orderingMod :: ModuleName
orderingMod = Text -> ModuleName
ModuleName Text
"Data.Ordering"

    orderingCtor :: Text -> Expr
    orderingCtor :: Text -> Expr
orderingCtor = ModuleName -> ProperName 'ConstructorName -> Expr
mkCtor ModuleName
orderingMod forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: ProperNameType). Text -> ProperName a
ProperName

    orderingBinder :: Text -> Binder
    orderingBinder :: Text -> Binder
orderingBinder Text
name = ModuleName -> ProperName 'ConstructorName -> [Binder] -> Binder
mkCtorBinder ModuleName
orderingMod (forall (a :: ProperNameType). Text -> ProperName a
ProperName Text
name) []

    ordCompare :: Expr -> Expr -> Expr
    ordCompare :: Expr -> Expr -> Expr
ordCompare = Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App (Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identCompare)

    ordCompare1 :: Expr -> Expr -> Expr
    ordCompare1 :: Expr -> Expr -> Expr
ordCompare1 = Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App (Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identCompare1)

    mkCtorClauses :: ((ProperName 'ConstructorName, [SourceType]), Bool) -> m [CaseAlternative]
    mkCtorClauses :: ((ProperName 'ConstructorName, [SourceType]), Bool)
-> m [CaseAlternative]
mkCtorClauses ((ProperName 'ConstructorName
ctorName, [SourceType]
tys), Bool
isLast) = do
      [Ident]
identsL <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceType]
tys) (forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"l")
      [Ident]
identsR <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceType]
tys) (forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"r")
      [SourceType]
tys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms [SourceType]
tys
      let tests :: [Expr]
tests = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Expr -> Expr -> SourceType -> Expr
toOrdering (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Ident -> Expr
mkVar [Ident]
identsL) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Ident -> Expr
mkVar [Ident]
identsR) [SourceType]
tys'
          extras :: [CaseAlternative]
extras | Bool -> Bool
not Bool
isLast = [ [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
nullCaseBinder, Binder
NullBinder] (Expr -> [GuardedExpr]
unguarded (Text -> Expr
orderingCtor Text
"LT"))
                                , [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
NullBinder, Binder
nullCaseBinder] (Expr -> [GuardedExpr]
unguarded (Text -> Expr
orderingCtor Text
"GT"))
                                ]
                 | Bool
otherwise = []
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [ [Ident] -> Binder
caseBinder [Ident]
identsL
                               , [Ident] -> Binder
caseBinder [Ident]
identsR
                               ]
                               (Expr -> [GuardedExpr]
unguarded ([Expr] -> Expr
appendAll [Expr]
tests))
             forall a. a -> [a] -> [a]
: [CaseAlternative]
extras

      where
      caseBinder :: [Ident] -> Binder
caseBinder [Ident]
idents = ModuleName -> ProperName 'ConstructorName -> [Binder] -> Binder
mkCtorBinder ModuleName
mn ProperName 'ConstructorName
ctorName forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Ident -> Binder
mkBinder [Ident]
idents
      nullCaseBinder :: Binder
nullCaseBinder = ModuleName -> ProperName 'ConstructorName -> [Binder] -> Binder
mkCtorBinder ModuleName
mn ProperName 'ConstructorName
ctorName forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceType]
tys) Binder
NullBinder

    appendAll :: [Expr] -> Expr
    appendAll :: [Expr] -> Expr
appendAll = \case
      [] -> Text -> Expr
orderingCtor Text
"EQ"
      [Expr
x] -> Expr
x
      (Expr
x : [Expr]
xs) -> [Expr] -> [CaseAlternative] -> Expr
Case [Expr
x] [ [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Text -> Binder
orderingBinder Text
"LT"] (Expr -> [GuardedExpr]
unguarded (Text -> Expr
orderingCtor Text
"LT"))
                           , [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Text -> Binder
orderingBinder Text
"GT"] (Expr -> [GuardedExpr]
unguarded (Text -> Expr
orderingCtor Text
"GT"))
                           , [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
NullBinder] (Expr -> [GuardedExpr]
unguarded ([Expr] -> Expr
appendAll [Expr]
xs))
                           ]

    toOrdering :: Expr -> Expr -> SourceType -> Expr
    toOrdering :: Expr -> Expr -> SourceType -> Expr
toOrdering Expr
l Expr
r SourceType
ty
      | Just [(Label, SourceType)]
fields <- SourceType -> Maybe [(Label, SourceType)]
decomposeRec forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. Type a -> Maybe (Type a)
objectType forall a b. (a -> b) -> a -> b
$ SourceType
ty
        = [Expr] -> Expr
appendAll
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(Label PSString
str, SourceType
typ) -> Expr -> Expr -> SourceType -> Expr
toOrdering (PSString -> Expr -> Expr
Accessor PSString
str Expr
l) (PSString -> Expr -> Expr
Accessor PSString
str Expr
r) SourceType
typ)
        forall a b. (a -> b) -> a -> b
$ [(Label, SourceType)]
fields
      | forall a. Type a -> Bool
isAppliedVar SourceType
ty = Expr -> Expr -> Expr
ordCompare1 Expr
l Expr
r
      | Bool
otherwise = Expr -> Expr -> Expr
ordCompare Expr
l Expr
r

deriveOrd1 :: forall m. Applicative m => m [(PSString, Expr)]
deriveOrd1 :: forall (m :: * -> *). Applicative m => m [(PSString, Expr)]
deriveOrd1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. IsString a => a
Prelude.compare1, Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identCompare)]

lookupTypeDecl
  :: forall m
   . MonadError MultipleErrors m
  => MonadState CheckState m
  => ModuleName
  -> ProperName 'TypeName
  -> m (Maybe DataDeclType, [Text], [(Text, Maybe SourceType)], [(ProperName 'ConstructorName, [SourceType])])
lookupTypeDecl :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> ProperName 'TypeName
-> m (Maybe DataDeclType, [Text], [(Text, Maybe SourceType)],
      [(ProperName 'ConstructorName, [SourceType])])
lookupTypeDecl ModuleName
mn ProperName 'TypeName
typeName = do
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
note (SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ ProperName 'TypeName -> SimpleErrorMessage
CannotFindDerivingType ProperName 'TypeName
typeName) forall a b. (a -> b) -> a -> b
$ do
    (SourceType
kind, DataType DataDeclType
_ [(Text, Maybe SourceType, Role)]
args [(ProperName 'ConstructorName, [SourceType])]
dctors) <- forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn) ProperName 'TypeName
typeName forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env
    ([(SourceAnn, (Text, SourceType))]
kargs, SourceType
_) <- forall a. Type a -> Maybe ([(a, (Text, Type a))], Type a)
completeBinderList SourceType
kind
    let dtype :: Maybe DataDeclType
dtype = do
          (ProperName 'ConstructorName
ctorName, [SourceType]
_) <- forall a. [a] -> Maybe a
headMay [(ProperName 'ConstructorName, [SourceType])]
dctors
          (DataDeclType
a, ProperName 'TypeName
_, SourceType
_, [Ident]
_) <- forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn) ProperName 'ConstructorName
ctorName forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Environment
-> Map
     (Qualified (ProperName 'ConstructorName))
     (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dataConstructors Environment
env
          forall (f :: * -> *) a. Applicative f => a -> f a
pure DataDeclType
a
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DataDeclType
dtype, forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SourceAnn, (Text, SourceType))]
kargs, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(Text
v, Maybe SourceType
k, Role
_) -> (Text
v, Maybe SourceType
k)) [(Text, Maybe SourceType, Role)]
args, [(ProperName 'ConstructorName, [SourceType])]
dctors)

isAppliedVar :: Type a -> Bool
isAppliedVar :: forall a. Type a -> Bool
isAppliedVar (TypeApp a
_ (TypeVar a
_ Text
_) Type a
_) = Bool
True
isAppliedVar Type a
_ = Bool
False

objectType :: Type a -> Maybe (Type a)
objectType :: forall a. Type a -> Maybe (Type a)
objectType (TypeApp a
_ (TypeConstructor a
_ Qualified (ProperName 'TypeName)
Prim.Record) Type a
rec) = forall a. a -> Maybe a
Just Type a
rec
objectType Type a
_ = forall a. Maybe a
Nothing

decomposeRec :: SourceType -> Maybe [(Label, SourceType)]
decomposeRec :: SourceType -> Maybe [(Label, SourceType)]
decomposeRec = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall o a. Ord o => (a -> o) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Type a -> Maybe [(Label, Type a)]
go
  where go :: Type a -> Maybe [(Label, Type a)]
go (RCons a
_ Label
str Type a
typ Type a
typs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Label
str, Type a
typ) forall a. a -> [a] -> [a]
:) (Type a -> Maybe [(Label, Type a)]
go Type a
typs)
        go (REmptyKinded a
_ Maybe (Type a)
_) = forall a. a -> Maybe a
Just []
        go Type a
_ = forall a. Maybe a
Nothing

decomposeRec' :: SourceType -> [(Label, SourceType)]
decomposeRec' :: SourceType -> [(Label, SourceType)]
decomposeRec' = forall o a. Ord o => (a -> o) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Type a -> [(Label, Type a)]
go
  where go :: Type a -> [(Label, Type a)]
go (RCons a
_ Label
str Type a
typ Type a
typs) = (Label
str, Type a
typ) forall a. a -> [a] -> [a]
: Type a -> [(Label, Type a)]
go Type a
typs
        go Type a
_ = []

data ParamUsage
  = IsParam
  | MentionsParam ParamUsage
  | IsRecord (NonEmpty (PSString, ParamUsage))

validateParamsInTypeConstructors
  :: forall m
   . MonadError MultipleErrors m
  => MonadState CheckState m
  => Qualified (ProperName 'ClassName)
  -> ModuleName
  -> ProperName 'TypeName
  -> m [(ProperName 'ConstructorName, [Maybe ParamUsage])]
validateParamsInTypeConstructors :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
Qualified (ProperName 'ClassName)
-> ModuleName
-> ProperName 'TypeName
-> m [(ProperName 'ConstructorName, [Maybe ParamUsage])]
validateParamsInTypeConstructors Qualified (ProperName 'ClassName)
derivingClass ModuleName
mn ProperName 'TypeName
tyConNm = do
  (Maybe DataDeclType
_, [Text]
_, [(Text, Maybe SourceType)]
tyArgNames, [(ProperName 'ConstructorName, [SourceType])]
ctors) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> ProperName 'TypeName
-> m (Maybe DataDeclType, [Text], [(Text, Maybe SourceType)],
      [(ProperName 'ConstructorName, [SourceType])])
lookupTypeDecl ModuleName
mn ProperName 'TypeName
tyConNm
  Text
param <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
note (SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ SourceType -> SourceType -> SimpleErrorMessage
KindsDoNotUnify (SourceType
kindType SourceType -> SourceType -> SourceType
-:> SourceType
kindType) SourceType
kindType) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
lastMay forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. (a, b) -> a
fst [(Text, Maybe SourceType)]
tyArgNames
  [(ProperName 'ConstructorName, [SourceType])]
ctors' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms) [(ProperName 'ConstructorName, [SourceType])]
ctors
  let ([(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctorUsages, [SourceSpan]
problemSpans) = forall w a. Writer w a -> (a, w)
runWriter forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ Text -> SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
typeToUsageOf Text
param) [(ProperName 'ConstructorName, [SourceType])]
ctors'
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
ordNub [SourceSpan]
problemSpans) forall a b. (a -> b) -> a -> b
$ \NonEmpty SourceSpan
sss ->
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (NonEmpty SourceSpan -> ErrorMessageHint
RelatedPositions NonEmpty SourceSpan
sss) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName) -> SimpleErrorMessage
CannotDeriveInvalidConstructorArg Qualified (ProperName 'ClassName)
derivingClass
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctorUsages
  where
  typeToUsageOf :: Text -> SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
  typeToUsageOf :: Text -> SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
typeToUsageOf Text
param = SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
go
    where
    assertNoParamUsedIn :: SourceType -> Writer [SourceSpan] ()
    assertNoParamUsedIn :: SourceType -> Writer [SourceSpan] ()
assertNoParamUsedIn = forall r a. (r -> r -> r) -> (Type a -> r) -> Type a -> r
everythingOnTypes forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>) forall a b. (a -> b) -> a -> b
$ \case
      TypeVar (SourceSpan
ss, [Comment]
_) Text
name | Text
name forall a. Eq a => a -> a -> Bool
== Text
param -> forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [SourceSpan
ss]
      SourceType
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    go :: SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
go = \case
      ForAll SourceAnn
_ Text
name Maybe SourceType
_ SourceType
ty Maybe SkolemScope
_ ->
        if Text
name forall a. Eq a => a -> a -> Bool
== Text
param then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing else SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
go SourceType
ty

      ConstrainedType SourceAnn
_ SourceConstraint
_ SourceType
ty ->
        SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
go SourceType
ty

      TypeApp SourceAnn
_ (TypeConstructor SourceAnn
_ Qualified (ProperName 'TypeName)
Prim.Record) SourceType
row ->
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (PSString, ParamUsage) -> ParamUsage
IsRecord forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (SourceType -> [(Label, SourceType)]
decomposeRec' SourceType
row) forall a b. (a -> b) -> a -> b
$ \(Label PSString
lbl, SourceType
ty) ->
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PSString
lbl, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
go SourceType
ty

      TypeApp SourceAnn
_ SourceType
tyFn SourceType
tyArg -> do
        SourceType -> Writer [SourceSpan] ()
assertNoParamUsedIn SourceType
tyFn
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParamUsage -> ParamUsage
MentionsParam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
go SourceType
tyArg

      TypeVar SourceAnn
_ Text
name ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Text
name forall a. Eq a => a -> a -> Bool
== Text
param) forall (f :: * -> *) a. Alternative f => Bool -> a -> f a
`orEmpty` ParamUsage
IsParam

      SourceType
ty ->
        SourceType -> Writer [SourceSpan] ()
assertNoParamUsedIn SourceType
ty forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. Maybe a
Nothing

usingLamIdent :: forall m. MonadSupply m => (Expr -> m Expr) -> m Expr
usingLamIdent :: forall (m :: * -> *). MonadSupply m => (Expr -> m Expr) -> m Expr
usingLamIdent Expr -> m Expr
cb = do
  Ident
ident <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"v"
  Ident -> Expr -> Expr
lam Ident
ident forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> m Expr
cb (Ident -> Expr
mkVar Ident
ident)

traverseFields :: forall f. Applicative f => (ParamUsage -> Expr -> f Expr) -> NonEmpty (PSString, ParamUsage) -> Expr -> f Expr
traverseFields :: forall (f :: * -> *).
Applicative f =>
(ParamUsage -> Expr -> f Expr)
-> NonEmpty (PSString, ParamUsage) -> Expr -> f Expr
traverseFields ParamUsage -> Expr -> f Expr
f NonEmpty (PSString, ParamUsage)
fields Expr
r = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Expr -> [(PSString, Expr)] -> Expr
ObjectUpdate Expr
r) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (PSString, ParamUsage)
fields) forall a b. (a -> b) -> a -> b
$ \(PSString
lbl, ParamUsage
usage) -> (PSString
lbl, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamUsage -> Expr -> f Expr
f ParamUsage
usage (PSString -> Expr -> Expr
Accessor PSString
lbl Expr
r)

unnestRecords :: forall f. Applicative f => (ParamUsage -> Expr -> f Expr) -> ParamUsage -> Expr -> f Expr
unnestRecords :: forall (f :: * -> *).
Applicative f =>
(ParamUsage -> Expr -> f Expr) -> ParamUsage -> Expr -> f Expr
unnestRecords ParamUsage -> Expr -> f Expr
f = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \ParamUsage -> Expr -> f Expr
go -> \case
  IsRecord NonEmpty (PSString, ParamUsage)
fields -> forall (f :: * -> *).
Applicative f =>
(ParamUsage -> Expr -> f Expr)
-> NonEmpty (PSString, ParamUsage) -> Expr -> f Expr
traverseFields ParamUsage -> Expr -> f Expr
go NonEmpty (PSString, ParamUsage)
fields
  ParamUsage
usage -> ParamUsage -> Expr -> f Expr
f ParamUsage
usage

mkCasesForTraversal
  :: forall f m
   . Applicative f -- this effect distinguishes the semantics of maps, folds, and traversals
  => MonadSupply m
  => ModuleName
  -> (ParamUsage -> Expr -> f Expr) -- how to handle constructor arguments
  -> (f Expr -> m Expr) -- resolve the applicative effect into an expression
  -> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
  -> m Expr
mkCasesForTraversal :: forall (f :: * -> *) (m :: * -> *).
(Applicative f, MonadSupply m) =>
ModuleName
-> (ParamUsage -> Expr -> f Expr)
-> (f Expr -> m Expr)
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkCasesForTraversal ModuleName
mn ParamUsage -> Expr -> f Expr
handleArg f Expr -> m Expr
extractExpr [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors = do
  Ident
m <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"m"
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Ident -> [CaseAlternative] -> Expr
lamCase Ident
m) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors forall a b. (a -> b) -> a -> b
$ \(ProperName 'ConstructorName
ctorName, [Maybe ParamUsage]
ctorUsages) -> do
    [(Ident, Maybe ParamUsage)]
ctorArgs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Maybe ParamUsage]
ctorUsages forall a b. (a -> b) -> a -> b
$ \Maybe ParamUsage
usage -> forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"v" forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (, Maybe ParamUsage
usage)
    let ctor :: Expr
ctor = ModuleName -> ProperName 'ConstructorName -> Expr
mkCtor ModuleName
mn ProperName 'ConstructorName
ctorName
    let caseBinder :: Binder
caseBinder = ModuleName -> ProperName 'ConstructorName -> [Binder] -> Binder
mkCtorBinder ModuleName
mn ProperName 'ConstructorName
ctorName forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Ident -> Binder
mkBinder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Ident, Maybe ParamUsage)]
ctorArgs
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
caseBinder] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> [GuardedExpr]
unguarded) forall b c a. (b -> c) -> (a -> b) -> a -> c
. f Expr -> m Expr
extractExpr forall a b. (a -> b) -> a -> b
$
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Expr -> Expr -> Expr
App Expr
ctor) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Ident, Maybe ParamUsage)]
ctorArgs forall a b. (a -> b) -> a -> b
$ \(Ident
ident, Maybe ParamUsage
mbUsage) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (f :: * -> *) a. Applicative f => a -> f a
pure ParamUsage -> Expr -> f Expr
handleArg Maybe ParamUsage
mbUsage forall a b. (a -> b) -> a -> b
$ Ident -> Expr
mkVar Ident
ident

data TraversalOps m = forall f. Applicative f => TraversalOps
  { ()
visitExpr :: m Expr -> f Expr -- lift an expression into the applicative effect defining the traversal
  , ()
extractExpr :: f Expr -> m Expr -- resolve the applicative effect into an expression
  }

mkTraversal
  :: forall m
   . MonadSupply m
  => ModuleName
  -> Expr -- a var representing map, foldMap, or traverse, for handling structured values
  -> TraversalOps m
  -> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
  -> m Expr
mkTraversal :: forall (m :: * -> *).
MonadSupply m =>
ModuleName
-> Expr
-> TraversalOps m
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkTraversal ModuleName
mn Expr
recurseVar (TraversalOps @_ @f m Expr -> f Expr
visitExpr f Expr -> m Expr
extractExpr) [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors = do
  Ident
f <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"f"
  let
    handleValue :: ParamUsage -> Expr -> f Expr
    handleValue :: ParamUsage -> Expr -> f Expr
handleValue = forall (f :: * -> *).
Applicative f =>
(ParamUsage -> Expr -> f Expr) -> ParamUsage -> Expr -> f Expr
unnestRecords forall a b. (a -> b) -> a -> b
$ \ParamUsage
usage Expr
inputExpr -> m Expr -> f Expr
visitExpr forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip Expr -> Expr -> Expr
App Expr
inputExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamUsage -> m Expr
mkFnExprForValue ParamUsage
usage

    mkFnExprForValue :: ParamUsage -> m Expr
    mkFnExprForValue :: ParamUsage -> m Expr
mkFnExprForValue = \case
      ParamUsage
IsParam ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Ident -> Expr
mkVar Ident
f
      MentionsParam ParamUsage
innerUsage ->
        Expr -> Expr -> Expr
App Expr
recurseVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamUsage -> m Expr
mkFnExprForValue ParamUsage
innerUsage
      IsRecord NonEmpty (PSString, ParamUsage)
fields ->
        forall (m :: * -> *). MonadSupply m => (Expr -> m Expr) -> m Expr
usingLamIdent forall a b. (a -> b) -> a -> b
$ f Expr -> m Expr
extractExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Applicative f =>
(ParamUsage -> Expr -> f Expr)
-> NonEmpty (PSString, ParamUsage) -> Expr -> f Expr
traverseFields ParamUsage -> Expr -> f Expr
handleValue NonEmpty (PSString, ParamUsage)
fields

  Ident -> Expr -> Expr
lam Ident
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) (m :: * -> *).
(Applicative f, MonadSupply m) =>
ModuleName
-> (ParamUsage -> Expr -> f Expr)
-> (f Expr -> m Expr)
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkCasesForTraversal ModuleName
mn ParamUsage -> Expr -> f Expr
handleValue f Expr -> m Expr
extractExpr [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors

deriveFunctor
  :: forall m
   . MonadError MultipleErrors m
  => MonadState CheckState m
  => MonadSupply m
  => Qualified (ProperName 'ClassName)
  -> ModuleName
  -> ProperName 'TypeName
  -> m [(PSString, Expr)]
deriveFunctor :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveFunctor Qualified (ProperName 'ClassName)
nm ModuleName
mn ProperName 'TypeName
tyConNm = do
  [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
Qualified (ProperName 'ClassName)
-> ModuleName
-> ProperName 'TypeName
-> m [(ProperName 'ConstructorName, [Maybe ParamUsage])]
validateParamsInTypeConstructors Qualified (ProperName 'ClassName)
nm ModuleName
mn ProperName 'TypeName
tyConNm
  Expr
mapFun <- forall (m :: * -> *).
MonadSupply m =>
ModuleName
-> Expr
-> TraversalOps m
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkTraversal ModuleName
mn Expr
mapVar (forall (m :: * -> *) (f :: * -> *).
Applicative f =>
(m Expr -> f Expr) -> (f Expr -> m Expr) -> TraversalOps m
TraversalOps forall a. a -> a
identity forall a. a -> a
identity) [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. IsString a => a
Prelude.map, Expr
mapFun)]
  where
  mapVar :: Expr
mapVar = Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identMap

toConst :: forall f a b. f a -> Const [f a] b
toConst :: forall (f :: * -> *) a b. f a -> Const [f a] b
toConst = forall {k} a (b :: k). a -> Const a b
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

consumeConst :: forall f a b c. Applicative f => ([a] -> b) -> Const [f a] c -> f b
consumeConst :: forall (f :: * -> *) a b c.
Applicative f =>
([a] -> b) -> Const [f a] c -> f b
consumeConst [a] -> b
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} a (b :: k). Const a b -> a
getConst

applyWhen :: forall a. Bool -> (a -> a) -> a -> a
applyWhen :: forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
cond a -> a
f = if Bool
cond then a -> a
f else forall a. a -> a
identity

deriveFoldable
  :: forall m
   . MonadError MultipleErrors m
  => MonadState CheckState m
  => MonadSupply m
  => Qualified (ProperName 'ClassName)
  -> ModuleName
  -> ProperName 'TypeName
  -> m [(PSString, Expr)]
deriveFoldable :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveFoldable Qualified (ProperName 'ClassName)
nm ModuleName
mn ProperName 'TypeName
tyConNm = do
  [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
Qualified (ProperName 'ClassName)
-> ModuleName
-> ProperName 'TypeName
-> m [(ProperName 'ConstructorName, [Maybe ParamUsage])]
validateParamsInTypeConstructors Qualified (ProperName 'ClassName)
nm ModuleName
mn ProperName 'TypeName
tyConNm
  Expr
foldlFun <- Bool
-> Expr
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkAsymmetricFoldFunction Bool
False Expr
foldlVar [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors
  Expr
foldrFun <- Bool
-> Expr
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkAsymmetricFoldFunction Bool
True Expr
foldrVar [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors
  Expr
foldMapFun <- forall (m :: * -> *).
MonadSupply m =>
ModuleName
-> Expr
-> TraversalOps m
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkTraversal ModuleName
mn Expr
foldMapVar forall (m :: * -> *). Applicative m => TraversalOps m
foldMapOps [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. IsString a => a
Foldable.foldl, Expr
foldlFun), (forall a. IsString a => a
Foldable.foldr, Expr
foldrFun), (forall a. IsString a => a
Foldable.foldMap, Expr
foldMapFun)]
  where
  foldlVar :: Expr
foldlVar = Qualified Ident -> Expr
mkRef Qualified Ident
Foldable.identFoldl
  foldrVar :: Expr
foldrVar = Qualified Ident -> Expr
mkRef Qualified Ident
Foldable.identFoldr
  foldMapVar :: Expr
foldMapVar = Qualified Ident -> Expr
mkRef Qualified Ident
Foldable.identFoldMap
  flipVar :: Expr
flipVar = Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identFlip

  mkAsymmetricFoldFunction :: Bool -> Expr -> [(ProperName 'ConstructorName, [Maybe ParamUsage])] -> m Expr
  mkAsymmetricFoldFunction :: Bool
-> Expr
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkAsymmetricFoldFunction Bool
isRightFold Expr
recurseVar [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors = do
    Ident
f <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"f"
    Ident
z <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"z"
    let
      appCombiner :: (Bool, Expr) -> Expr -> Expr -> Expr
      appCombiner :: (Bool, Expr) -> Expr -> Expr -> Expr
appCombiner (Bool
isFlipped, Expr
fn) = forall a. Bool -> (a -> a) -> a -> a
applyWhen (Bool
isFlipped forall a. Eq a => a -> a -> Bool
== Bool
isRightFold) forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App Expr
fn

      mkCombinerExpr :: ParamUsage -> m Expr
      mkCombinerExpr :: ParamUsage -> m Expr
mkCombinerExpr = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ \Bool
isFlipped -> forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
isFlipped forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
App Expr
flipVar) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParamUsage -> m (Bool, Expr)
getCombiner

      handleValue :: ParamUsage -> Expr -> Const [m (Expr -> Expr)] Expr
      handleValue :: ParamUsage -> Expr -> Const [m (Expr -> Expr)] Expr
handleValue = forall (f :: * -> *).
Applicative f =>
(ParamUsage -> Expr -> f Expr) -> ParamUsage -> Expr -> f Expr
unnestRecords forall a b. (a -> b) -> a -> b
$ \ParamUsage
usage Expr
inputExpr -> forall (f :: * -> *) a b. f a -> Const [f a] b
toConst forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip (Bool, Expr) -> Expr -> Expr -> Expr
appCombiner Expr
inputExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamUsage -> m (Bool, Expr)
getCombiner ParamUsage
usage

      getCombiner :: ParamUsage -> m (Bool, Expr)
      getCombiner :: ParamUsage -> m (Bool, Expr)
getCombiner = \case
        ParamUsage
IsParam ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, Ident -> Expr
mkVar Ident
f)
        MentionsParam ParamUsage
innerUsage ->
          (Bool
isRightFold, ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App Expr
recurseVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamUsage -> m Expr
mkCombinerExpr ParamUsage
innerUsage
        IsRecord NonEmpty (PSString, ParamUsage)
fields -> do
          let foldFieldsOf :: Expr -> Const [m (Expr -> Expr)] Expr
foldFieldsOf = forall (f :: * -> *).
Applicative f =>
(ParamUsage -> Expr -> f Expr)
-> NonEmpty (PSString, ParamUsage) -> Expr -> f Expr
traverseFields ParamUsage -> Expr -> Const [m (Expr -> Expr)] Expr
handleValue NonEmpty (PSString, ParamUsage)
fields
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool
False, ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadSupply m => (Expr -> m Expr) -> m Expr
usingLamIdent forall a b. (a -> b) -> a -> b
$ \Expr
lVar ->
            forall (m :: * -> *). MonadSupply m => (Expr -> m Expr) -> m Expr
usingLamIdent forall a b. (a -> b) -> a -> b
$
              if Bool
isRightFold
              then forall a b c. (a -> b -> c) -> b -> a -> c
flip Expr -> Const [m (Expr -> Expr)] Expr -> m Expr
extractExprStartingWith forall a b. (a -> b) -> a -> b
$ Expr -> Const [m (Expr -> Expr)] Expr
foldFieldsOf Expr
lVar
              else Expr -> Const [m (Expr -> Expr)] Expr -> m Expr
extractExprStartingWith Expr
lVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Const [m (Expr -> Expr)] Expr
foldFieldsOf

      extractExprStartingWith :: Expr -> Const [m (Expr -> Expr)] Expr -> m Expr
      extractExprStartingWith :: Expr -> Const [m (Expr -> Expr)] Expr -> m Expr
extractExprStartingWith = forall (f :: * -> *) a b c.
Applicative f =>
([a] -> b) -> Const [f a] c -> f b
consumeConst forall b c a. (b -> c) -> (a -> b) -> a -> c
. if Bool
isRightFold then forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) else forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a b. a -> (a -> b) -> b
(&)

    Ident -> Expr -> Expr
lam Ident
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Expr -> Expr
lam Ident
z forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) (m :: * -> *).
(Applicative f, MonadSupply m) =>
ModuleName
-> (ParamUsage -> Expr -> f Expr)
-> (f Expr -> m Expr)
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkCasesForTraversal ModuleName
mn ParamUsage -> Expr -> Const [m (Expr -> Expr)] Expr
handleValue (Expr -> Const [m (Expr -> Expr)] Expr -> m Expr
extractExprStartingWith forall a b. (a -> b) -> a -> b
$ Ident -> Expr
mkVar Ident
z) [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors

foldMapOps :: forall m. Applicative m => TraversalOps m
foldMapOps :: forall (m :: * -> *). Applicative m => TraversalOps m
foldMapOps = TraversalOps { visitExpr :: m Expr -> Const [m Expr] Expr
visitExpr = forall (f :: * -> *) a b. f a -> Const [f a] b
toConst, Const [m Expr] Expr -> m Expr
extractExpr :: Const [m Expr] Expr -> m Expr
extractExpr :: Const [m Expr] Expr -> m Expr
.. }
  where
  appendVar :: Expr
appendVar = Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identAppend
  memptyVar :: Expr
memptyVar = Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identMempty

  extractExpr :: Const [m Expr] Expr -> m Expr
  extractExpr :: Const [m Expr] Expr -> m Expr
extractExpr = forall (f :: * -> *) a b c.
Applicative f =>
([a] -> b) -> Const [f a] c -> f b
consumeConst forall a b. (a -> b) -> a -> b
$ \case
    [] -> Expr
memptyVar
    [Expr]
exprs -> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App Expr
appendVar) [Expr]
exprs

deriveTraversable
  :: forall m
   . MonadError MultipleErrors m
  => MonadState CheckState m
  => MonadSupply m
  => Qualified (ProperName 'ClassName)
  -> ModuleName
  -> ProperName 'TypeName
  -> m [(PSString, Expr)]
deriveTraversable :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveTraversable Qualified (ProperName 'ClassName)
nm ModuleName
mn ProperName 'TypeName
tyConNm = do
  [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
Qualified (ProperName 'ClassName)
-> ModuleName
-> ProperName 'TypeName
-> m [(ProperName 'ConstructorName, [Maybe ParamUsage])]
validateParamsInTypeConstructors Qualified (ProperName 'ClassName)
nm ModuleName
mn ProperName 'TypeName
tyConNm
  Expr
traverseFun <- forall (m :: * -> *).
MonadSupply m =>
ModuleName
-> Expr
-> TraversalOps m
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkTraversal ModuleName
mn Expr
traverseVar forall (m :: * -> *). MonadSupply m => TraversalOps m
traverseOps [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors
  Expr
sequenceFun <- forall (m :: * -> *). MonadSupply m => (Expr -> m Expr) -> m Expr
usingLamIdent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App (Expr -> Expr -> Expr
App Expr
traverseVar Expr
identityVar)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. IsString a => a
Traversable.traverse, Expr
traverseFun), (forall a. IsString a => a
Traversable.sequence, Expr
sequenceFun)]
  where
  traverseVar :: Expr
traverseVar = Qualified Ident -> Expr
mkRef Qualified Ident
Traversable.identTraverse
  identityVar :: Expr
identityVar = Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identIdentity

traverseOps :: forall m. MonadSupply m => TraversalOps m
traverseOps :: forall (m :: * -> *). MonadSupply m => TraversalOps m
traverseOps = TraversalOps { m Expr -> WriterT [(Ident, m Expr)] m Expr
WriterT [(Ident, m Expr)] m Expr -> m Expr
extractExpr :: WriterT [(Ident, m Expr)] m Expr -> m Expr
visitExpr :: m Expr -> WriterT [(Ident, m Expr)] m Expr
extractExpr :: WriterT [(Ident, m Expr)] m Expr -> m Expr
visitExpr :: m Expr -> WriterT [(Ident, m Expr)] m Expr
.. }
  where
  pureVar :: Expr
pureVar = Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identPure
  mapVar :: Expr
mapVar = Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identMap
  applyVar :: Expr
applyVar = Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identApply

  visitExpr :: m Expr -> WriterT [(Ident, m Expr)] m Expr
  visitExpr :: m Expr -> WriterT [(Ident, m Expr)] m Expr
visitExpr m Expr
traversedExpr = do
    Ident
ident <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"v"
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(Ident
ident, m Expr
traversedExpr)] forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Ident -> Expr
mkVar Ident
ident

  extractExpr :: WriterT [(Ident, m Expr)] m Expr -> m Expr
  extractExpr :: WriterT [(Ident, m Expr)] m Expr -> m Expr
extractExpr = forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \(Expr
result, forall a b. [(a, b)] -> ([a], [b])
unzip -> ([Ident]
ctx, [m Expr]
args)) -> forall a b c. (a -> b -> c) -> b -> a -> c
flip [Expr] -> Expr -> Expr
mkApps (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ident -> Expr -> Expr
lam Expr
result [Ident]
ctx) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [m Expr]
args

  mkApps :: [Expr] -> Expr -> Expr
  mkApps :: [Expr] -> Expr -> Expr
mkApps = \case
    [] -> Expr -> Expr -> Expr
App Expr
pureVar
    Expr
h : [Expr]
t -> \Expr
l -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App Expr
applyVar) (Expr -> Expr -> Expr
App (Expr -> Expr -> Expr
App Expr
mapVar Expr
l) Expr
h) [Expr]
t