{-# 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)
extractNewtypeName :: ModuleName -> [SourceType] -> Maybe (ModuleName, ProperName 'TypeName)
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)]
[SourceConstraint]
[FunctionalDependency]
Set Int
Set (Set Int)
typeClassIsEmpty :: TypeClassData -> Bool
typeClassCoveringSets :: TypeClassData -> Set (Set Int)
typeClassDeterminedArguments :: TypeClassData -> Set Int
typeClassDependencies :: TypeClassData -> [FunctionalDependency]
typeClassSuperclasses :: TypeClassData -> [SourceConstraint]
typeClassMembers :: TypeClassData -> [(Ident, SourceType)]
typeClassArguments :: TypeClassData -> [(Text, Maybe SourceType)]
typeClassIsEmpty :: Bool
typeClassCoveringSets :: Set (Set Int)
typeClassDeterminedArguments :: Set Int
typeClassDependencies :: [FunctionalDependency]
typeClassSuperclasses :: [SourceConstraint]
typeClassMembers :: [(Ident, SourceType)]
typeClassArguments :: [(Text, Maybe SourceType)]
..} <-
forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
note (SimpleErrorMessage -> MultipleErrors
errorMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Qualified Name -> SimpleErrorMessage
UnknownName forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ProperName 'ClassName -> Name
TyClassName Qualified (ProperName 'ClassName)
className) forall a b. (a -> b) -> a -> b
$
Qualified (ProperName 'ClassName)
className forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Environment
env
case InstanceDerivationStrategy
strategy of
InstanceDerivationStrategy
KnownClassStrategy -> let
unaryClass :: (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
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
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 } ->
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
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
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
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
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]
| 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
_ = []
data ParamUsage c
= IsParam
| IsLParam
| MentionsParam (ParamUsage c)
| MentionsParamBi (These (ParamUsage c) (ParamUsage c))
| MentionsParamContravariantly !c (ContravariantParamUsage c)
| IsRecord (NonEmpty (PSString, ParamUsage c))
data ContravariantParamUsage c
= MentionsParamContra (ParamUsage c)
| MentionsParamPro (These (ParamUsage c) (ParamUsage c))
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
}
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'
[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
=> MonadSupply m
=> ModuleName
-> (ParamUsage c -> Expr -> f Expr)
-> (f Expr -> m Expr)
-> [(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
, TraversalExprs -> Expr
birecurseVar :: Expr
, TraversalExprs -> Expr
lrecurseExpr :: Expr
, TraversalExprs -> Expr
rrecurseExpr :: Expr
}
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
, :: f Expr -> m Expr
}
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
-> Bool
-> PSString
-> 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
-> 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
-> 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