{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
module Language.PureScript.TypeChecker.Deriving (deriveInstance) where
import Protolude hiding (Type)
import Control.Monad.Trans.Writer (Writer, WriterT, runWriter, runWriterT)
import Control.Monad.Writer.Class (MonadWriter(..))
import Data.Foldable (foldl1, foldr1)
import Data.List (init, last, zipWith3, (!!))
import qualified Data.Map as M
import Control.Monad.Supply.Class
import Language.PureScript.AST
import Language.PureScript.AST.Utils
import qualified Language.PureScript.Constants.Data.Foldable as Foldable
import qualified Language.PureScript.Constants.Data.Traversable as Traversable
import qualified Language.PureScript.Constants.Prelude as Prelude
import qualified Language.PureScript.Constants.Prim as Prim
import Language.PureScript.Crash
import Language.PureScript.Environment
import Language.PureScript.Errors hiding (nonEmpty)
import Language.PureScript.Label (Label(..))
import Language.PureScript.Names
import Language.PureScript.PSString
import Language.PureScript.Sugar.TypeClasses
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.TypeChecker.Synonyms
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types
extractNewtypeName :: ModuleName -> [SourceType] -> Maybe (ModuleName, ProperName 'TypeName)
ModuleName
mn
= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Qualified (ProperName 'TypeName)
n, [SourceType]
_, [SourceType]
_) -> forall a. ModuleName -> Qualified a -> (ModuleName, a)
qualify ModuleName
mn Qualified (ProperName 'TypeName)
n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourceType
-> Maybe
(Qualified (ProperName 'TypeName), [SourceType], [SourceType])
unwrapTypeConstructor forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. [a] -> Maybe a
lastMay)
deriveInstance
:: forall m
. MonadError MultipleErrors m
=> MonadState CheckState m
=> MonadSupply m
=> MonadWriter MultipleErrors m
=> SourceType
-> Qualified (ProperName 'ClassName)
-> InstanceDerivationStrategy
-> m Expr
deriveInstance :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
MonadSupply m, MonadWriter MultipleErrors m) =>
SourceType
-> Qualified (ProperName 'ClassName)
-> InstanceDerivationStrategy
-> m Expr
deriveInstance SourceType
instType Qualified (ProperName 'ClassName)
className InstanceDerivationStrategy
strategy = do
ModuleName
mn <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
m ModuleName
unsafeCheckCurrentModule
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName -> Qualified (ProperName 'ConstructorName)
ctorName, [SourceType]
_, [SourceType]
tys) <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a.
(MonadError MultipleErrors m, HasCallStack) =>
Text -> m a
internalCompilerError Text
"invalid instance type") forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SourceType
-> Maybe
(Qualified (ProperName 'TypeName), [SourceType], [SourceType])
unwrapTypeConstructor SourceType
instType
TypeClassData{Bool
[(Text, Maybe SourceType)]
[(Ident, SourceType)]
[SourceConstraint]
[FunctionalDependency]
Set Int
Set (Set Int)
typeClassIsEmpty :: TypeClassData -> Bool
typeClassCoveringSets :: TypeClassData -> Set (Set Int)
typeClassDeterminedArguments :: TypeClassData -> Set Int
typeClassDependencies :: TypeClassData -> [FunctionalDependency]
typeClassSuperclasses :: TypeClassData -> [SourceConstraint]
typeClassMembers :: TypeClassData -> [(Ident, SourceType)]
typeClassArguments :: TypeClassData -> [(Text, Maybe SourceType)]
typeClassIsEmpty :: Bool
typeClassCoveringSets :: Set (Set Int)
typeClassDeterminedArguments :: Set Int
typeClassDependencies :: [FunctionalDependency]
typeClassSuperclasses :: [SourceConstraint]
typeClassMembers :: [(Ident, SourceType)]
typeClassArguments :: [(Text, Maybe SourceType)]
..} <-
forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
note (SimpleErrorMessage -> MultipleErrors
errorMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Qualified Name -> SimpleErrorMessage
UnknownName forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ProperName 'ClassName -> Name
TyClassName Qualified (ProperName 'ClassName)
className) forall a b. (a -> b) -> a -> b
$
Qualified (ProperName 'ClassName)
className forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Environment
env
case InstanceDerivationStrategy
strategy of
InstanceDerivationStrategy
KnownClassStrategy -> let
unaryClass :: (ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]) -> m Expr
unaryClass :: (ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
f = case [SourceType]
tys of
[SourceType
ty] -> case SourceType
-> Maybe
(Qualified (ProperName 'TypeName), [SourceType], [SourceType])
unwrapTypeConstructor SourceType
ty of
Just (Qualified (ByModuleName ModuleName
mn') ProperName 'TypeName
tyCon, [SourceType]
_, [SourceType]
_) | ModuleName
mn forall a. Eq a => a -> a -> Bool
== ModuleName
mn' -> do
let superclassesDicts :: [Expr]
superclassesDicts = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map [SourceConstraint]
typeClassSuperclasses forall a b. (a -> b) -> a -> b
$ \(Constraint SourceAnn
_ Qualified (ProperName 'ClassName)
superclass [SourceType]
_ [SourceType]
suTyArgs Maybe ConstraintData
_) ->
let tyArgs :: [SourceType]
tyArgs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall a. [(Text, Type a)] -> Type a -> Type a
replaceAllTypeVars (forall a b. [a] -> [b] -> [(a, b)]
zip (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. (a, b) -> a
fst [(Text, Maybe SourceType)]
typeClassArguments) [SourceType]
tys)) [SourceType]
suTyArgs
in Ident -> Expr -> Expr
lam Ident
UnusedIdent (Qualified (ProperName 'ClassName) -> [SourceType] -> Expr
DeferredDictionary Qualified (ProperName 'ClassName)
superclass [SourceType]
tyArgs)
let superclasses :: [(PSString, Expr)]
superclasses = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> PSString
mkString (forall a. [Constraint a] -> [Text]
superClassDictionaryNames [SourceConstraint]
typeClassSuperclasses) forall a b. [a] -> [b] -> [(a, b)]
`zip` [Expr]
superclassesDicts
Expr -> Expr -> Expr
App (SourceSpan -> Qualified (ProperName 'ConstructorName) -> Expr
Constructor SourceSpan
nullSourceSpan Qualified (ProperName 'ConstructorName)
ctorName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal Expr -> Expr
mkLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(PSString, a)] -> Literal a
ObjectLiteral forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ [(PSString, Expr)]
superclasses) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
f ModuleName
mn ProperName 'TypeName
tyCon
Maybe
(Qualified (ProperName 'TypeName), [SourceType], [SourceType])
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> [SourceType] -> SourceType -> SimpleErrorMessage
ExpectedTypeConstructor Qualified (ProperName 'ClassName)
className [SourceType]
tys SourceType
ty
[SourceType]
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> [SourceType] -> Int -> SimpleErrorMessage
InvalidDerivedInstance Qualified (ProperName 'ClassName)
className [SourceType]
tys Int
1
unaryClass' :: (Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass' Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
f = (ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass (Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
f Qualified (ProperName 'ClassName)
className)
in case Qualified (ProperName 'ClassName)
className of
Qualified (ProperName 'ClassName)
Foldable.Foldable -> (Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass' forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
MonadSupply m) =>
Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveFoldable
Qualified (ProperName 'ClassName)
Prelude.Eq -> (ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
MonadSupply m) =>
ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveEq
Qualified (ProperName 'ClassName)
Prelude.Eq1 -> (ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass forall a b. (a -> b) -> a -> b
$ \ModuleName
_ ProperName 'TypeName
_ -> forall (m :: * -> *). Applicative m => m [(PSString, Expr)]
deriveEq1
Qualified (ProperName 'ClassName)
Prelude.Functor -> (Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass' forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
MonadSupply m) =>
Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveFunctor
Qualified (ProperName 'ClassName)
Prelude.Ord -> (ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
MonadSupply m) =>
ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveOrd
Qualified (ProperName 'ClassName)
Prelude.Ord1 -> (ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass forall a b. (a -> b) -> a -> b
$ \ModuleName
_ ProperName 'TypeName
_ -> forall (m :: * -> *). Applicative m => m [(PSString, Expr)]
deriveOrd1
Qualified (ProperName 'ClassName)
Traversable.Traversable -> (Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)])
-> m Expr
unaryClass' forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
MonadSupply m) =>
Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveTraversable
Qualified (ProperName 'ClassName)
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> [SourceType] -> SimpleErrorMessage
CannotDerive Qualified (ProperName 'ClassName)
className [SourceType]
tys
InstanceDerivationStrategy
NewtypeStrategy ->
case [SourceType]
tys of
SourceType
_ : [SourceType]
_ | Just (Qualified (ByModuleName ModuleName
mn') ProperName 'TypeName
tyCon, [SourceType]
kargs, [SourceType]
args) <- SourceType
-> Maybe
(Qualified (ProperName 'TypeName), [SourceType], [SourceType])
unwrapTypeConstructor (forall a. [a] -> a
last [SourceType]
tys)
, ModuleName
mn forall a. Eq a => a -> a -> Bool
== ModuleName
mn'
-> forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
MonadSupply m, MonadWriter MultipleErrors m) =>
ModuleName
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> ProperName 'TypeName
-> [SourceType]
-> [SourceType]
-> m Expr
deriveNewtypeInstance ModuleName
mn Qualified (ProperName 'ClassName)
className [SourceType]
tys ProperName 'TypeName
tyCon [SourceType]
kargs [SourceType]
args
| Bool
otherwise -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> [SourceType] -> SourceType -> SimpleErrorMessage
ExpectedTypeConstructor Qualified (ProperName 'ClassName)
className [SourceType]
tys (forall a. [a] -> a
last [SourceType]
tys)
[SourceType]
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> [SourceType] -> SimpleErrorMessage
InvalidNewtypeInstance Qualified (ProperName 'ClassName)
className [SourceType]
tys
deriveNewtypeInstance
:: forall m
. MonadError MultipleErrors m
=> MonadState CheckState m
=> MonadSupply m
=> MonadWriter MultipleErrors m
=> ModuleName
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> ProperName 'TypeName
-> [SourceType]
-> [SourceType]
-> m Expr
deriveNewtypeInstance :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
MonadSupply m, MonadWriter MultipleErrors m) =>
ModuleName
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> ProperName 'TypeName
-> [SourceType]
-> [SourceType]
-> m Expr
deriveNewtypeInstance ModuleName
mn Qualified (ProperName 'ClassName)
className [SourceType]
tys ProperName 'TypeName
tyConNm [SourceType]
dkargs [SourceType]
dargs = do
m ()
verifySuperclasses
(Maybe DataDeclType
dtype, [Text]
tyKindNames, [(Text, Maybe SourceType)]
tyArgNames, [(ProperName 'ConstructorName, [SourceType])]
ctors) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> ProperName 'TypeName
-> m (Maybe DataDeclType, [Text], [(Text, Maybe SourceType)],
[(ProperName 'ConstructorName, [SourceType])])
lookupTypeDecl ModuleName
mn ProperName 'TypeName
tyConNm
Maybe DataDeclType
-> [Text]
-> [(Text, Maybe SourceType)]
-> [(ProperName 'ConstructorName, [SourceType])]
-> m Expr
go Maybe DataDeclType
dtype [Text]
tyKindNames [(Text, Maybe SourceType)]
tyArgNames [(ProperName 'ConstructorName, [SourceType])]
ctors
where
go :: Maybe DataDeclType
-> [Text]
-> [(Text, Maybe SourceType)]
-> [(ProperName 'ConstructorName, [SourceType])]
-> m Expr
go (Just DataDeclType
Newtype) [Text]
tyKindNames [(Text, Maybe SourceType)]
tyArgNames [(ProperName 'ConstructorName
_, [SourceType
wrapped])] = do
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
deriveEq
:: forall m
. MonadError MultipleErrors m
=> MonadState CheckState m
=> MonadSupply m
=> ModuleName
-> ProperName 'TypeName
-> m [(PSString, Expr)]
deriveEq :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
MonadSupply m) =>
ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveEq ModuleName
mn ProperName 'TypeName
tyConNm = do
(Maybe DataDeclType
_, [Text]
_, [(Text, Maybe SourceType)]
_, [(ProperName 'ConstructorName, [SourceType])]
ctors) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> ProperName 'TypeName
-> m (Maybe DataDeclType, [Text], [(Text, Maybe SourceType)],
[(ProperName 'ConstructorName, [SourceType])])
lookupTypeDecl ModuleName
mn ProperName 'TypeName
tyConNm
Expr
eqFun <- [(ProperName 'ConstructorName, [SourceType])] -> m Expr
mkEqFunction [(ProperName 'ConstructorName, [SourceType])]
ctors
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. IsString a => a
Prelude.eq, Expr
eqFun)]
where
mkEqFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr
mkEqFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr
mkEqFunction [(ProperName 'ConstructorName, [SourceType])]
ctors = do
Ident
x <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"x"
Ident
y <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"y"
Ident -> Ident -> [CaseAlternative] -> Expr
lamCase2 Ident
x Ident
y forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CaseAlternative] -> [CaseAlternative]
addCatch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ProperName 'ConstructorName, [SourceType]) -> m CaseAlternative
mkCtorClause [(ProperName 'ConstructorName, [SourceType])]
ctors
preludeConj :: Expr -> Expr -> Expr
preludeConj :: Expr -> Expr -> Expr
preludeConj = Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App (Maybe ModuleName -> Ident -> Expr
mkVarMn (forall a. a -> Maybe a
Just (Text -> ModuleName
ModuleName Text
"Data.HeytingAlgebra")) (Text -> Ident
Ident forall a. IsString a => a
Prelude.conj))
preludeEq :: Expr -> Expr -> Expr
preludeEq :: Expr -> Expr -> Expr
preludeEq = Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App (Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identEq)
preludeEq1 :: Expr -> Expr -> Expr
preludeEq1 :: Expr -> Expr -> Expr
preludeEq1 = Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App (Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identEq1)
addCatch :: [CaseAlternative] -> [CaseAlternative]
addCatch :: [CaseAlternative] -> [CaseAlternative]
addCatch [CaseAlternative]
xs
| forall (t :: * -> *) a. Foldable t => t a -> Int
length [CaseAlternative]
xs forall a. Eq a => a -> a -> Bool
/= Int
1 = [CaseAlternative]
xs forall a. [a] -> [a] -> [a]
++ [CaseAlternative
catchAll]
| Bool
otherwise = [CaseAlternative]
xs
where
catchAll :: CaseAlternative
catchAll = [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
NullBinder, Binder
NullBinder] (Expr -> [GuardedExpr]
unguarded (Literal Expr -> Expr
mkLit (forall a. Bool -> Literal a
BooleanLiteral Bool
False)))
mkCtorClause :: (ProperName 'ConstructorName, [SourceType]) -> m CaseAlternative
mkCtorClause :: (ProperName 'ConstructorName, [SourceType]) -> m CaseAlternative
mkCtorClause (ProperName 'ConstructorName
ctorName, [SourceType]
tys) = do
[Ident]
identsL <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceType]
tys) (forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"l")
[Ident]
identsR <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceType]
tys) (forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"r")
[SourceType]
tys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms [SourceType]
tys
let tests :: [Expr]
tests = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Expr -> Expr -> SourceType -> Expr
toEqTest (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Ident -> Expr
mkVar [Ident]
identsL) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Ident -> Expr
mkVar [Ident]
identsR) [SourceType]
tys'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [[Ident] -> Binder
caseBinder [Ident]
identsL, [Ident] -> Binder
caseBinder [Ident]
identsR] (Expr -> [GuardedExpr]
unguarded ([Expr] -> Expr
conjAll [Expr]
tests))
where
caseBinder :: [Ident] -> Binder
caseBinder [Ident]
idents = ModuleName -> ProperName 'ConstructorName -> [Binder] -> Binder
mkCtorBinder ModuleName
mn ProperName 'ConstructorName
ctorName forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Ident -> Binder
mkBinder [Ident]
idents
conjAll :: [Expr] -> Expr
conjAll :: [Expr] -> Expr
conjAll = \case
[] -> Literal Expr -> Expr
mkLit (forall a. Bool -> Literal a
BooleanLiteral Bool
True)
[Expr]
xs -> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Expr -> Expr -> Expr
preludeConj [Expr]
xs
toEqTest :: Expr -> Expr -> SourceType -> Expr
toEqTest :: Expr -> Expr -> SourceType -> Expr
toEqTest Expr
l Expr
r SourceType
ty
| Just [(Label, SourceType)]
fields <- SourceType -> Maybe [(Label, SourceType)]
decomposeRec forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. Type a -> Maybe (Type a)
objectType forall a b. (a -> b) -> a -> b
$ SourceType
ty
= [Expr] -> Expr
conjAll
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(Label PSString
str, SourceType
typ) -> Expr -> Expr -> SourceType -> Expr
toEqTest (PSString -> Expr -> Expr
Accessor PSString
str Expr
l) (PSString -> Expr -> Expr
Accessor PSString
str Expr
r) SourceType
typ)
forall a b. (a -> b) -> a -> b
$ [(Label, SourceType)]
fields
| forall a. Type a -> Bool
isAppliedVar SourceType
ty = Expr -> Expr -> Expr
preludeEq1 Expr
l Expr
r
| Bool
otherwise = Expr -> Expr -> Expr
preludeEq Expr
l Expr
r
deriveEq1 :: forall m. Applicative m => m [(PSString, Expr)]
deriveEq1 :: forall (m :: * -> *). Applicative m => m [(PSString, Expr)]
deriveEq1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. IsString a => a
Prelude.eq1, Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identEq)]
deriveOrd
:: forall m
. MonadError MultipleErrors m
=> MonadState CheckState m
=> MonadSupply m
=> ModuleName
-> ProperName 'TypeName
-> m [(PSString, Expr)]
deriveOrd :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
MonadSupply m) =>
ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveOrd ModuleName
mn ProperName 'TypeName
tyConNm = do
(Maybe DataDeclType
_, [Text]
_, [(Text, Maybe SourceType)]
_, [(ProperName 'ConstructorName, [SourceType])]
ctors) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> ProperName 'TypeName
-> m (Maybe DataDeclType, [Text], [(Text, Maybe SourceType)],
[(ProperName 'ConstructorName, [SourceType])])
lookupTypeDecl ModuleName
mn ProperName 'TypeName
tyConNm
Expr
compareFun <- [(ProperName 'ConstructorName, [SourceType])] -> m Expr
mkCompareFunction [(ProperName 'ConstructorName, [SourceType])]
ctors
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. IsString a => a
Prelude.compare, Expr
compareFun)]
where
mkCompareFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr
mkCompareFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr
mkCompareFunction [(ProperName 'ConstructorName, [SourceType])]
ctors = do
Ident
x <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"x"
Ident
y <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"y"
Ident -> Ident -> [CaseAlternative] -> Expr
lamCase2 Ident
x Ident
y forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([CaseAlternative] -> [CaseAlternative]
addCatch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((ProperName 'ConstructorName, [SourceType]), Bool)
-> m [CaseAlternative]
mkCtorClauses (forall a. [a] -> [(a, Bool)]
splitLast [(ProperName 'ConstructorName, [SourceType])]
ctors))
splitLast :: [a] -> [(a, Bool)]
splitLast :: forall a. [a] -> [(a, Bool)]
splitLast [] = []
splitLast [a
x] = [(a
x, Bool
True)]
splitLast (a
x : [a]
xs) = (a
x, Bool
False) forall a. a -> [a] -> [a]
: forall a. [a] -> [(a, Bool)]
splitLast [a]
xs
addCatch :: [CaseAlternative] -> [CaseAlternative]
addCatch :: [CaseAlternative] -> [CaseAlternative]
addCatch [CaseAlternative]
xs
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CaseAlternative]
xs = [CaseAlternative
catchAll]
| Bool
otherwise = [CaseAlternative]
xs
where
catchAll :: CaseAlternative
catchAll = [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
NullBinder, Binder
NullBinder] (Expr -> [GuardedExpr]
unguarded (Text -> Expr
orderingCtor Text
"EQ"))
orderingMod :: ModuleName
orderingMod :: ModuleName
orderingMod = Text -> ModuleName
ModuleName Text
"Data.Ordering"
orderingCtor :: Text -> Expr
orderingCtor :: Text -> Expr
orderingCtor = ModuleName -> ProperName 'ConstructorName -> Expr
mkCtor ModuleName
orderingMod forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: ProperNameType). Text -> ProperName a
ProperName
orderingBinder :: Text -> Binder
orderingBinder :: Text -> Binder
orderingBinder Text
name = ModuleName -> ProperName 'ConstructorName -> [Binder] -> Binder
mkCtorBinder ModuleName
orderingMod (forall (a :: ProperNameType). Text -> ProperName a
ProperName Text
name) []
ordCompare :: Expr -> Expr -> Expr
ordCompare :: Expr -> Expr -> Expr
ordCompare = Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App (Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identCompare)
ordCompare1 :: Expr -> Expr -> Expr
ordCompare1 :: Expr -> Expr -> Expr
ordCompare1 = Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App (Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identCompare1)
mkCtorClauses :: ((ProperName 'ConstructorName, [SourceType]), Bool) -> m [CaseAlternative]
mkCtorClauses :: ((ProperName 'ConstructorName, [SourceType]), Bool)
-> m [CaseAlternative]
mkCtorClauses ((ProperName 'ConstructorName
ctorName, [SourceType]
tys), Bool
isLast) = do
[Ident]
identsL <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceType]
tys) (forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"l")
[Ident]
identsR <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceType]
tys) (forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"r")
[SourceType]
tys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms [SourceType]
tys
let tests :: [Expr]
tests = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Expr -> Expr -> SourceType -> Expr
toOrdering (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Ident -> Expr
mkVar [Ident]
identsL) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Ident -> Expr
mkVar [Ident]
identsR) [SourceType]
tys'
extras :: [CaseAlternative]
extras | Bool -> Bool
not Bool
isLast = [ [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
nullCaseBinder, Binder
NullBinder] (Expr -> [GuardedExpr]
unguarded (Text -> Expr
orderingCtor Text
"LT"))
, [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
NullBinder, Binder
nullCaseBinder] (Expr -> [GuardedExpr]
unguarded (Text -> Expr
orderingCtor Text
"GT"))
]
| Bool
otherwise = []
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [ [Ident] -> Binder
caseBinder [Ident]
identsL
, [Ident] -> Binder
caseBinder [Ident]
identsR
]
(Expr -> [GuardedExpr]
unguarded ([Expr] -> Expr
appendAll [Expr]
tests))
forall a. a -> [a] -> [a]
: [CaseAlternative]
extras
where
caseBinder :: [Ident] -> Binder
caseBinder [Ident]
idents = ModuleName -> ProperName 'ConstructorName -> [Binder] -> Binder
mkCtorBinder ModuleName
mn ProperName 'ConstructorName
ctorName forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Ident -> Binder
mkBinder [Ident]
idents
nullCaseBinder :: Binder
nullCaseBinder = ModuleName -> ProperName 'ConstructorName -> [Binder] -> Binder
mkCtorBinder ModuleName
mn ProperName 'ConstructorName
ctorName forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceType]
tys) Binder
NullBinder
appendAll :: [Expr] -> Expr
appendAll :: [Expr] -> Expr
appendAll = \case
[] -> Text -> Expr
orderingCtor Text
"EQ"
[Expr
x] -> Expr
x
(Expr
x : [Expr]
xs) -> [Expr] -> [CaseAlternative] -> Expr
Case [Expr
x] [ [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Text -> Binder
orderingBinder Text
"LT"] (Expr -> [GuardedExpr]
unguarded (Text -> Expr
orderingCtor Text
"LT"))
, [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Text -> Binder
orderingBinder Text
"GT"] (Expr -> [GuardedExpr]
unguarded (Text -> Expr
orderingCtor Text
"GT"))
, [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
NullBinder] (Expr -> [GuardedExpr]
unguarded ([Expr] -> Expr
appendAll [Expr]
xs))
]
toOrdering :: Expr -> Expr -> SourceType -> Expr
toOrdering :: Expr -> Expr -> SourceType -> Expr
toOrdering Expr
l Expr
r SourceType
ty
| Just [(Label, SourceType)]
fields <- SourceType -> Maybe [(Label, SourceType)]
decomposeRec forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. Type a -> Maybe (Type a)
objectType forall a b. (a -> b) -> a -> b
$ SourceType
ty
= [Expr] -> Expr
appendAll
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(Label PSString
str, SourceType
typ) -> Expr -> Expr -> SourceType -> Expr
toOrdering (PSString -> Expr -> Expr
Accessor PSString
str Expr
l) (PSString -> Expr -> Expr
Accessor PSString
str Expr
r) SourceType
typ)
forall a b. (a -> b) -> a -> b
$ [(Label, SourceType)]
fields
| forall a. Type a -> Bool
isAppliedVar SourceType
ty = Expr -> Expr -> Expr
ordCompare1 Expr
l Expr
r
| Bool
otherwise = Expr -> Expr -> Expr
ordCompare Expr
l Expr
r
deriveOrd1 :: forall m. Applicative m => m [(PSString, Expr)]
deriveOrd1 :: forall (m :: * -> *). Applicative m => m [(PSString, Expr)]
deriveOrd1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. IsString a => a
Prelude.compare1, Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identCompare)]
lookupTypeDecl
:: forall m
. MonadError MultipleErrors m
=> MonadState CheckState m
=> ModuleName
-> ProperName 'TypeName
-> m (Maybe DataDeclType, [Text], [(Text, Maybe SourceType)], [(ProperName 'ConstructorName, [SourceType])])
lookupTypeDecl :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> ProperName 'TypeName
-> m (Maybe DataDeclType, [Text], [(Text, Maybe SourceType)],
[(ProperName 'ConstructorName, [SourceType])])
lookupTypeDecl ModuleName
mn ProperName 'TypeName
typeName = do
Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
note (SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ ProperName 'TypeName -> SimpleErrorMessage
CannotFindDerivingType ProperName 'TypeName
typeName) forall a b. (a -> b) -> a -> b
$ do
(SourceType
kind, DataType DataDeclType
_ [(Text, Maybe SourceType, Role)]
args [(ProperName 'ConstructorName, [SourceType])]
dctors) <- forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn) ProperName 'TypeName
typeName forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env
([(SourceAnn, (Text, SourceType))]
kargs, SourceType
_) <- forall a. Type a -> Maybe ([(a, (Text, Type a))], Type a)
completeBinderList SourceType
kind
let dtype :: Maybe DataDeclType
dtype = do
(ProperName 'ConstructorName
ctorName, [SourceType]
_) <- forall a. [a] -> Maybe a
headMay [(ProperName 'ConstructorName, [SourceType])]
dctors
(DataDeclType
a, ProperName 'TypeName
_, SourceType
_, [Ident]
_) <- forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn) ProperName 'ConstructorName
ctorName forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Environment
-> Map
(Qualified (ProperName 'ConstructorName))
(DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dataConstructors Environment
env
forall (f :: * -> *) a. Applicative f => a -> f a
pure DataDeclType
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DataDeclType
dtype, forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SourceAnn, (Text, SourceType))]
kargs, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(Text
v, Maybe SourceType
k, Role
_) -> (Text
v, Maybe SourceType
k)) [(Text, Maybe SourceType, Role)]
args, [(ProperName 'ConstructorName, [SourceType])]
dctors)
isAppliedVar :: Type a -> Bool
isAppliedVar :: forall a. Type a -> Bool
isAppliedVar (TypeApp a
_ (TypeVar a
_ Text
_) Type a
_) = Bool
True
isAppliedVar Type a
_ = Bool
False
objectType :: Type a -> Maybe (Type a)
objectType :: forall a. Type a -> Maybe (Type a)
objectType (TypeApp a
_ (TypeConstructor a
_ Qualified (ProperName 'TypeName)
Prim.Record) Type a
rec) = forall a. a -> Maybe a
Just Type a
rec
objectType Type a
_ = forall a. Maybe a
Nothing
decomposeRec :: SourceType -> Maybe [(Label, SourceType)]
decomposeRec :: SourceType -> Maybe [(Label, SourceType)]
decomposeRec = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall o a. Ord o => (a -> o) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Type a -> Maybe [(Label, Type a)]
go
where go :: Type a -> Maybe [(Label, Type a)]
go (RCons a
_ Label
str Type a
typ Type a
typs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Label
str, Type a
typ) forall a. a -> [a] -> [a]
:) (Type a -> Maybe [(Label, Type a)]
go Type a
typs)
go (REmptyKinded a
_ Maybe (Type a)
_) = forall a. a -> Maybe a
Just []
go Type a
_ = forall a. Maybe a
Nothing
decomposeRec' :: SourceType -> [(Label, SourceType)]
decomposeRec' :: SourceType -> [(Label, SourceType)]
decomposeRec' = forall o a. Ord o => (a -> o) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Type a -> [(Label, Type a)]
go
where go :: Type a -> [(Label, Type a)]
go (RCons a
_ Label
str Type a
typ Type a
typs) = (Label
str, Type a
typ) forall a. a -> [a] -> [a]
: Type a -> [(Label, Type a)]
go Type a
typs
go Type a
_ = []
data ParamUsage
= IsParam
| MentionsParam ParamUsage
| IsRecord (NonEmpty (PSString, ParamUsage))
validateParamsInTypeConstructors
:: forall m
. MonadError MultipleErrors m
=> MonadState CheckState m
=> Qualified (ProperName 'ClassName)
-> ModuleName
-> ProperName 'TypeName
-> m [(ProperName 'ConstructorName, [Maybe ParamUsage])]
validateParamsInTypeConstructors :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
Qualified (ProperName 'ClassName)
-> ModuleName
-> ProperName 'TypeName
-> m [(ProperName 'ConstructorName, [Maybe ParamUsage])]
validateParamsInTypeConstructors Qualified (ProperName 'ClassName)
derivingClass ModuleName
mn ProperName 'TypeName
tyConNm = do
(Maybe DataDeclType
_, [Text]
_, [(Text, Maybe SourceType)]
tyArgNames, [(ProperName 'ConstructorName, [SourceType])]
ctors) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
ModuleName
-> ProperName 'TypeName
-> m (Maybe DataDeclType, [Text], [(Text, Maybe SourceType)],
[(ProperName 'ConstructorName, [SourceType])])
lookupTypeDecl ModuleName
mn ProperName 'TypeName
tyConNm
Text
param <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
note (SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ SourceType -> SourceType -> SimpleErrorMessage
KindsDoNotUnify (SourceType
kindType SourceType -> SourceType -> SourceType
-:> SourceType
kindType) SourceType
kindType) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
lastMay forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. (a, b) -> a
fst [(Text, Maybe SourceType)]
tyArgNames
[(ProperName 'ConstructorName, [SourceType])]
ctors' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
SourceType -> m SourceType
replaceAllTypeSynonyms) [(ProperName 'ConstructorName, [SourceType])]
ctors
let ([(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctorUsages, [SourceSpan]
problemSpans) = forall w a. Writer w a -> (a, w)
runWriter forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ Text -> SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
typeToUsageOf Text
param) [(ProperName 'ConstructorName, [SourceType])]
ctors'
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
ordNub [SourceSpan]
problemSpans) forall a b. (a -> b) -> a -> b
$ \NonEmpty SourceSpan
sss ->
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (NonEmpty SourceSpan -> ErrorMessageHint
RelatedPositions NonEmpty SourceSpan
sss) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName) -> SimpleErrorMessage
CannotDeriveInvalidConstructorArg Qualified (ProperName 'ClassName)
derivingClass
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctorUsages
where
typeToUsageOf :: Text -> SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
typeToUsageOf :: Text -> SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
typeToUsageOf Text
param = SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
go
where
assertNoParamUsedIn :: SourceType -> Writer [SourceSpan] ()
assertNoParamUsedIn :: SourceType -> Writer [SourceSpan] ()
assertNoParamUsedIn = forall r a. (r -> r -> r) -> (Type a -> r) -> Type a -> r
everythingOnTypes forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>) forall a b. (a -> b) -> a -> b
$ \case
TypeVar (SourceSpan
ss, [Comment]
_) Text
name | Text
name forall a. Eq a => a -> a -> Bool
== Text
param -> forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [SourceSpan
ss]
SourceType
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
go :: SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
go = \case
ForAll SourceAnn
_ Text
name Maybe SourceType
_ SourceType
ty Maybe SkolemScope
_ ->
if Text
name forall a. Eq a => a -> a -> Bool
== Text
param then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing else SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
go SourceType
ty
ConstrainedType SourceAnn
_ SourceConstraint
_ SourceType
ty ->
SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
go SourceType
ty
TypeApp SourceAnn
_ (TypeConstructor SourceAnn
_ Qualified (ProperName 'TypeName)
Prim.Record) SourceType
row ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (PSString, ParamUsage) -> ParamUsage
IsRecord forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (SourceType -> [(Label, SourceType)]
decomposeRec' SourceType
row) forall a b. (a -> b) -> a -> b
$ \(Label PSString
lbl, SourceType
ty) ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PSString
lbl, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
go SourceType
ty
TypeApp SourceAnn
_ SourceType
tyFn SourceType
tyArg -> do
SourceType -> Writer [SourceSpan] ()
assertNoParamUsedIn SourceType
tyFn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParamUsage -> ParamUsage
MentionsParam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceType -> Writer [SourceSpan] (Maybe ParamUsage)
go SourceType
tyArg
TypeVar SourceAnn
_ Text
name ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Text
name forall a. Eq a => a -> a -> Bool
== Text
param) forall (f :: * -> *) a. Alternative f => Bool -> a -> f a
`orEmpty` ParamUsage
IsParam
SourceType
ty ->
SourceType -> Writer [SourceSpan] ()
assertNoParamUsedIn SourceType
ty forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. Maybe a
Nothing
usingLamIdent :: forall m. MonadSupply m => (Expr -> m Expr) -> m Expr
usingLamIdent :: forall (m :: * -> *). MonadSupply m => (Expr -> m Expr) -> m Expr
usingLamIdent Expr -> m Expr
cb = do
Ident
ident <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"v"
Ident -> Expr -> Expr
lam Ident
ident forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> m Expr
cb (Ident -> Expr
mkVar Ident
ident)
traverseFields :: forall f. Applicative f => (ParamUsage -> Expr -> f Expr) -> NonEmpty (PSString, ParamUsage) -> Expr -> f Expr
traverseFields :: forall (f :: * -> *).
Applicative f =>
(ParamUsage -> Expr -> f Expr)
-> NonEmpty (PSString, ParamUsage) -> Expr -> f Expr
traverseFields ParamUsage -> Expr -> f Expr
f NonEmpty (PSString, ParamUsage)
fields Expr
r = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Expr -> [(PSString, Expr)] -> Expr
ObjectUpdate Expr
r) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (PSString, ParamUsage)
fields) forall a b. (a -> b) -> a -> b
$ \(PSString
lbl, ParamUsage
usage) -> (PSString
lbl, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamUsage -> Expr -> f Expr
f ParamUsage
usage (PSString -> Expr -> Expr
Accessor PSString
lbl Expr
r)
unnestRecords :: forall f. Applicative f => (ParamUsage -> Expr -> f Expr) -> ParamUsage -> Expr -> f Expr
unnestRecords :: forall (f :: * -> *).
Applicative f =>
(ParamUsage -> Expr -> f Expr) -> ParamUsage -> Expr -> f Expr
unnestRecords ParamUsage -> Expr -> f Expr
f = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \ParamUsage -> Expr -> f Expr
go -> \case
IsRecord NonEmpty (PSString, ParamUsage)
fields -> forall (f :: * -> *).
Applicative f =>
(ParamUsage -> Expr -> f Expr)
-> NonEmpty (PSString, ParamUsage) -> Expr -> f Expr
traverseFields ParamUsage -> Expr -> f Expr
go NonEmpty (PSString, ParamUsage)
fields
ParamUsage
usage -> ParamUsage -> Expr -> f Expr
f ParamUsage
usage
mkCasesForTraversal
:: forall f m
. Applicative f
=> MonadSupply m
=> ModuleName
-> (ParamUsage -> Expr -> f Expr)
-> (f Expr -> m Expr)
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkCasesForTraversal :: forall (f :: * -> *) (m :: * -> *).
(Applicative f, MonadSupply m) =>
ModuleName
-> (ParamUsage -> Expr -> f Expr)
-> (f Expr -> m Expr)
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkCasesForTraversal ModuleName
mn ParamUsage -> Expr -> f Expr
handleArg f Expr -> m Expr
extractExpr [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors = do
Ident
m <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"m"
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Ident -> [CaseAlternative] -> Expr
lamCase Ident
m) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors forall a b. (a -> b) -> a -> b
$ \(ProperName 'ConstructorName
ctorName, [Maybe ParamUsage]
ctorUsages) -> do
[(Ident, Maybe ParamUsage)]
ctorArgs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Maybe ParamUsage]
ctorUsages forall a b. (a -> b) -> a -> b
$ \Maybe ParamUsage
usage -> forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"v" forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (, Maybe ParamUsage
usage)
let ctor :: Expr
ctor = ModuleName -> ProperName 'ConstructorName -> Expr
mkCtor ModuleName
mn ProperName 'ConstructorName
ctorName
let caseBinder :: Binder
caseBinder = ModuleName -> ProperName 'ConstructorName -> [Binder] -> Binder
mkCtorBinder ModuleName
mn ProperName 'ConstructorName
ctorName forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Ident -> Binder
mkBinder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Ident, Maybe ParamUsage)]
ctorArgs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
caseBinder] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> [GuardedExpr]
unguarded) forall b c a. (b -> c) -> (a -> b) -> a -> c
. f Expr -> m Expr
extractExpr forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Expr -> Expr -> Expr
App Expr
ctor) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Ident, Maybe ParamUsage)]
ctorArgs forall a b. (a -> b) -> a -> b
$ \(Ident
ident, Maybe ParamUsage
mbUsage) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (f :: * -> *) a. Applicative f => a -> f a
pure ParamUsage -> Expr -> f Expr
handleArg Maybe ParamUsage
mbUsage forall a b. (a -> b) -> a -> b
$ Ident -> Expr
mkVar Ident
ident
data TraversalOps m = forall f. Applicative f => TraversalOps
{ ()
visitExpr :: m Expr -> f Expr
, :: f Expr -> m Expr
}
mkTraversal
:: forall m
. MonadSupply m
=> ModuleName
-> Expr
-> TraversalOps m
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkTraversal :: forall (m :: * -> *).
MonadSupply m =>
ModuleName
-> Expr
-> TraversalOps m
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkTraversal ModuleName
mn Expr
recurseVar (TraversalOps @_ @f m Expr -> f Expr
visitExpr f Expr -> m Expr
extractExpr) [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors = do
Ident
f <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"f"
let
handleValue :: ParamUsage -> Expr -> f Expr
handleValue :: ParamUsage -> Expr -> f Expr
handleValue = forall (f :: * -> *).
Applicative f =>
(ParamUsage -> Expr -> f Expr) -> ParamUsage -> Expr -> f Expr
unnestRecords forall a b. (a -> b) -> a -> b
$ \ParamUsage
usage Expr
inputExpr -> m Expr -> f Expr
visitExpr forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip Expr -> Expr -> Expr
App Expr
inputExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamUsage -> m Expr
mkFnExprForValue ParamUsage
usage
mkFnExprForValue :: ParamUsage -> m Expr
mkFnExprForValue :: ParamUsage -> m Expr
mkFnExprForValue = \case
ParamUsage
IsParam ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Ident -> Expr
mkVar Ident
f
MentionsParam ParamUsage
innerUsage ->
Expr -> Expr -> Expr
App Expr
recurseVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamUsage -> m Expr
mkFnExprForValue ParamUsage
innerUsage
IsRecord NonEmpty (PSString, ParamUsage)
fields ->
forall (m :: * -> *). MonadSupply m => (Expr -> m Expr) -> m Expr
usingLamIdent forall a b. (a -> b) -> a -> b
$ f Expr -> m Expr
extractExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Applicative f =>
(ParamUsage -> Expr -> f Expr)
-> NonEmpty (PSString, ParamUsage) -> Expr -> f Expr
traverseFields ParamUsage -> Expr -> f Expr
handleValue NonEmpty (PSString, ParamUsage)
fields
Ident -> Expr -> Expr
lam Ident
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) (m :: * -> *).
(Applicative f, MonadSupply m) =>
ModuleName
-> (ParamUsage -> Expr -> f Expr)
-> (f Expr -> m Expr)
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkCasesForTraversal ModuleName
mn ParamUsage -> Expr -> f Expr
handleValue f Expr -> m Expr
extractExpr [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors
deriveFunctor
:: forall m
. MonadError MultipleErrors m
=> MonadState CheckState m
=> MonadSupply m
=> Qualified (ProperName 'ClassName)
-> ModuleName
-> ProperName 'TypeName
-> m [(PSString, Expr)]
deriveFunctor :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
MonadSupply m) =>
Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveFunctor Qualified (ProperName 'ClassName)
nm ModuleName
mn ProperName 'TypeName
tyConNm = do
[(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
Qualified (ProperName 'ClassName)
-> ModuleName
-> ProperName 'TypeName
-> m [(ProperName 'ConstructorName, [Maybe ParamUsage])]
validateParamsInTypeConstructors Qualified (ProperName 'ClassName)
nm ModuleName
mn ProperName 'TypeName
tyConNm
Expr
mapFun <- forall (m :: * -> *).
MonadSupply m =>
ModuleName
-> Expr
-> TraversalOps m
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkTraversal ModuleName
mn Expr
mapVar (forall (m :: * -> *) (f :: * -> *).
Applicative f =>
(m Expr -> f Expr) -> (f Expr -> m Expr) -> TraversalOps m
TraversalOps forall a. a -> a
identity forall a. a -> a
identity) [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. IsString a => a
Prelude.map, Expr
mapFun)]
where
mapVar :: Expr
mapVar = Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identMap
toConst :: forall f a b. f a -> Const [f a] b
toConst :: forall (f :: * -> *) a b. f a -> Const [f a] b
toConst = forall {k} a (b :: k). a -> Const a b
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
consumeConst :: forall f a b c. Applicative f => ([a] -> b) -> Const [f a] c -> f b
consumeConst :: forall (f :: * -> *) a b c.
Applicative f =>
([a] -> b) -> Const [f a] c -> f b
consumeConst [a] -> b
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} a (b :: k). Const a b -> a
getConst
applyWhen :: forall a. Bool -> (a -> a) -> a -> a
applyWhen :: forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
cond a -> a
f = if Bool
cond then a -> a
f else forall a. a -> a
identity
deriveFoldable
:: forall m
. MonadError MultipleErrors m
=> MonadState CheckState m
=> MonadSupply m
=> Qualified (ProperName 'ClassName)
-> ModuleName
-> ProperName 'TypeName
-> m [(PSString, Expr)]
deriveFoldable :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
MonadSupply m) =>
Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveFoldable Qualified (ProperName 'ClassName)
nm ModuleName
mn ProperName 'TypeName
tyConNm = do
[(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
Qualified (ProperName 'ClassName)
-> ModuleName
-> ProperName 'TypeName
-> m [(ProperName 'ConstructorName, [Maybe ParamUsage])]
validateParamsInTypeConstructors Qualified (ProperName 'ClassName)
nm ModuleName
mn ProperName 'TypeName
tyConNm
Expr
foldlFun <- Bool
-> Expr
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkAsymmetricFoldFunction Bool
False Expr
foldlVar [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors
Expr
foldrFun <- Bool
-> Expr
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkAsymmetricFoldFunction Bool
True Expr
foldrVar [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors
Expr
foldMapFun <- forall (m :: * -> *).
MonadSupply m =>
ModuleName
-> Expr
-> TraversalOps m
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkTraversal ModuleName
mn Expr
foldMapVar forall (m :: * -> *). Applicative m => TraversalOps m
foldMapOps [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. IsString a => a
Foldable.foldl, Expr
foldlFun), (forall a. IsString a => a
Foldable.foldr, Expr
foldrFun), (forall a. IsString a => a
Foldable.foldMap, Expr
foldMapFun)]
where
foldlVar :: Expr
foldlVar = Qualified Ident -> Expr
mkRef Qualified Ident
Foldable.identFoldl
foldrVar :: Expr
foldrVar = Qualified Ident -> Expr
mkRef Qualified Ident
Foldable.identFoldr
foldMapVar :: Expr
foldMapVar = Qualified Ident -> Expr
mkRef Qualified Ident
Foldable.identFoldMap
flipVar :: Expr
flipVar = Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identFlip
mkAsymmetricFoldFunction :: Bool -> Expr -> [(ProperName 'ConstructorName, [Maybe ParamUsage])] -> m Expr
mkAsymmetricFoldFunction :: Bool
-> Expr
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkAsymmetricFoldFunction Bool
isRightFold Expr
recurseVar [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors = do
Ident
f <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"f"
Ident
z <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"z"
let
appCombiner :: (Bool, Expr) -> Expr -> Expr -> Expr
appCombiner :: (Bool, Expr) -> Expr -> Expr -> Expr
appCombiner (Bool
isFlipped, Expr
fn) = forall a. Bool -> (a -> a) -> a -> a
applyWhen (Bool
isFlipped forall a. Eq a => a -> a -> Bool
== Bool
isRightFold) forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App Expr
fn
mkCombinerExpr :: ParamUsage -> m Expr
mkCombinerExpr :: ParamUsage -> m Expr
mkCombinerExpr = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ \Bool
isFlipped -> forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
isFlipped forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
App Expr
flipVar) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParamUsage -> m (Bool, Expr)
getCombiner
handleValue :: ParamUsage -> Expr -> Const [m (Expr -> Expr)] Expr
handleValue :: ParamUsage -> Expr -> Const [m (Expr -> Expr)] Expr
handleValue = forall (f :: * -> *).
Applicative f =>
(ParamUsage -> Expr -> f Expr) -> ParamUsage -> Expr -> f Expr
unnestRecords forall a b. (a -> b) -> a -> b
$ \ParamUsage
usage Expr
inputExpr -> forall (f :: * -> *) a b. f a -> Const [f a] b
toConst forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip (Bool, Expr) -> Expr -> Expr -> Expr
appCombiner Expr
inputExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamUsage -> m (Bool, Expr)
getCombiner ParamUsage
usage
getCombiner :: ParamUsage -> m (Bool, Expr)
getCombiner :: ParamUsage -> m (Bool, Expr)
getCombiner = \case
ParamUsage
IsParam ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, Ident -> Expr
mkVar Ident
f)
MentionsParam ParamUsage
innerUsage ->
(Bool
isRightFold, ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App Expr
recurseVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamUsage -> m Expr
mkCombinerExpr ParamUsage
innerUsage
IsRecord NonEmpty (PSString, ParamUsage)
fields -> do
let foldFieldsOf :: Expr -> Const [m (Expr -> Expr)] Expr
foldFieldsOf = forall (f :: * -> *).
Applicative f =>
(ParamUsage -> Expr -> f Expr)
-> NonEmpty (PSString, ParamUsage) -> Expr -> f Expr
traverseFields ParamUsage -> Expr -> Const [m (Expr -> Expr)] Expr
handleValue NonEmpty (PSString, ParamUsage)
fields
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool
False, ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadSupply m => (Expr -> m Expr) -> m Expr
usingLamIdent forall a b. (a -> b) -> a -> b
$ \Expr
lVar ->
forall (m :: * -> *). MonadSupply m => (Expr -> m Expr) -> m Expr
usingLamIdent forall a b. (a -> b) -> a -> b
$
if Bool
isRightFold
then forall a b c. (a -> b -> c) -> b -> a -> c
flip Expr -> Const [m (Expr -> Expr)] Expr -> m Expr
extractExprStartingWith forall a b. (a -> b) -> a -> b
$ Expr -> Const [m (Expr -> Expr)] Expr
foldFieldsOf Expr
lVar
else Expr -> Const [m (Expr -> Expr)] Expr -> m Expr
extractExprStartingWith Expr
lVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Const [m (Expr -> Expr)] Expr
foldFieldsOf
extractExprStartingWith :: Expr -> Const [m (Expr -> Expr)] Expr -> m Expr
extractExprStartingWith :: Expr -> Const [m (Expr -> Expr)] Expr -> m Expr
extractExprStartingWith = forall (f :: * -> *) a b c.
Applicative f =>
([a] -> b) -> Const [f a] c -> f b
consumeConst forall b c a. (b -> c) -> (a -> b) -> a -> c
. if Bool
isRightFold then forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) else forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a b. a -> (a -> b) -> b
(&)
Ident -> Expr -> Expr
lam Ident
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Expr -> Expr
lam Ident
z forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) (m :: * -> *).
(Applicative f, MonadSupply m) =>
ModuleName
-> (ParamUsage -> Expr -> f Expr)
-> (f Expr -> m Expr)
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkCasesForTraversal ModuleName
mn ParamUsage -> Expr -> Const [m (Expr -> Expr)] Expr
handleValue (Expr -> Const [m (Expr -> Expr)] Expr -> m Expr
extractExprStartingWith forall a b. (a -> b) -> a -> b
$ Ident -> Expr
mkVar Ident
z) [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors
foldMapOps :: forall m. Applicative m => TraversalOps m
foldMapOps :: forall (m :: * -> *). Applicative m => TraversalOps m
foldMapOps = TraversalOps { visitExpr :: m Expr -> Const [m Expr] Expr
visitExpr = forall (f :: * -> *) a b. f a -> Const [f a] b
toConst, Const [m Expr] Expr -> m Expr
extractExpr :: Const [m Expr] Expr -> m Expr
extractExpr :: Const [m Expr] Expr -> m Expr
.. }
where
appendVar :: Expr
appendVar = Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identAppend
memptyVar :: Expr
memptyVar = Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identMempty
extractExpr :: Const [m Expr] Expr -> m Expr
extractExpr :: Const [m Expr] Expr -> m Expr
extractExpr = forall (f :: * -> *) a b c.
Applicative f =>
([a] -> b) -> Const [f a] c -> f b
consumeConst forall a b. (a -> b) -> a -> b
$ \case
[] -> Expr
memptyVar
[Expr]
exprs -> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App Expr
appendVar) [Expr]
exprs
deriveTraversable
:: forall m
. MonadError MultipleErrors m
=> MonadState CheckState m
=> MonadSupply m
=> Qualified (ProperName 'ClassName)
-> ModuleName
-> ProperName 'TypeName
-> m [(PSString, Expr)]
deriveTraversable :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m,
MonadSupply m) =>
Qualified (ProperName 'ClassName)
-> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]
deriveTraversable Qualified (ProperName 'ClassName)
nm ModuleName
mn ProperName 'TypeName
tyConNm = do
[(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
Qualified (ProperName 'ClassName)
-> ModuleName
-> ProperName 'TypeName
-> m [(ProperName 'ConstructorName, [Maybe ParamUsage])]
validateParamsInTypeConstructors Qualified (ProperName 'ClassName)
nm ModuleName
mn ProperName 'TypeName
tyConNm
Expr
traverseFun <- forall (m :: * -> *).
MonadSupply m =>
ModuleName
-> Expr
-> TraversalOps m
-> [(ProperName 'ConstructorName, [Maybe ParamUsage])]
-> m Expr
mkTraversal ModuleName
mn Expr
traverseVar forall (m :: * -> *). MonadSupply m => TraversalOps m
traverseOps [(ProperName 'ConstructorName, [Maybe ParamUsage])]
ctors
Expr
sequenceFun <- forall (m :: * -> *). MonadSupply m => (Expr -> m Expr) -> m Expr
usingLamIdent forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App (Expr -> Expr -> Expr
App Expr
traverseVar Expr
identityVar)
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. IsString a => a
Traversable.traverse, Expr
traverseFun), (forall a. IsString a => a
Traversable.sequence, Expr
sequenceFun)]
where
traverseVar :: Expr
traverseVar = Qualified Ident -> Expr
mkRef Qualified Ident
Traversable.identTraverse
identityVar :: Expr
identityVar = Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identIdentity
traverseOps :: forall m. MonadSupply m => TraversalOps m
traverseOps :: forall (m :: * -> *). MonadSupply m => TraversalOps m
traverseOps = TraversalOps { m Expr -> WriterT [(Ident, m Expr)] m Expr
WriterT [(Ident, m Expr)] m Expr -> m Expr
extractExpr :: WriterT [(Ident, m Expr)] m Expr -> m Expr
visitExpr :: m Expr -> WriterT [(Ident, m Expr)] m Expr
extractExpr :: WriterT [(Ident, m Expr)] m Expr -> m Expr
visitExpr :: m Expr -> WriterT [(Ident, m Expr)] m Expr
.. }
where
pureVar :: Expr
pureVar = Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identPure
mapVar :: Expr
mapVar = Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identMap
applyVar :: Expr
applyVar = Qualified Ident -> Expr
mkRef Qualified Ident
Prelude.identApply
visitExpr :: m Expr -> WriterT [(Ident, m Expr)] m Expr
visitExpr :: m Expr -> WriterT [(Ident, m Expr)] m Expr
visitExpr m Expr
traversedExpr = do
Ident
ident <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"v"
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(Ident
ident, m Expr
traversedExpr)] forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Ident -> Expr
mkVar Ident
ident
extractExpr :: WriterT [(Ident, m Expr)] m Expr -> m Expr
extractExpr :: WriterT [(Ident, m Expr)] m Expr -> m Expr
extractExpr = forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \(Expr
result, forall a b. [(a, b)] -> ([a], [b])
unzip -> ([Ident]
ctx, [m Expr]
args)) -> forall a b c. (a -> b -> c) -> b -> a -> c
flip [Expr] -> Expr -> Expr
mkApps (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ident -> Expr -> Expr
lam Expr
result [Ident]
ctx) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [m Expr]
args
mkApps :: [Expr] -> Expr -> Expr
mkApps :: [Expr] -> Expr -> Expr
mkApps = \case
[] -> Expr -> Expr -> Expr
App Expr
pureVar
Expr
h : [Expr]
t -> \Expr
l -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Expr -> Expr -> Expr
App forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr -> Expr
App Expr
applyVar) (Expr -> Expr -> Expr
App (Expr -> Expr -> Expr
App Expr
mapVar Expr
l) Expr
h) [Expr]
t