{- 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.Lens (both, over)
import Control.Monad.Error.Class (liftEither)
import Control.Monad.Trans.Writer (Writer, WriterT, runWriter, runWriterT)
import Control.Monad.Writer.Class (MonadWriter(..))
import Data.Align (align, unalign)
import Data.Foldable (foldl1, foldr1)
import Data.List (init, last, zipWith3, (!!))
import Data.Map qualified as M
import Data.These (These(..), mergeTheseWith, these)

import Control.Monad.Supply.Class (MonadSupply)
import Language.PureScript.AST (Binder(..), CaseAlternative(..), ErrorMessageHint(..), Expr(..), InstanceDerivationStrategy(..), Literal(..), SourceSpan, nullSourceSpan)
import Language.PureScript.AST.Utils (UnwrappedTypeConstructor(..), lam, lamCase, lamCase2, mkBinder, mkCtor, mkCtorBinder, mkLit, mkRef, mkVar, unguarded, unwrapTypeConstructor, utcQTyCon)
import Language.PureScript.Constants.Libs qualified as Libs
import Language.PureScript.Constants.Prim qualified as Prim
import Language.PureScript.Crash (internalError)
import Language.PureScript.Environment (DataDeclType(..), Environment(..), FunctionalDependency(..), TypeClassData(..), TypeKind(..), kindType, (-:>))
import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, internalCompilerError)
import Language.PureScript.Label (Label(..))
import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify)
import Language.PureScript.PSString (PSString, mkString)
import Language.PureScript.Sugar.TypeClasses (superClassDictionaryNames)
import Language.PureScript.TypeChecker.Entailment (InstanceContext, findDicts)
import Language.PureScript.TypeChecker.Monad (CheckState, getEnv, getTypeClassDictionaries, unsafeCheckCurrentModule)
import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms)
import Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..))
import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, SourceType, Type(..), completeBinderList, eqType, everythingOnTypes, replaceAllTypeVars, srcTypeVar, usedTypeVariables)

-- | 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 (forall a. ModuleName -> Qualified a -> (ModuleName, a)
qualify ModuleName
mn forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnwrappedTypeConstructor -> Qualified (ProperName 'TypeName)
utcQTyCon)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourceType -> Maybe UnwrappedTypeConstructor
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
  instUtc :: UnwrappedTypeConstructor
instUtc@UnwrappedTypeConstructor{ utcArgs :: UnwrappedTypeConstructor -> [SourceType]
utcArgs = [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 UnwrappedTypeConstructor
unwrapTypeConstructor SourceType
instType
  let ctorName :: Qualified (ProperName 'ConstructorName)
ctorName = forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnwrappedTypeConstructor -> Qualified (ProperName 'TypeName)
utcQTyCon UnwrappedTypeConstructor
instUtc

  TypeClassData{Bool
[(Text, Maybe SourceType)]
[(Ident, SourceType, Maybe (Set (NonEmpty Int)))]
[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, Maybe (Set (NonEmpty Int)))]
typeClassArguments :: TypeClassData -> [(Text, Maybe SourceType)]
typeClassIsEmpty :: Bool
typeClassCoveringSets :: Set (Set Int)
typeClassDeterminedArguments :: Set Int
typeClassDependencies :: [FunctionalDependency]
typeClassSuperclasses :: [SourceConstraint]
typeClassMembers :: [(Ident, SourceType, Maybe (Set (NonEmpty Int)))]
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 :: (UnwrappedTypeConstructor -> m [(PSString, Expr)]) -> m Expr
      unaryClass :: (UnwrappedTypeConstructor -> m [(PSString, Expr)]) -> m Expr
unaryClass UnwrappedTypeConstructor -> m [(PSString, Expr)]
f = case [SourceType]
tys of
        [SourceType
ty] -> case SourceType -> Maybe UnwrappedTypeConstructor
unwrapTypeConstructor SourceType
ty of
          Just UnwrappedTypeConstructor
utc | ModuleName
mn forall a. Eq a => a -> a -> Bool
== UnwrappedTypeConstructor -> ModuleName
utcModuleName UnwrappedTypeConstructor
utc -> 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
<$> UnwrappedTypeConstructor -> m [(PSString, Expr)]
f UnwrappedTypeConstructor
utc
          Maybe UnwrappedTypeConstructor
_ -> 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)
 -> UnwrappedTypeConstructor -> m [(PSString, Expr)])
-> m Expr
unaryClass' Qualified (ProperName 'ClassName)
-> UnwrappedTypeConstructor -> m [(PSString, Expr)]
f = (UnwrappedTypeConstructor -> m [(PSString, Expr)]) -> m Expr
unaryClass (Qualified (ProperName 'ClassName)
-> UnwrappedTypeConstructor -> m [(PSString, Expr)]
f Qualified (ProperName 'ClassName)
className)

      in case Qualified (ProperName 'ClassName)
className of
        Qualified (ProperName 'ClassName)
Libs.Bifoldable -> (Qualified (ProperName 'ClassName)
 -> UnwrappedTypeConstructor -> m [(PSString, Expr)])
-> m Expr
unaryClass' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
Bool
-> Qualified (ProperName 'ClassName)
-> UnwrappedTypeConstructor
-> m [(PSString, Expr)]
deriveFoldable Bool
True
        Qualified (ProperName 'ClassName)
Libs.Bifunctor -> (Qualified (ProperName 'ClassName)
 -> UnwrappedTypeConstructor -> m [(PSString, Expr)])
-> m Expr
unaryClass' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
Maybe Bool
-> Bool
-> PSString
-> Qualified (ProperName 'ClassName)
-> UnwrappedTypeConstructor
-> m [(PSString, Expr)]
deriveFunctor (forall a. a -> Maybe a
Just Bool
False) Bool
False forall a. (Eq a, IsString a) => a
Libs.S_bimap
        Qualified (ProperName 'ClassName)
Libs.Bitraversable -> (Qualified (ProperName 'ClassName)
 -> UnwrappedTypeConstructor -> m [(PSString, Expr)])
-> m Expr
unaryClass' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
Bool
-> Qualified (ProperName 'ClassName)
-> UnwrappedTypeConstructor
-> m [(PSString, Expr)]
deriveTraversable Bool
True
        Qualified (ProperName 'ClassName)
Libs.Contravariant -> (Qualified (ProperName 'ClassName)
 -> UnwrappedTypeConstructor -> m [(PSString, Expr)])
-> m Expr
unaryClass' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
Maybe Bool
-> Bool
-> PSString
-> Qualified (ProperName 'ClassName)
-> UnwrappedTypeConstructor
-> m [(PSString, Expr)]
deriveFunctor forall a. Maybe a
Nothing Bool
True forall a. (Eq a, IsString a) => a
Libs.S_cmap
        Qualified (ProperName 'ClassName)
Libs.Eq -> (UnwrappedTypeConstructor -> m [(PSString, Expr)]) -> m Expr
unaryClass forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
UnwrappedTypeConstructor -> m [(PSString, Expr)]
deriveEq
        Qualified (ProperName 'ClassName)
Libs.Eq1 -> (UnwrappedTypeConstructor -> m [(PSString, Expr)]) -> m Expr
unaryClass forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall (m :: * -> *). Applicative m => m [(PSString, Expr)]
deriveEq1
        Qualified (ProperName 'ClassName)
Libs.Foldable -> (Qualified (ProperName 'ClassName)
 -> UnwrappedTypeConstructor -> m [(PSString, Expr)])
-> m Expr
unaryClass' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
Bool
-> Qualified (ProperName 'ClassName)
-> UnwrappedTypeConstructor
-> m [(PSString, Expr)]
deriveFoldable Bool
False
        Qualified (ProperName 'ClassName)
Libs.Functor -> (Qualified (ProperName 'ClassName)
 -> UnwrappedTypeConstructor -> m [(PSString, Expr)])
-> m Expr
unaryClass' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
Maybe Bool
-> Bool
-> PSString
-> Qualified (ProperName 'ClassName)
-> UnwrappedTypeConstructor
-> m [(PSString, Expr)]
deriveFunctor forall a. Maybe a
Nothing Bool
False forall a. (Eq a, IsString a) => a
Libs.S_map
        Qualified (ProperName 'ClassName)
Libs.Ord -> (UnwrappedTypeConstructor -> m [(PSString, Expr)]) -> m Expr
unaryClass forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
UnwrappedTypeConstructor -> m [(PSString, Expr)]
deriveOrd
        Qualified (ProperName 'ClassName)
Libs.Ord1 -> (UnwrappedTypeConstructor -> m [(PSString, Expr)]) -> m Expr
unaryClass forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall (m :: * -> *). Applicative m => m [(PSString, Expr)]
deriveOrd1
        Qualified (ProperName 'ClassName)
Libs.Profunctor -> (Qualified (ProperName 'ClassName)
 -> UnwrappedTypeConstructor -> m [(PSString, Expr)])
-> m Expr
unaryClass' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
Maybe Bool
-> Bool
-> PSString
-> Qualified (ProperName 'ClassName)
-> UnwrappedTypeConstructor
-> m [(PSString, Expr)]
deriveFunctor (forall a. a -> Maybe a
Just Bool
True) Bool
False forall a. (Eq a, IsString a) => a
Libs.S_dimap
        Qualified (ProperName 'ClassName)
Libs.Traversable -> (Qualified (ProperName 'ClassName)
 -> UnwrappedTypeConstructor -> m [(PSString, Expr)])
-> m Expr
unaryClass' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
Bool
-> Qualified (ProperName 'ClassName)
-> UnwrappedTypeConstructor
-> m [(PSString, Expr)]
deriveTraversable Bool
False
        -- 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 UnwrappedTypeConstructor
utc <- SourceType -> Maybe UnwrappedTypeConstructor
unwrapTypeConstructor (forall a. [a] -> a
last [SourceType]
tys)
              , ModuleName
mn forall a. Eq a => a -> a -> Bool
== UnwrappedTypeConstructor -> ModuleName
utcModuleName UnwrappedTypeConstructor
utc
              -> forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadWriter MultipleErrors m) =>
Qualified (ProperName 'ClassName)
-> [SourceType] -> UnwrappedTypeConstructor -> m Expr
deriveNewtypeInstance Qualified (ProperName 'ClassName)
className [SourceType]
tys UnwrappedTypeConstructor
utc
              | 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
  => MonadWriter MultipleErrors m
  => Qualified (ProperName 'ClassName)
  -> [SourceType]
  -> UnwrappedTypeConstructor
  -> m Expr
deriveNewtypeInstance :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadWriter MultipleErrors m) =>
Qualified (ProperName 'ClassName)
-> [SourceType] -> UnwrappedTypeConstructor -> m Expr
deriveNewtypeInstance Qualified (ProperName 'ClassName)
className [SourceType]
tys (UnwrappedTypeConstructor ModuleName
mn 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

data TypeInfo = TypeInfo
  { TypeInfo -> [Text]
tiTypeParams :: [Text]
  , TypeInfo -> [(ProperName 'ConstructorName, [SourceType])]
tiCtors :: [(ProperName 'ConstructorName, [SourceType])]
  , TypeInfo -> [(Text, SourceType)]
tiArgSubst :: [(Text, SourceType)]
  }

lookupTypeInfo
  :: forall m
   . MonadError MultipleErrors m
  => MonadState CheckState m
  => UnwrappedTypeConstructor
  -> m TypeInfo
lookupTypeInfo :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
UnwrappedTypeConstructor -> m TypeInfo
lookupTypeInfo UnwrappedTypeConstructor{[SourceType]
ModuleName
ProperName 'TypeName
utcKindArgs :: UnwrappedTypeConstructor -> [SourceType]
utcTyCon :: UnwrappedTypeConstructor -> ProperName 'TypeName
utcArgs :: [SourceType]
utcKindArgs :: [SourceType]
utcTyCon :: ProperName 'TypeName
utcModuleName :: ModuleName
utcModuleName :: UnwrappedTypeConstructor -> ModuleName
utcArgs :: UnwrappedTypeConstructor -> [SourceType]
..} = do
  (Maybe DataDeclType
_, [Text]
kindParams, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. (a, b) -> a
fst -> [Text]
tiTypeParams, [(ProperName 'ConstructorName, [SourceType])]
tiCtors) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> ProperName 'TypeName
-> m (Maybe DataDeclType, [Text], [(Text, Maybe SourceType)],
      [(ProperName 'ConstructorName, [SourceType])])
lookupTypeDecl ModuleName
utcModuleName ProperName 'TypeName
utcTyCon
  let tiArgSubst :: [(Text, SourceType)]
tiArgSubst = forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
tiTypeParams [SourceType]
utcArgs forall a. Semigroup a => a -> a -> a
<> forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
kindParams [SourceType]
utcKindArgs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeInfo{[(Text, SourceType)]
[(ProperName 'ConstructorName, [SourceType])]
[Text]
tiArgSubst :: [(Text, SourceType)]
tiCtors :: [(ProperName 'ConstructorName, [SourceType])]
tiTypeParams :: [Text]
tiArgSubst :: [(Text, SourceType)]
tiCtors :: [(ProperName 'ConstructorName, [SourceType])]
tiTypeParams :: [Text]
..}

deriveEq
  :: forall m
   . MonadError MultipleErrors m
  => MonadState CheckState m
  => MonadSupply m
  => UnwrappedTypeConstructor
  -> m [(PSString, Expr)]
deriveEq :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
UnwrappedTypeConstructor -> m [(PSString, Expr)]
deriveEq UnwrappedTypeConstructor
utc = do
  TypeInfo{[(Text, SourceType)]
[(ProperName 'ConstructorName, [SourceType])]
[Text]
tiArgSubst :: [(Text, SourceType)]
tiCtors :: [(ProperName 'ConstructorName, [SourceType])]
tiTypeParams :: [Text]
tiArgSubst :: TypeInfo -> [(Text, SourceType)]
tiCtors :: TypeInfo -> [(ProperName 'ConstructorName, [SourceType])]
tiTypeParams :: TypeInfo -> [Text]
..} <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
UnwrappedTypeConstructor -> m TypeInfo
lookupTypeInfo UnwrappedTypeConstructor
utc
  Expr
eqFun <- [(ProperName 'ConstructorName, [SourceType])] -> m Expr
mkEqFunction [(ProperName 'ConstructorName, [SourceType])]
tiCtors
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. (Eq a, IsString a) => a
Libs.S_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 (Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_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
Libs.I_eq)

    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
Libs.I_eq1)

    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 (UnwrappedTypeConstructor -> ModuleName
utcModuleName UnwrappedTypeConstructor
utc) 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. (Eq a, IsString a) => a
Libs.S_eq1, Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_eq)]

deriveOrd
  :: forall m
   . MonadError MultipleErrors m
  => MonadState CheckState m
  => MonadSupply m
  => UnwrappedTypeConstructor
  -> m [(PSString, Expr)]
deriveOrd :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
UnwrappedTypeConstructor -> m [(PSString, Expr)]
deriveOrd UnwrappedTypeConstructor
utc = do
  TypeInfo{[(Text, SourceType)]
[(ProperName 'ConstructorName, [SourceType])]
[Text]
tiArgSubst :: [(Text, SourceType)]
tiCtors :: [(ProperName 'ConstructorName, [SourceType])]
tiTypeParams :: [Text]
tiArgSubst :: TypeInfo -> [(Text, SourceType)]
tiCtors :: TypeInfo -> [(ProperName 'ConstructorName, [SourceType])]
tiTypeParams :: TypeInfo -> [Text]
..} <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
UnwrappedTypeConstructor -> m TypeInfo
lookupTypeInfo UnwrappedTypeConstructor
utc
  Expr
compareFun <- [(ProperName 'ConstructorName, [SourceType])] -> m Expr
mkCompareFunction [(ProperName 'ConstructorName, [SourceType])]
tiCtors
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. (Eq a, IsString a) => a
Libs.S_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
Libs.I_compare)

    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
Libs.I_compare1)

    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
      mn :: ModuleName
mn = UnwrappedTypeConstructor -> ModuleName
utcModuleName UnwrappedTypeConstructor
utc
      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. (Eq a, IsString a) => a
Libs.S_compare1, Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_compare)]

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
_ = []

-- | The parameter `c` is used to allow or forbid contravariance for different
-- type classes. When deriving a type class that is a variation on Functor, a
-- witness for `c` will be provided; when deriving a type class that is a
-- variation on Foldable or Traversable, `c` will be Void and the contravariant
-- ParamUsage constructor can be skipped in pattern matching.
data ParamUsage c
  = IsParam
  | IsLParam
    -- ^ enables biparametric classes (of any variance) to be derived
  | MentionsParam (ParamUsage c)
    -- ^ enables monoparametric classes to be used in a derivation
  | MentionsParamBi (These (ParamUsage c) (ParamUsage c))
    -- ^ enables biparametric classes to be used in a derivation
  | MentionsParamContravariantly !c (ContravariantParamUsage c)
    -- ^ enables contravariant classes (of either parametricity) to be used in a derivation
  | IsRecord (NonEmpty (PSString, ParamUsage c))

data ContravariantParamUsage c
  = MentionsParamContra (ParamUsage c)
    -- ^ enables Contravariant to be used in a derivation
  | MentionsParamPro (These (ParamUsage c) (ParamUsage c))
    -- ^ enables Profunctor to be used in a derivation

data CovariantClasses = CovariantClasses
  { CovariantClasses -> Qualified (ProperName 'ClassName)
monoClass :: Qualified (ProperName 'ClassName)
  , CovariantClasses -> Qualified (ProperName 'ClassName)
biClass :: Qualified (ProperName 'ClassName)
  }

data ContravariantClasses = ContravariantClasses
  { ContravariantClasses -> Qualified (ProperName 'ClassName)
contraClass :: Qualified (ProperName 'ClassName)
  , ContravariantClasses -> Qualified (ProperName 'ClassName)
proClass :: Qualified (ProperName 'ClassName)
  }

data ContravarianceSupport c = ContravarianceSupport
  { forall c. ContravarianceSupport c -> c
contravarianceWitness :: c
  , forall c. ContravarianceSupport c -> Bool
paramIsContravariant :: Bool
  , forall c. ContravarianceSupport c -> Bool
lparamIsContravariant :: Bool
  , forall c. ContravarianceSupport c -> ContravariantClasses
contravariantClasses :: ContravariantClasses
  }

-- | Return, if possible, a These the contents of which each satisfy the
-- predicate.
filterThese :: forall a. (a -> Bool) -> These a a -> Maybe (These a a)
filterThese :: forall a. (a -> Bool) -> These a a -> Maybe (These a a)
filterThese a -> Bool
p = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (f :: * -> *) a b.
Semialign f =>
f a -> f b -> f (These a b)
align forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both (forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter a -> Bool
p) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Unalign f => f (These a b) -> (f a, f b)
unalign forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just

validateParamsInTypeConstructors
  :: forall c m
   . MonadError MultipleErrors m
  => MonadState CheckState m
  => Qualified (ProperName 'ClassName)
  -> UnwrappedTypeConstructor
  -> Bool
  -> CovariantClasses
  -> Maybe (ContravarianceSupport c)
  -> m [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])]
validateParamsInTypeConstructors :: forall c (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
Qualified (ProperName 'ClassName)
-> UnwrappedTypeConstructor
-> Bool
-> CovariantClasses
-> Maybe (ContravarianceSupport c)
-> m [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])]
validateParamsInTypeConstructors Qualified (ProperName 'ClassName)
derivingClass UnwrappedTypeConstructor
utc Bool
isBi CovariantClasses{Qualified (ProperName 'ClassName)
biClass :: Qualified (ProperName 'ClassName)
monoClass :: Qualified (ProperName 'ClassName)
biClass :: CovariantClasses -> Qualified (ProperName 'ClassName)
monoClass :: CovariantClasses -> Qualified (ProperName 'ClassName)
..} Maybe (ContravarianceSupport c)
contravarianceSupport = do
  TypeInfo{[(Text, SourceType)]
[(ProperName 'ConstructorName, [SourceType])]
[Text]
tiArgSubst :: [(Text, SourceType)]
tiCtors :: [(ProperName 'ConstructorName, [SourceType])]
tiTypeParams :: [Text]
tiArgSubst :: TypeInfo -> [(Text, SourceType)]
tiCtors :: TypeInfo -> [(ProperName 'ConstructorName, [SourceType])]
tiTypeParams :: TypeInfo -> [Text]
..} <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
UnwrappedTypeConstructor -> m TypeInfo
lookupTypeInfo UnwrappedTypeConstructor
utc
  (Maybe Text
mbLParam, Text
param) <- forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (SimpleErrorMessage -> MultipleErrors
errorMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip SourceType -> SourceType -> SimpleErrorMessage
KindsDoNotUnify SourceType
kindType forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourceType
kindType SourceType -> SourceType -> SourceType
-:>)) forall a b. (a -> b) -> a -> b
$
    case (Bool
isBi, forall a. [a] -> [a]
reverse [Text]
tiTypeParams) of
      (Bool
False, Text
x : [Text]
_)    -> forall a b. b -> Either a b
Right (forall a. Maybe a
Nothing, Text
x)
      (Bool
False, [Text]
_)        -> forall a b. a -> Either a b
Left SourceType
kindType
      (Bool
True, Text
y : Text
x : [Text]
_) -> forall a b. b -> Either a b
Right (forall a. a -> Maybe a
Just Text
x, Text
y)
      (Bool
True, Text
_ : [Text]
_)     -> forall a b. a -> Either a b
Left SourceType
kindType
      (Bool
True, [Text]
_)         -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ SourceType
kindType SourceType -> SourceType -> SourceType
-:> SourceType
kindType
  [(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])]
tiCtors
  Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
tcds <- forall (m :: * -> *).
MonadState CheckState m =>
m (Map
     QualifiedBy
     (Map
        (Qualified (ProperName 'ClassName))
        (Map (Qualified Ident) (NonEmpty NamedDict))))
getTypeClassDictionaries
  let ([(ProperName 'ConstructorName, [Maybe (ParamUsage c)])]
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
$ Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
-> [(Text, SourceType)]
-> These Text Text
-> Bool
-> SourceType
-> Writer [SourceSpan] (Maybe (ParamUsage c))
typeToUsageOf Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
tcds [(Text, SourceType)]
tiArgSubst (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a b. b -> These a b
That forall a b. a -> b -> These a b
These Maybe Text
mbLParam Text
param) Bool
False) [(ProperName 'ConstructorName, [SourceType])]
ctors
  let relatedClasses :: [Qualified (ProperName 'ClassName)]
relatedClasses = [Qualified (ProperName 'ClassName)
monoClass, Qualified (ProperName 'ClassName)
biClass] forall a. [a] -> [a] -> [a]
++ ([ContravariantClasses -> Qualified (ProperName 'ClassName)
contraClass, ContravariantClasses -> Qualified (ProperName 'ClassName)
proClass] forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall c. ContravarianceSupport c -> ContravariantClasses
contravariantClasses forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe (ContravarianceSupport c)
contravarianceSupport))
  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)
-> [Qualified (ProperName 'ClassName)]
-> Bool
-> SimpleErrorMessage
CannotDeriveInvalidConstructorArg Qualified (ProperName 'ClassName)
derivingClass [Qualified (ProperName 'ClassName)]
relatedClasses (forall a. Maybe a -> Bool
isJust Maybe (ContravarianceSupport c)
contravarianceSupport)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])]
ctorUsages

  where
  typeToUsageOf :: InstanceContext -> [(Text, SourceType)] -> These Text Text -> Bool -> SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c))
  typeToUsageOf :: Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
-> [(Text, SourceType)]
-> These Text Text
-> Bool
-> SourceType
-> Writer [SourceSpan] (Maybe (ParamUsage c))
typeToUsageOf Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
tcds [(Text, SourceType)]
subst = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \These Text Text
-> Bool -> SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c))
go These Text Text
params Bool
isNegative -> let
    goCo :: SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c))
goCo = These Text Text
-> Bool -> SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c))
go These Text Text
params Bool
isNegative
    goContra :: SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c))
goContra = These Text Text
-> Bool -> SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c))
go These Text Text
params forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
isNegative

    assertNoParamUsedIn :: SourceType -> Writer [SourceSpan] ()
    assertNoParamUsedIn :: SourceType -> Writer [SourceSpan] ()
assertNoParamUsedIn SourceType
ty = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both (forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> SourceType -> Writer [SourceSpan] ()
assertParamNotUsedIn SourceType
ty) These Text Text
params

    assertParamNotUsedIn :: Text -> SourceType -> Writer [SourceSpan] ()
    assertParamNotUsedIn :: Text -> SourceType -> Writer [SourceSpan] ()
assertParamNotUsedIn Text
param = 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 ()

    tryBiClasses :: Qualified (Either Text (ProperName 'TypeName))
-> SourceType
-> SourceType
-> Writer [SourceSpan] (Maybe (ParamUsage c))
tryBiClasses Qualified (Either Text (ProperName 'TypeName))
ht SourceType
tyLArg SourceType
tyArg
      | Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
-> Qualified (Either Text (ProperName 'TypeName))
-> Qualified (ProperName 'ClassName)
-> Bool
hasInstance Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
tcds Qualified (Either Text (ProperName 'TypeName))
ht Qualified (ProperName 'ClassName)
biClass
        = SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c))
goCo SourceType
tyLArg forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (These (ParamUsage c) (ParamUsage c) -> ParamUsage c)
-> Maybe (ParamUsage c)
-> Writer [SourceSpan] (Maybe (ParamUsage c))
preferMonoClass forall c. These (ParamUsage c) (ParamUsage c) -> ParamUsage c
MentionsParamBi
      | Just (ContravarianceSupport c
c Bool
_ Bool
_ ContravariantClasses{Qualified (ProperName 'ClassName)
proClass :: Qualified (ProperName 'ClassName)
contraClass :: Qualified (ProperName 'ClassName)
proClass :: ContravariantClasses -> Qualified (ProperName 'ClassName)
contraClass :: ContravariantClasses -> Qualified (ProperName 'ClassName)
..}) <- Maybe (ContravarianceSupport c)
contravarianceSupport, Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
-> Qualified (Either Text (ProperName 'TypeName))
-> Qualified (ProperName 'ClassName)
-> Bool
hasInstance Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
tcds Qualified (Either Text (ProperName 'TypeName))
ht Qualified (ProperName 'ClassName)
proClass
        = SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c))
goContra SourceType
tyLArg forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (These (ParamUsage c) (ParamUsage c) -> ParamUsage c)
-> Maybe (ParamUsage c)
-> Writer [SourceSpan] (Maybe (ParamUsage c))
preferMonoClass (forall c. c -> ContravariantParamUsage c -> ParamUsage c
MentionsParamContravariantly c
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c.
These (ParamUsage c) (ParamUsage c) -> ContravariantParamUsage c
MentionsParamPro)
      | Bool
otherwise
        = SourceType -> Writer [SourceSpan] ()
assertNoParamUsedIn SourceType
tyLArg forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Qualified (Either Text (ProperName 'TypeName))
-> SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c))
tryMonoClasses Qualified (Either Text (ProperName 'TypeName))
ht SourceType
tyArg
      where
      preferMonoClass :: (These (ParamUsage c) (ParamUsage c) -> ParamUsage c)
-> Maybe (ParamUsage c)
-> Writer [SourceSpan] (Maybe (ParamUsage c))
preferMonoClass These (ParamUsage c) (ParamUsage c) -> ParamUsage c
f Maybe (ParamUsage c)
lUsage =
        (if forall a. Maybe a -> Bool
isNothing Maybe (ParamUsage c)
lUsage Bool -> Bool -> Bool
&& Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
-> Qualified (Either Text (ProperName 'TypeName))
-> Qualified (ProperName 'ClassName)
-> Bool
hasInstance Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
tcds Qualified (Either Text (ProperName 'TypeName))
ht Qualified (ProperName 'ClassName)
monoClass then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall c. ParamUsage c -> ParamUsage c
MentionsParam else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap These (ParamUsage c) (ParamUsage c) -> ParamUsage c
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b.
Semialign f =>
f a -> f b -> f (These a b)
align Maybe (ParamUsage c)
lUsage) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c))
goCo SourceType
tyArg

    tryMonoClasses :: Qualified (Either Text (ProperName 'TypeName))
-> SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c))
tryMonoClasses Qualified (Either Text (ProperName 'TypeName))
ht SourceType
tyArg
      | Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
-> Qualified (Either Text (ProperName 'TypeName))
-> Qualified (ProperName 'ClassName)
-> Bool
hasInstance Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
tcds Qualified (Either Text (ProperName 'TypeName))
ht Qualified (ProperName 'ClassName)
monoClass
        = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall c. ParamUsage c -> ParamUsage c
MentionsParam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c))
goCo SourceType
tyArg
      | Just (ContravarianceSupport c
c Bool
_ Bool
_ ContravariantClasses{Qualified (ProperName 'ClassName)
proClass :: Qualified (ProperName 'ClassName)
contraClass :: Qualified (ProperName 'ClassName)
proClass :: ContravariantClasses -> Qualified (ProperName 'ClassName)
contraClass :: ContravariantClasses -> Qualified (ProperName 'ClassName)
..}) <- Maybe (ContravarianceSupport c)
contravarianceSupport, Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
-> Qualified (Either Text (ProperName 'TypeName))
-> Qualified (ProperName 'ClassName)
-> Bool
hasInstance Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
tcds Qualified (Either Text (ProperName 'TypeName))
ht Qualified (ProperName 'ClassName)
contraClass
        = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall c. c -> ContravariantParamUsage c -> ParamUsage c
MentionsParamContravariantly c
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. ParamUsage c -> ContravariantParamUsage c
MentionsParamContra) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c))
goContra SourceType
tyArg
      | Bool
otherwise
        = SourceType -> Writer [SourceSpan] ()
assertNoParamUsedIn SourceType
tyArg forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. Maybe a
Nothing

    headOfTypeWithSubst :: SourceType -> Qualified (Either Text (ProperName 'TypeName))
    headOfTypeWithSubst :: SourceType -> Qualified (Either Text (ProperName 'TypeName))
headOfTypeWithSubst = SourceType -> Qualified (Either Text (ProperName 'TypeName))
headOfType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(Text, Type a)] -> Type a -> Type a
replaceAllTypeVars [(Text, SourceType)]
subst

    in \case
      ForAll SourceAnn
_ TypeVarVisibility
_ Text
name Maybe SourceType
_ SourceType
ty Maybe SkolemScope
_ ->
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join 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 (\These Text Text
params' -> These Text Text
-> Bool -> SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c))
go These Text Text
params' Bool
isNegative SourceType
ty) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> These a a -> Maybe (These a a)
filterThese (forall a. Eq a => a -> a -> Bool
/= Text
name) These Text Text
params

      ConstrainedType SourceAnn
_ SourceConstraint
_ SourceType
ty ->
        SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c))
goCo 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 forall c. NonEmpty (PSString, ParamUsage c) -> ParamUsage c
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 c))
goCo SourceType
ty

      TypeApp SourceAnn
_ (TypeApp SourceAnn
_ SourceType
tyFn SourceType
tyLArg) SourceType
tyArg ->
        SourceType -> Writer [SourceSpan] ()
assertNoParamUsedIn SourceType
tyFn forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Qualified (Either Text (ProperName 'TypeName))
-> SourceType
-> SourceType
-> Writer [SourceSpan] (Maybe (ParamUsage c))
tryBiClasses (SourceType -> Qualified (Either Text (ProperName 'TypeName))
headOfTypeWithSubst SourceType
tyFn) SourceType
tyLArg SourceType
tyArg

      TypeApp SourceAnn
_ SourceType
tyFn SourceType
tyArg ->
        SourceType -> Writer [SourceSpan] ()
assertNoParamUsedIn SourceType
tyFn forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Qualified (Either Text (ProperName 'TypeName))
-> SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c))
tryMonoClasses (SourceType -> Qualified (Either Text (ProperName 'TypeName))
headOfTypeWithSubst SourceType
tyFn) SourceType
tyArg

      TypeVar (SourceSpan
ss, [Comment]
_) Text
name -> forall a c b.
(a -> c) -> (b -> c) -> (c -> c -> c) -> These a b -> c
mergeTheseWith (Bool
-> ParamUsage c
-> Text
-> Writer [SourceSpan] (Maybe (ParamUsage c))
checkName Bool
lparamIsContra forall c. ParamUsage c
IsLParam) (Bool
-> ParamUsage c
-> Text
-> Writer [SourceSpan] (Maybe (ParamUsage c))
checkName Bool
paramIsContra forall c. ParamUsage c
IsParam) (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)) These Text Text
params
        where
        checkName :: Bool
-> ParamUsage c
-> Text
-> Writer [SourceSpan] (Maybe (ParamUsage c))
checkName Bool
thisParamIsContra ParamUsage c
usage Text
param
          | Text
name forall a. Eq a => a -> a -> Bool
== Text
param = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
thisParamIsContra forall a. Eq a => a -> a -> Bool
/= Bool
isNegative) (forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [SourceSpan
ss]) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. a -> Maybe a
Just ParamUsage c
usage
          | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

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

  paramIsContra :: Bool
paramIsContra = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall c. ContravarianceSupport c -> Bool
paramIsContravariant Maybe (ContravarianceSupport c)
contravarianceSupport
  lparamIsContra :: Bool
lparamIsContra = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall c. ContravarianceSupport c -> Bool
lparamIsContravariant Maybe (ContravarianceSupport c)
contravarianceSupport

  hasInstance :: InstanceContext -> Qualified (Either Text (ProperName 'TypeName)) -> Qualified (ProperName 'ClassName) -> Bool
  hasInstance :: Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
-> Qualified (Either Text (ProperName 'TypeName))
-> Qualified (ProperName 'ClassName)
-> Bool
hasInstance Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
tcds ht :: Qualified (Either Text (ProperName 'TypeName))
ht@(Qualified QualifiedBy
qb Either Text (ProperName 'TypeName)
_) cn :: Qualified (ProperName 'ClassName)
cn@(Qualified QualifiedBy
cqb ProperName 'ClassName
_) =
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TypeClassDictionaryInScope Evidence -> Bool
tcdAppliesToType forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
-> Qualified (ProperName 'ClassName)
-> QualifiedBy
-> [TypeClassDictionaryInScope Evidence]
findDicts Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
tcds Qualified (ProperName 'ClassName)
cn) (forall a. Ord a => [a] -> [a]
ordNub [QualifiedBy
ByNullSourcePos, QualifiedBy
cqb, QualifiedBy
qb])
    where
    tcdAppliesToType :: TypeClassDictionaryInScope Evidence -> Bool
tcdAppliesToType TypeClassDictionaryInScope Evidence
tcd = case forall v. TypeClassDictionaryInScope v -> [SourceType]
tcdInstanceTypes TypeClassDictionaryInScope Evidence
tcd of
      [SourceType -> Qualified (Either Text (ProperName 'TypeName))
headOfType -> Qualified (Either Text (ProperName 'TypeName))
ht'] -> Qualified (Either Text (ProperName 'TypeName))
ht forall a. Eq a => a -> a -> Bool
== Qualified (Either Text (ProperName 'TypeName))
ht'
        -- It's possible that, if ht and ht' are Lefts, this might require
        -- verifying that the name isn't shadowed by something in tcdForAll. I
        -- can't devise a legal program that causes this issue, but if in the
        -- future it seems like a good idea, it probably is.
      [SourceType]
_ -> Bool
False

  headOfType :: SourceType -> Qualified (Either Text (ProperName 'TypeName))
  headOfType :: SourceType -> Qualified (Either Text (ProperName 'TypeName))
headOfType = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \SourceType -> Qualified (Either Text (ProperName 'TypeName))
go -> \case
    TypeApp SourceAnn
_ SourceType
ty SourceType
_ -> SourceType -> Qualified (Either Text (ProperName 'TypeName))
go SourceType
ty
    KindApp SourceAnn
_ SourceType
ty SourceType
_ -> SourceType -> Qualified (Either Text (ProperName 'TypeName))
go SourceType
ty
    TypeVar SourceAnn
_ Text
nm -> forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos (forall a b. a -> Either a b
Left Text
nm)
    Skolem SourceAnn
_ Text
nm Maybe SourceType
_ Int
_ SkolemScope
_ -> forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos (forall a b. a -> Either a b
Left Text
nm)
    TypeConstructor SourceAnn
_ (Qualified QualifiedBy
qb ProperName 'TypeName
nm) -> forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
qb (forall a b. b -> Either a b
Right ProperName 'TypeName
nm)
    SourceType
ty -> forall a. HasCallStack => String -> a
internalError forall a b. (a -> b) -> a -> b
$ String
"headOfType missing a case: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show (forall (f :: * -> *) a. Functor f => f a -> f ()
void SourceType
ty)

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 c f. Applicative f => (ParamUsage c -> Expr -> f Expr) -> NonEmpty (PSString, ParamUsage c) -> Expr -> f Expr
traverseFields :: forall c (f :: * -> *).
Applicative f =>
(ParamUsage c -> Expr -> f Expr)
-> NonEmpty (PSString, ParamUsage c) -> Expr -> f Expr
traverseFields ParamUsage c -> Expr -> f Expr
f NonEmpty (PSString, ParamUsage c)
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 c)
fields) forall a b. (a -> b) -> a -> b
$ \(PSString
lbl, ParamUsage c
usage) -> (PSString
lbl, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamUsage c -> Expr -> f Expr
f ParamUsage c
usage (PSString -> Expr -> Expr
Accessor PSString
lbl Expr
r)

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

mkCasesForTraversal
  :: forall c f m
   . Applicative f -- this effect distinguishes the semantics of maps, folds, and traversals
  => MonadSupply m
  => ModuleName
  -> (ParamUsage c -> Expr -> f Expr) -- how to handle constructor arguments
  -> (f Expr -> m Expr) -- resolve the applicative effect into an expression
  -> [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])]
  -> m Expr
mkCasesForTraversal :: forall c (f :: * -> *) (m :: * -> *).
(Applicative f, MonadSupply m) =>
ModuleName
-> (ParamUsage c -> Expr -> f Expr)
-> (f Expr -> m Expr)
-> [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])]
-> m Expr
mkCasesForTraversal ModuleName
mn ParamUsage c -> Expr -> f Expr
handleArg f Expr -> m Expr
extractExpr [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])]
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 c)])]
ctors forall a b. (a -> b) -> a -> b
$ \(ProperName 'ConstructorName
ctorName, [Maybe (ParamUsage c)]
ctorUsages) -> do
    [(Ident, Maybe (ParamUsage c))]
ctorArgs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Maybe (ParamUsage c)]
ctorUsages forall a b. (a -> b) -> a -> b
$ \Maybe (ParamUsage c)
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 c)
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 c))]
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 c))]
ctorArgs forall a b. (a -> b) -> a -> b
$ \(Ident
ident, Maybe (ParamUsage c)
mbUsage) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (f :: * -> *) a. Applicative f => a -> f a
pure ParamUsage c -> Expr -> f Expr
handleArg Maybe (ParamUsage c)
mbUsage forall a b. (a -> b) -> a -> b
$ Ident -> Expr
mkVar Ident
ident

data TraversalExprs = TraversalExprs
  { TraversalExprs -> Expr
recurseVar :: Expr -- a var representing map, foldMap, or traverse, for handling structured values
  , TraversalExprs -> Expr
birecurseVar :: Expr -- same, but bimap, bifoldMap, or bitraverse
  , TraversalExprs -> Expr
lrecurseExpr :: Expr -- same, but lmap or ltraverse (there is no lfoldMap, but we can use `flip bifoldMap mempty`)
  , TraversalExprs -> Expr
rrecurseExpr :: Expr -- same, but rmap or rtraverse etc., which conceptually should be the same as recurseVar but the bi classes aren't subclasses of the mono classes
  }

data ContraversalExprs = ContraversalExprs
  { ContraversalExprs -> Expr
crecurseVar :: Expr
  , ContraversalExprs -> Expr
direcurseVar :: Expr
  , ContraversalExprs -> Expr
lcrecurseVar :: Expr
  , ContraversalExprs -> Expr
rprorecurseVar :: Expr
  }

appBirecurseExprs :: TraversalExprs -> These Expr Expr -> Expr
appBirecurseExprs :: TraversalExprs -> These Expr Expr -> Expr
appBirecurseExprs TraversalExprs{Expr
rrecurseExpr :: Expr
lrecurseExpr :: Expr
birecurseVar :: Expr
recurseVar :: Expr
rrecurseExpr :: TraversalExprs -> Expr
lrecurseExpr :: TraversalExprs -> Expr
birecurseVar :: TraversalExprs -> Expr
recurseVar :: TraversalExprs -> Expr
..} = forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these (Expr -> Expr -> Expr
App Expr
lrecurseExpr) (Expr -> Expr -> Expr
App Expr
rrecurseExpr) (Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App Expr
birecurseVar)

appDirecurseExprs :: ContraversalExprs -> These Expr Expr -> Expr
appDirecurseExprs :: ContraversalExprs -> These Expr Expr -> Expr
appDirecurseExprs ContraversalExprs{Expr
rprorecurseVar :: Expr
lcrecurseVar :: Expr
direcurseVar :: Expr
crecurseVar :: Expr
rprorecurseVar :: ContraversalExprs -> Expr
lcrecurseVar :: ContraversalExprs -> Expr
direcurseVar :: ContraversalExprs -> Expr
crecurseVar :: ContraversalExprs -> Expr
..} = forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these (Expr -> Expr -> Expr
App Expr
lcrecurseVar) (Expr -> Expr -> Expr
App Expr
rprorecurseVar) (Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App Expr
direcurseVar)

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 c m
   . MonadSupply m
  => ModuleName
  -> Bool
  -> TraversalExprs
  -> (c -> ContraversalExprs)
  -> TraversalOps m
  -> [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])]
  -> m Expr
mkTraversal :: forall c (m :: * -> *).
MonadSupply m =>
ModuleName
-> Bool
-> TraversalExprs
-> (c -> ContraversalExprs)
-> TraversalOps m
-> [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])]
-> m Expr
mkTraversal ModuleName
mn Bool
isBi te :: TraversalExprs
te@TraversalExprs{Expr
rrecurseExpr :: Expr
lrecurseExpr :: Expr
birecurseVar :: Expr
recurseVar :: Expr
rrecurseExpr :: TraversalExprs -> Expr
lrecurseExpr :: TraversalExprs -> Expr
birecurseVar :: TraversalExprs -> Expr
recurseVar :: TraversalExprs -> Expr
..} c -> ContraversalExprs
getContraversalExprs (TraversalOps @_ @f m Expr -> f Expr
visitExpr f Expr -> m Expr
extractExpr) [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])]
ctors = do
  Ident
f <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"f"
  Ident
g <- if Bool
isBi then forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"g" else forall (f :: * -> *) a. Applicative f => a -> f a
pure Ident
f
  let
    handleValue :: ParamUsage c -> Expr -> f Expr
    handleValue :: ParamUsage c -> Expr -> f Expr
handleValue = forall c (f :: * -> *).
Applicative f =>
(ParamUsage c -> Expr -> f Expr) -> ParamUsage c -> Expr -> f Expr
unnestRecords forall a b. (a -> b) -> a -> b
$ \ParamUsage c
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 c -> m Expr
mkFnExprForValue ParamUsage c
usage

    mkFnExprForValue :: ParamUsage c -> m Expr
    mkFnExprForValue :: ParamUsage c -> m Expr
mkFnExprForValue = \case
      ParamUsage c
IsParam ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Ident -> Expr
mkVar Ident
g
      ParamUsage c
IsLParam ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Ident -> Expr
mkVar Ident
f
      MentionsParam ParamUsage c
innerUsage ->
        Expr -> Expr -> Expr
App Expr
recurseVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamUsage c -> m Expr
mkFnExprForValue ParamUsage c
innerUsage
      MentionsParamBi These (ParamUsage c) (ParamUsage c)
theseInnerUsages ->
        TraversalExprs -> These Expr Expr -> Expr
appBirecurseExprs TraversalExprs
te forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both ParamUsage c -> m Expr
mkFnExprForValue These (ParamUsage c) (ParamUsage c)
theseInnerUsages
      MentionsParamContravariantly c
c ContravariantParamUsage c
contraUsage -> do
        let ce :: ContraversalExprs
ce@ContraversalExprs{Expr
rprorecurseVar :: Expr
lcrecurseVar :: Expr
direcurseVar :: Expr
crecurseVar :: Expr
rprorecurseVar :: ContraversalExprs -> Expr
lcrecurseVar :: ContraversalExprs -> Expr
direcurseVar :: ContraversalExprs -> Expr
crecurseVar :: ContraversalExprs -> Expr
..} = c -> ContraversalExprs
getContraversalExprs c
c
        case ContravariantParamUsage c
contraUsage of
          MentionsParamContra ParamUsage c
innerUsage ->
            Expr -> Expr -> Expr
App Expr
crecurseVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamUsage c -> m Expr
mkFnExprForValue ParamUsage c
innerUsage
          MentionsParamPro These (ParamUsage c) (ParamUsage c)
theseInnerUsages ->
            ContraversalExprs -> These Expr Expr -> Expr
appDirecurseExprs ContraversalExprs
ce forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both ParamUsage c -> m Expr
mkFnExprForValue These (ParamUsage c) (ParamUsage c)
theseInnerUsages
      IsRecord NonEmpty (PSString, ParamUsage c)
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 c (f :: * -> *).
Applicative f =>
(ParamUsage c -> Expr -> f Expr)
-> NonEmpty (PSString, ParamUsage c) -> Expr -> f Expr
traverseFields ParamUsage c -> Expr -> f Expr
handleValue NonEmpty (PSString, ParamUsage c)
fields

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

deriveFunctor
  :: forall m
   . MonadError MultipleErrors m
  => MonadState CheckState m
  => MonadSupply m
  => Maybe Bool -- does left parameter exist, and is it contravariant?
  -> Bool -- is the (right) parameter contravariant?
  -> PSString -- name of the map function for this functor type
  -> Qualified (ProperName 'ClassName)
  -> UnwrappedTypeConstructor
  -> m [(PSString, Expr)]
deriveFunctor :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
Maybe Bool
-> Bool
-> PSString
-> Qualified (ProperName 'ClassName)
-> UnwrappedTypeConstructor
-> m [(PSString, Expr)]
deriveFunctor Maybe Bool
mbLParamIsContravariant Bool
paramIsContravariant PSString
mapName Qualified (ProperName 'ClassName)
nm UnwrappedTypeConstructor
utc = do
  [(ProperName 'ConstructorName, [Maybe (ParamUsage ())])]
ctors <- forall c (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
Qualified (ProperName 'ClassName)
-> UnwrappedTypeConstructor
-> Bool
-> CovariantClasses
-> Maybe (ContravarianceSupport c)
-> m [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])]
validateParamsInTypeConstructors Qualified (ProperName 'ClassName)
nm UnwrappedTypeConstructor
utc Bool
isBi CovariantClasses
functorClasses forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ContravarianceSupport
    { contravarianceWitness :: ()
contravarianceWitness = ()
    , Bool
paramIsContravariant :: Bool
paramIsContravariant :: Bool
paramIsContravariant
    , lparamIsContravariant :: Bool
lparamIsContravariant = forall (t :: * -> *). Foldable t => t Bool -> Bool
or Maybe Bool
mbLParamIsContravariant
    , ContravariantClasses
contravariantClasses :: ContravariantClasses
contravariantClasses :: ContravariantClasses
contravariantClasses
    }
  Expr
mapFun <- forall c (m :: * -> *).
MonadSupply m =>
ModuleName
-> Bool
-> TraversalExprs
-> (c -> ContraversalExprs)
-> TraversalOps m
-> [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])]
-> m Expr
mkTraversal (UnwrappedTypeConstructor -> ModuleName
utcModuleName UnwrappedTypeConstructor
utc) Bool
isBi TraversalExprs
mapExprs (forall a b. a -> b -> a
const ContraversalExprs
cmapExprs) (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 [(PSString
mapName, Expr
mapFun)]
  where
  isBi :: Bool
isBi = forall a. Maybe a -> Bool
isJust Maybe Bool
mbLParamIsContravariant
  mapExprs :: TraversalExprs
mapExprs = TraversalExprs
    { recurseVar :: Expr
recurseVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_map
    , birecurseVar :: Expr
birecurseVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_bimap
    , lrecurseExpr :: Expr
lrecurseExpr = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_lmap
    , rrecurseExpr :: Expr
rrecurseExpr = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_rmap
    }
  cmapExprs :: ContraversalExprs
cmapExprs = ContraversalExprs
    { crecurseVar :: Expr
crecurseVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_cmap
    , direcurseVar :: Expr
direcurseVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_dimap
    , lcrecurseVar :: Expr
lcrecurseVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_lcmap
    , rprorecurseVar :: Expr
rprorecurseVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_profunctorRmap
    }
  functorClasses :: CovariantClasses
functorClasses = Qualified (ProperName 'ClassName)
-> Qualified (ProperName 'ClassName) -> CovariantClasses
CovariantClasses Qualified (ProperName 'ClassName)
Libs.Functor Qualified (ProperName 'ClassName)
Libs.Bifunctor
  contravariantClasses :: ContravariantClasses
contravariantClasses = Qualified (ProperName 'ClassName)
-> Qualified (ProperName 'ClassName) -> ContravariantClasses
ContravariantClasses Qualified (ProperName 'ClassName)
Libs.Contravariant Qualified (ProperName 'ClassName)
Libs.Profunctor

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
  => Bool -- is there a left parameter (are we deriving Bifoldable)?
  -> Qualified (ProperName 'ClassName)
  -> UnwrappedTypeConstructor
  -> m [(PSString, Expr)]
deriveFoldable :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
Bool
-> Qualified (ProperName 'ClassName)
-> UnwrappedTypeConstructor
-> m [(PSString, Expr)]
deriveFoldable Bool
isBi Qualified (ProperName 'ClassName)
nm UnwrappedTypeConstructor
utc = do
  [(ProperName 'ConstructorName, [Maybe (ParamUsage Void)])]
ctors <- forall c (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
Qualified (ProperName 'ClassName)
-> UnwrappedTypeConstructor
-> Bool
-> CovariantClasses
-> Maybe (ContravarianceSupport c)
-> m [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])]
validateParamsInTypeConstructors Qualified (ProperName 'ClassName)
nm UnwrappedTypeConstructor
utc Bool
isBi CovariantClasses
foldableClasses forall a. Maybe a
Nothing
  Expr
foldlFun <- Bool
-> TraversalExprs
-> [(ProperName 'ConstructorName, [Maybe (ParamUsage Void)])]
-> m Expr
mkAsymmetricFoldFunction Bool
False TraversalExprs
foldlExprs [(ProperName 'ConstructorName, [Maybe (ParamUsage Void)])]
ctors
  Expr
foldrFun <- Bool
-> TraversalExprs
-> [(ProperName 'ConstructorName, [Maybe (ParamUsage Void)])]
-> m Expr
mkAsymmetricFoldFunction Bool
True TraversalExprs
foldrExprs [(ProperName 'ConstructorName, [Maybe (ParamUsage Void)])]
ctors
  Expr
foldMapFun <- forall c (m :: * -> *).
MonadSupply m =>
ModuleName
-> Bool
-> TraversalExprs
-> (c -> ContraversalExprs)
-> TraversalOps m
-> [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])]
-> m Expr
mkTraversal ModuleName
mn Bool
isBi TraversalExprs
foldMapExprs forall a. Void -> a
absurd forall (m :: * -> *). Applicative m => TraversalOps m
foldMapOps [(ProperName 'ConstructorName, [Maybe (ParamUsage Void)])]
ctors
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ (if Bool
isBi then forall a. (Eq a, IsString a) => a
Libs.S_bifoldl else forall a. (Eq a, IsString a) => a
Libs.S_foldl, Expr
foldlFun)
    , (if Bool
isBi then forall a. (Eq a, IsString a) => a
Libs.S_bifoldr else forall a. (Eq a, IsString a) => a
Libs.S_foldr, Expr
foldrFun)
    , (if Bool
isBi then forall a. (Eq a, IsString a) => a
Libs.S_bifoldMap else forall a. (Eq a, IsString a) => a
Libs.S_foldMap, Expr
foldMapFun)
    ]
  where
  mn :: ModuleName
mn = UnwrappedTypeConstructor -> ModuleName
utcModuleName UnwrappedTypeConstructor
utc
  foldableClasses :: CovariantClasses
foldableClasses = Qualified (ProperName 'ClassName)
-> Qualified (ProperName 'ClassName) -> CovariantClasses
CovariantClasses Qualified (ProperName 'ClassName)
Libs.Foldable Qualified (ProperName 'ClassName)
Libs.Bifoldable
  foldlExprs :: TraversalExprs
foldlExprs = TraversalExprs
    { recurseVar :: Expr
recurseVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_foldl
    , birecurseVar :: Expr
birecurseVar = Expr
bifoldlVar
    , lrecurseExpr :: Expr
lrecurseExpr = Expr -> Expr -> Expr
App (Expr -> Expr -> Expr
App Expr
flipVar Expr
bifoldlVar) Expr
constVar
    , rrecurseExpr :: Expr
rrecurseExpr = Expr -> Expr -> Expr
App Expr
bifoldlVar Expr
constVar
    }
  foldrExprs :: TraversalExprs
foldrExprs = TraversalExprs
    { recurseVar :: Expr
recurseVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_foldr
    , birecurseVar :: Expr
birecurseVar = Expr
bifoldrVar
    , lrecurseExpr :: Expr
lrecurseExpr = Expr -> Expr -> Expr
App (Expr -> Expr -> Expr
App Expr
flipVar Expr
bifoldrVar) (Expr -> Expr -> Expr
App Expr
constVar Expr
identityVar)
    , rrecurseExpr :: Expr
rrecurseExpr = Expr -> Expr -> Expr
App Expr
bifoldrVar (Expr -> Expr -> Expr
App Expr
constVar Expr
identityVar)
    }
  foldMapExprs :: TraversalExprs
foldMapExprs = TraversalExprs
    { recurseVar :: Expr
recurseVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_foldMap
    , birecurseVar :: Expr
birecurseVar = Expr
bifoldMapVar
    , lrecurseExpr :: Expr
lrecurseExpr = Expr -> Expr -> Expr
App (Expr -> Expr -> Expr
App Expr
flipVar Expr
bifoldMapVar) Expr
memptyVar
    , rrecurseExpr :: Expr
rrecurseExpr = Expr -> Expr -> Expr
App Expr
bifoldMapVar Expr
memptyVar
    }
  bifoldlVar :: Expr
bifoldlVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_bifoldl
  bifoldrVar :: Expr
bifoldrVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_bifoldr
  bifoldMapVar :: Expr
bifoldMapVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_bifoldMap
  constVar :: Expr
constVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_const
  flipVar :: Expr
flipVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_flip
  identityVar :: Expr
identityVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_identity
  memptyVar :: Expr
memptyVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_mempty

  mkAsymmetricFoldFunction :: Bool -> TraversalExprs -> [(ProperName 'ConstructorName, [Maybe (ParamUsage Void)])] -> m Expr
  mkAsymmetricFoldFunction :: Bool
-> TraversalExprs
-> [(ProperName 'ConstructorName, [Maybe (ParamUsage Void)])]
-> m Expr
mkAsymmetricFoldFunction Bool
isRightFold te :: TraversalExprs
te@TraversalExprs{Expr
rrecurseExpr :: Expr
lrecurseExpr :: Expr
birecurseVar :: Expr
recurseVar :: Expr
rrecurseExpr :: TraversalExprs -> Expr
lrecurseExpr :: TraversalExprs -> Expr
birecurseVar :: TraversalExprs -> Expr
recurseVar :: TraversalExprs -> Expr
..} [(ProperName 'ConstructorName, [Maybe (ParamUsage Void)])]
ctors = do
    Ident
f <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"f"
    Ident
g <- if Bool
isBi then forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"g" else forall (f :: * -> *) a. Applicative f => a -> f a
pure Ident
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 Void -> m Expr
      mkCombinerExpr :: ParamUsage Void -> 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 Void -> m (Bool, Expr)
getCombiner

      handleValue :: ParamUsage Void -> Expr -> Const [m (Expr -> Expr)] Expr
      handleValue :: ParamUsage Void -> Expr -> Const [m (Expr -> Expr)] Expr
handleValue = forall c (f :: * -> *).
Applicative f =>
(ParamUsage c -> Expr -> f Expr) -> ParamUsage c -> Expr -> f Expr
unnestRecords forall a b. (a -> b) -> a -> b
$ \ParamUsage Void
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 Void -> m (Bool, Expr)
getCombiner ParamUsage Void
usage

      getCombiner :: ParamUsage Void -> m (Bool, Expr)
      getCombiner :: ParamUsage Void -> m (Bool, Expr)
getCombiner = \case
        ParamUsage Void
IsParam ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, Ident -> Expr
mkVar Ident
g)
        ParamUsage Void
IsLParam ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, Ident -> Expr
mkVar Ident
f)
        MentionsParam ParamUsage Void
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 Void -> m Expr
mkCombinerExpr ParamUsage Void
innerUsage
        MentionsParamBi These (ParamUsage Void) (ParamUsage Void)
theseInnerUsages ->
          (Bool
isRightFold, ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraversalExprs -> These Expr Expr -> Expr
appBirecurseExprs TraversalExprs
te forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both ParamUsage Void -> m Expr
mkCombinerExpr These (ParamUsage Void) (ParamUsage Void)
theseInnerUsages
        IsRecord NonEmpty (PSString, ParamUsage Void)
fields -> do
          let foldFieldsOf :: Expr -> Const [m (Expr -> Expr)] Expr
foldFieldsOf = forall c (f :: * -> *).
Applicative f =>
(ParamUsage c -> Expr -> f Expr)
-> NonEmpty (PSString, ParamUsage c) -> Expr -> f Expr
traverseFields ParamUsage Void -> Expr -> Const [m (Expr -> Expr)] Expr
handleValue NonEmpty (PSString, ParamUsage Void)
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
. forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
isBi (Ident -> Expr -> Expr
lam Ident
g) 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 c (f :: * -> *) (m :: * -> *).
(Applicative f, MonadSupply m) =>
ModuleName
-> (ParamUsage c -> Expr -> f Expr)
-> (f Expr -> m Expr)
-> [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])]
-> m Expr
mkCasesForTraversal ModuleName
mn ParamUsage Void -> 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 Void)])]
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
Libs.I_append
  memptyVar :: Expr
memptyVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_mempty

  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
  => Bool -- is there a left parameter (are we deriving Bitraversable)?
  -> Qualified (ProperName 'ClassName)
  -> UnwrappedTypeConstructor
  -> m [(PSString, Expr)]
deriveTraversable :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
 MonadSupply m) =>
Bool
-> Qualified (ProperName 'ClassName)
-> UnwrappedTypeConstructor
-> m [(PSString, Expr)]
deriveTraversable Bool
isBi Qualified (ProperName 'ClassName)
nm UnwrappedTypeConstructor
utc = do
  [(ProperName 'ConstructorName, [Maybe (ParamUsage Void)])]
ctors <- forall c (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
Qualified (ProperName 'ClassName)
-> UnwrappedTypeConstructor
-> Bool
-> CovariantClasses
-> Maybe (ContravarianceSupport c)
-> m [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])]
validateParamsInTypeConstructors Qualified (ProperName 'ClassName)
nm UnwrappedTypeConstructor
utc Bool
isBi CovariantClasses
traversableClasses forall a. Maybe a
Nothing
  Expr
traverseFun <- forall c (m :: * -> *).
MonadSupply m =>
ModuleName
-> Bool
-> TraversalExprs
-> (c -> ContraversalExprs)
-> TraversalOps m
-> [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])]
-> m Expr
mkTraversal (UnwrappedTypeConstructor -> ModuleName
utcModuleName UnwrappedTypeConstructor
utc) Bool
isBi TraversalExprs
traverseExprs forall a. Void -> a
absurd forall (m :: * -> *). MonadSupply m => TraversalOps m
traverseOps [(ProperName 'ConstructorName, [Maybe (ParamUsage Void)])]
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 (if Bool
isBi then Expr -> Expr -> Expr
App Expr
bitraverseVar Expr
identityVar else Expr
traverseVar) Expr
identityVar)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ (if Bool
isBi then forall a. (Eq a, IsString a) => a
Libs.S_bitraverse else forall a. (Eq a, IsString a) => a
Libs.S_traverse, Expr
traverseFun)
    , (if Bool
isBi then forall a. (Eq a, IsString a) => a
Libs.S_bisequence else forall a. (Eq a, IsString a) => a
Libs.S_sequence, Expr
sequenceFun)
    ]
  where
  traversableClasses :: CovariantClasses
traversableClasses = Qualified (ProperName 'ClassName)
-> Qualified (ProperName 'ClassName) -> CovariantClasses
CovariantClasses Qualified (ProperName 'ClassName)
Libs.Traversable Qualified (ProperName 'ClassName)
Libs.Bitraversable
  traverseExprs :: TraversalExprs
traverseExprs = TraversalExprs
    { recurseVar :: Expr
recurseVar = Expr
traverseVar
    , birecurseVar :: Expr
birecurseVar = Expr
bitraverseVar
    , lrecurseExpr :: Expr
lrecurseExpr = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_ltraverse
    , rrecurseExpr :: Expr
rrecurseExpr = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_rtraverse
    }
  traverseVar :: Expr
traverseVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_traverse
  bitraverseVar :: Expr
bitraverseVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_bitraverse
  identityVar :: Expr
identityVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_identity

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
Libs.I_pure
  mapVar :: Expr
mapVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_map
  applyVar :: Expr
applyVar = Qualified Ident -> Expr
mkRef Qualified Ident
Libs.I_apply

  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