module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where
import Prelude
import Protolude (note)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Supply.Class (MonadSupply)
import Data.List (foldl', find, unzip5)
import Language.PureScript.AST (Binder(..), CaseAlternative(..), DataConstructorDeclaration(..), Declaration(..), Expr(..), pattern MkUnguarded, Module(..), SourceSpan(..), TypeInstanceBody(..), pattern ValueDecl)
import Language.PureScript.AST.Utils (UnwrappedTypeConstructor(..), lamCase, unguarded, unwrapTypeConstructor)
import Language.PureScript.Constants.Libs qualified as Libs
import Language.PureScript.Crash (internalError)
import Language.PureScript.Environment (DataDeclType(..), NameKind(..))
import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage')
import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), freshIdent)
import Language.PureScript.PSString (mkString)
import Language.PureScript.Types (SourceType, Type(..), WildcardData(..), replaceAllTypeVars, srcTypeApp, srcTypeConstructor, srcTypeLevelString)
import Language.PureScript.TypeChecker (checkNewtype)
deriveInstances
:: forall m
. (MonadError MultipleErrors m, MonadSupply m)
=> Module
-> m Module
deriveInstances :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadSupply m) =>
Module -> m Module
deriveInstances (Module SourceSpan
ss [Comment]
coms ModuleName
mn [Declaration]
ds Maybe [DeclarationRef]
exts) =
SourceSpan
-> [Comment]
-> ModuleName
-> [Declaration]
-> Maybe [DeclarationRef]
-> Module
Module SourceSpan
ss [Comment]
coms ModuleName
mn 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 (forall (m :: * -> *).
(MonadError MultipleErrors m, MonadSupply m) =>
ModuleName -> [Declaration] -> Declaration -> m Declaration
deriveInstance ModuleName
mn [Declaration]
ds) [Declaration]
ds forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [DeclarationRef]
exts
deriveInstance
:: forall m
. (MonadError MultipleErrors m, MonadSupply m)
=> ModuleName
-> [Declaration]
-> Declaration
-> m Declaration
deriveInstance :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadSupply m) =>
ModuleName -> [Declaration] -> Declaration -> m Declaration
deriveInstance ModuleName
mn [Declaration]
ds Declaration
decl =
case Declaration
decl of
TypeInstanceDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) SourceAnn
na ChainId
ch Integer
idx Either Text Ident
nm [SourceConstraint]
deps Qualified (ProperName 'ClassName)
className [SourceType]
tys TypeInstanceBody
DerivedInstance -> let
binaryWildcardClass :: (Declaration -> [SourceType] -> m ([Declaration], SourceType)) -> m Declaration
binaryWildcardClass :: (Declaration -> [SourceType] -> m ([Declaration], SourceType))
-> m Declaration
binaryWildcardClass Declaration -> [SourceType] -> m ([Declaration], SourceType)
f = case [SourceType]
tys of
[SourceType
ty1, SourceType
ty2] -> case SourceType -> Maybe UnwrappedTypeConstructor
unwrapTypeConstructor SourceType
ty1 of
Just UnwrappedTypeConstructor{[SourceType]
ModuleName
ProperName 'TypeName
utcArgs :: UnwrappedTypeConstructor -> [SourceType]
utcKindArgs :: UnwrappedTypeConstructor -> [SourceType]
utcTyCon :: UnwrappedTypeConstructor -> ProperName 'TypeName
utcModuleName :: UnwrappedTypeConstructor -> ModuleName
utcArgs :: [SourceType]
utcKindArgs :: [SourceType]
utcTyCon :: ProperName 'TypeName
utcModuleName :: ModuleName
..} | ModuleName
mn forall a. Eq a => a -> a -> Bool
== ModuleName
utcModuleName -> do
forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan -> ProperName 'TypeName -> SourceType -> m ()
checkIsWildcard SourceSpan
ss ProperName 'TypeName
utcTyCon SourceType
ty2
Declaration
tyConDecl <- forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan
-> ProperName 'TypeName -> [Declaration] -> m Declaration
findTypeDecl SourceSpan
ss ProperName 'TypeName
utcTyCon [Declaration]
ds
([Declaration]
members, SourceType
ty2') <- Declaration -> [SourceType] -> m ([Declaration], SourceType)
f Declaration
tyConDecl [SourceType]
utcArgs
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SourceAnn
-> SourceAnn
-> ChainId
-> Integer
-> Either Text Ident
-> [SourceConstraint]
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> TypeInstanceBody
-> Declaration
TypeInstanceDeclaration SourceAnn
sa SourceAnn
na ChainId
ch Integer
idx Either Text Ident
nm [SourceConstraint]
deps Qualified (ProperName 'ClassName)
className [SourceType
ty1, SourceType
ty2'] ([Declaration] -> TypeInstanceBody
ExplicitInstance [Declaration]
members)
Maybe UnwrappedTypeConstructor
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> [SourceType] -> SourceType -> SimpleErrorMessage
ExpectedTypeConstructor Qualified (ProperName 'ClassName)
className [SourceType]
tys SourceType
ty1
[SourceType]
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> [SourceType] -> Int -> SimpleErrorMessage
InvalidDerivedInstance Qualified (ProperName 'ClassName)
className [SourceType]
tys Int
2
in case Qualified (ProperName 'ClassName)
className of
Qualified (ProperName 'ClassName)
Libs.Generic -> (Declaration -> [SourceType] -> m ([Declaration], SourceType))
-> m Declaration
binaryWildcardClass (forall (m :: * -> *).
(MonadError MultipleErrors m, MonadSupply m) =>
SourceSpan
-> ModuleName
-> Declaration
-> [SourceType]
-> m ([Declaration], SourceType)
deriveGenericRep SourceSpan
ss ModuleName
mn)
Qualified (ProperName 'ClassName)
Libs.Newtype -> (Declaration -> [SourceType] -> m ([Declaration], SourceType))
-> m Declaration
binaryWildcardClass forall (m :: * -> *).
MonadError MultipleErrors m =>
Declaration -> [SourceType] -> m ([Declaration], SourceType)
deriveNewtype
Qualified (ProperName 'ClassName)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Declaration
decl
Declaration
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Declaration
decl
deriveGenericRep
:: forall m
. (MonadError MultipleErrors m, MonadSupply m)
=> SourceSpan
-> ModuleName
-> Declaration
-> [SourceType]
-> m ([Declaration], SourceType)
deriveGenericRep :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadSupply m) =>
SourceSpan
-> ModuleName
-> Declaration
-> [SourceType]
-> m ([Declaration], SourceType)
deriveGenericRep SourceSpan
ss ModuleName
mn Declaration
tyCon [SourceType]
tyConArgs =
case Declaration
tyCon of
DataDeclaration (SourceSpan
ss', [Comment]
_) DataDeclType
_ ProperName 'TypeName
_ [(Text, Maybe SourceType)]
args [DataConstructorDeclaration]
dctors -> do
Ident
x <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"x"
([SourceType]
reps, [CaseAlternative]
to, [CaseAlternative]
from) <- forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DataConstructorDeclaration
-> m (SourceType, CaseAlternative, CaseAlternative)
makeInst [DataConstructorDeclaration]
dctors
let rep :: SourceType
rep = [SourceType] -> SourceType
toRepTy [SourceType]
reps
inst :: [Declaration]
inst | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SourceType]
reps =
[ SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl (SourceSpan
ss', []) (Text -> Ident
Ident Text
"to") NameKind
Public [] forall a b. (a -> b) -> a -> b
$ Expr -> [GuardedExpr]
unguarded forall a b. (a -> b) -> a -> b
$
Ident -> [CaseAlternative] -> Expr
lamCase Ident
x
[ [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative
[Binder
NullBinder]
(Expr -> [GuardedExpr]
unguarded (Expr -> Expr -> Expr
App (SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
ss Qualified Ident
Libs.I_to) (SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
ss' (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Ident
x))))
]
, SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl (SourceSpan
ss', []) (Text -> Ident
Ident Text
"from") NameKind
Public [] forall a b. (a -> b) -> a -> b
$ Expr -> [GuardedExpr]
unguarded forall a b. (a -> b) -> a -> b
$
Ident -> [CaseAlternative] -> Expr
lamCase Ident
x
[ [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative
[Binder
NullBinder]
(Expr -> [GuardedExpr]
unguarded (Expr -> Expr -> Expr
App (SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
ss Qualified Ident
Libs.I_from) (SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
ss' (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Ident
x))))
]
]
| Bool
otherwise =
[ SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl (SourceSpan
ss', []) (Text -> Ident
Ident Text
"to") NameKind
Public [] forall a b. (a -> b) -> a -> b
$ Expr -> [GuardedExpr]
unguarded forall a b. (a -> b) -> a -> b
$
Ident -> [CaseAlternative] -> Expr
lamCase Ident
x (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a b. (a -> b) -> a -> b
($) (forall a b. (a -> b) -> [a] -> [b]
map (Binder -> Binder) -> CaseAlternative -> CaseAlternative
underBinder (Int -> [Binder -> Binder]
sumBinders (forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataConstructorDeclaration]
dctors))) [CaseAlternative]
to)
, SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl (SourceSpan
ss', []) (Text -> Ident
Ident Text
"from") NameKind
Public [] forall a b. (a -> b) -> a -> b
$ Expr -> [GuardedExpr]
unguarded forall a b. (a -> b) -> a -> b
$
Ident -> [CaseAlternative] -> Expr
lamCase Ident
x (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a b. (a -> b) -> a -> b
($) (forall a b. (a -> b) -> [a] -> [b]
map (Expr -> Expr) -> CaseAlternative -> CaseAlternative
underExpr (Int -> [Expr -> Expr]
sumExprs (forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataConstructorDeclaration]
dctors))) [CaseAlternative]
from)
]
subst :: [(Text, SourceType)]
subst = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, Maybe SourceType)]
args [SourceType]
tyConArgs
forall (m :: * -> *) a. Monad m => a -> m a
return ([Declaration]
inst, forall a. [(Text, Type a)] -> Type a -> Type a
replaceAllTypeVars [(Text, SourceType)]
subst SourceType
rep)
Declaration
_ -> forall a. HasCallStack => String -> a
internalError String
"deriveGenericRep: expected DataDeclaration"
where
select :: (a -> a) -> (a -> a) -> Int -> [a -> a]
select :: forall a. (a -> a) -> (a -> a) -> Int -> [a -> a]
select a -> a
_ a -> a
_ Int
0 = []
select a -> a
_ a -> a
_ Int
1 = [forall a. a -> a
id]
select a -> a
l a -> a
r Int
n = forall a. Int -> [a] -> [a]
take (Int
n forall a. Num a => a -> a -> a
- Int
1) (forall a. (a -> a) -> a -> [a]
iterate (a -> a
r forall b c a. (b -> c) -> (a -> b) -> a -> c
.) a -> a
l) forall a. [a] -> [a] -> [a]
++ [forall a. Int -> (a -> a) -> a -> a
compN (Int
n forall a. Num a => a -> a -> a
- Int
1) a -> a
r]
sumBinders :: Int -> [Binder -> Binder]
sumBinders :: Int -> [Binder -> Binder]
sumBinders = forall a. (a -> a) -> (a -> a) -> Int -> [a -> a]
select (SourceSpan
-> Qualified (ProperName 'ConstructorName) -> [Binder] -> Binder
ConstructorBinder SourceSpan
ss Qualified (ProperName 'ConstructorName)
Libs.C_Inl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure)
(SourceSpan
-> Qualified (ProperName 'ConstructorName) -> [Binder] -> Binder
ConstructorBinder SourceSpan
ss Qualified (ProperName 'ConstructorName)
Libs.C_Inr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure)
sumExprs :: Int -> [Expr -> Expr]
sumExprs :: Int -> [Expr -> Expr]
sumExprs = forall a. (a -> a) -> (a -> a) -> Int -> [a -> a]
select (Expr -> Expr -> Expr
App (SourceSpan -> Qualified (ProperName 'ConstructorName) -> Expr
Constructor SourceSpan
ss Qualified (ProperName 'ConstructorName)
Libs.C_Inl))
(Expr -> Expr -> Expr
App (SourceSpan -> Qualified (ProperName 'ConstructorName) -> Expr
Constructor SourceSpan
ss Qualified (ProperName 'ConstructorName)
Libs.C_Inr))
compN :: Int -> (a -> a) -> a -> a
compN :: forall a. Int -> (a -> a) -> a -> a
compN Int
0 a -> a
_ = forall a. a -> a
id
compN Int
n a -> a
f = a -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> (a -> a) -> a -> a
compN (Int
n forall a. Num a => a -> a -> a
- Int
1) a -> a
f
makeInst
:: DataConstructorDeclaration
-> m (SourceType, CaseAlternative, CaseAlternative)
makeInst :: DataConstructorDeclaration
-> m (SourceType, CaseAlternative, CaseAlternative)
makeInst (DataConstructorDeclaration SourceAnn
_ ProperName 'ConstructorName
ctorName [(Ident, SourceType)]
args) = do
let args' :: [SourceType]
args' = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Ident, SourceType)]
args
(SourceType
ctorTy, Binder
matchProduct, [Expr]
ctorArgs, [Binder]
matchCtor, Expr
mkProduct) <- [SourceType] -> m (SourceType, Binder, [Expr], [Binder], Expr)
makeProduct [SourceType]
args'
forall (m :: * -> *) a. Monad m => a -> m a
return ( SourceType -> SourceType -> SourceType
srcTypeApp (SourceType -> SourceType -> SourceType
srcTypeApp (Qualified (ProperName 'TypeName) -> SourceType
srcTypeConstructor Qualified (ProperName 'TypeName)
Libs.Constructor)
(PSString -> SourceType
srcTypeLevelString forall a b. (a -> b) -> a -> b
$ Text -> PSString
mkString (forall (a :: ProperNameType). ProperName a -> Text
runProperName ProperName 'ConstructorName
ctorName)))
SourceType
ctorTy
, [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [ SourceSpan
-> Qualified (ProperName 'ConstructorName) -> [Binder] -> Binder
ConstructorBinder SourceSpan
ss Qualified (ProperName 'ConstructorName)
Libs.C_Constructor [Binder
matchProduct] ]
(Expr -> [GuardedExpr]
unguarded (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Expr -> Expr -> Expr
App (SourceSpan -> Qualified (ProperName 'ConstructorName) -> Expr
Constructor SourceSpan
ss (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn) ProperName 'ConstructorName
ctorName)) [Expr]
ctorArgs))
, [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [ SourceSpan
-> Qualified (ProperName 'ConstructorName) -> [Binder] -> Binder
ConstructorBinder SourceSpan
ss (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn) ProperName 'ConstructorName
ctorName) [Binder]
matchCtor ]
(Expr -> [GuardedExpr]
unguarded (Expr -> Expr -> Expr
App (SourceSpan -> Qualified (ProperName 'ConstructorName) -> Expr
Constructor SourceSpan
ss Qualified (ProperName 'ConstructorName)
Libs.C_Constructor) Expr
mkProduct))
)
makeProduct
:: [SourceType]
-> m (SourceType, Binder, [Expr], [Binder], Expr)
makeProduct :: [SourceType] -> m (SourceType, Binder, [Expr], [Binder], Expr)
makeProduct [] =
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Qualified (ProperName 'TypeName) -> SourceType
srcTypeConstructor Qualified (ProperName 'TypeName)
Libs.NoArguments, Binder
NullBinder, [], [], SourceSpan -> Qualified (ProperName 'ConstructorName) -> Expr
Constructor SourceSpan
ss Qualified (ProperName 'ConstructorName)
Libs.C_NoArguments)
makeProduct [SourceType]
args = do
([SourceType]
tys, [Binder]
bs1, [Expr]
es1, [Binder]
bs2, [Expr]
es2) <- forall a b c d e. [(a, b, c, d, e)] -> ([a], [b], [c], [d], [e])
unzip5 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse SourceType -> m (SourceType, Binder, Expr, Binder, Expr)
makeArg [SourceType]
args
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\SourceType
f -> SourceType -> SourceType -> SourceType
srcTypeApp (SourceType -> SourceType -> SourceType
srcTypeApp (Qualified (ProperName 'TypeName) -> SourceType
srcTypeConstructor Qualified (ProperName 'TypeName)
Libs.Product) SourceType
f)) [SourceType]
tys
, forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Binder
b1 Binder
b2 -> SourceSpan
-> Qualified (ProperName 'ConstructorName) -> [Binder] -> Binder
ConstructorBinder SourceSpan
ss Qualified (ProperName 'ConstructorName)
Libs.C_Product [Binder
b1, Binder
b2]) [Binder]
bs1
, [Expr]
es1
, [Binder]
bs2
, forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Expr
e1 -> Expr -> Expr -> Expr
App (Expr -> Expr -> Expr
App (SourceSpan -> Qualified (ProperName 'ConstructorName) -> Expr
Constructor SourceSpan
ss Qualified (ProperName 'ConstructorName)
Libs.C_Product) Expr
e1)) [Expr]
es2
)
makeArg :: SourceType -> m (SourceType, Binder, Expr, Binder, Expr)
makeArg :: SourceType -> m (SourceType, Binder, Expr, Binder, Expr)
makeArg SourceType
arg = do
Ident
argName <- forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent Text
"arg"
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( SourceType -> SourceType -> SourceType
srcTypeApp (Qualified (ProperName 'TypeName) -> SourceType
srcTypeConstructor Qualified (ProperName 'TypeName)
Libs.Argument) SourceType
arg
, SourceSpan
-> Qualified (ProperName 'ConstructorName) -> [Binder] -> Binder
ConstructorBinder SourceSpan
ss Qualified (ProperName 'ConstructorName)
Libs.C_Argument [ SourceSpan -> Ident -> Binder
VarBinder SourceSpan
ss Ident
argName ]
, SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
ss (forall a. QualifiedBy -> a -> Qualified a
Qualified (SourcePos -> QualifiedBy
BySourcePos forall a b. (a -> b) -> a -> b
$ SourceSpan -> SourcePos
spanStart SourceSpan
ss) Ident
argName)
, SourceSpan -> Ident -> Binder
VarBinder SourceSpan
ss Ident
argName
, Expr -> Expr -> Expr
App (SourceSpan -> Qualified (ProperName 'ConstructorName) -> Expr
Constructor SourceSpan
ss Qualified (ProperName 'ConstructorName)
Libs.C_Argument) (SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
ss (forall a. QualifiedBy -> a -> Qualified a
Qualified (SourcePos -> QualifiedBy
BySourcePos forall a b. (a -> b) -> a -> b
$ SourceSpan -> SourcePos
spanStart SourceSpan
ss) Ident
argName))
)
underBinder :: (Binder -> Binder) -> CaseAlternative -> CaseAlternative
underBinder :: (Binder -> Binder) -> CaseAlternative -> CaseAlternative
underBinder Binder -> Binder
f (CaseAlternative [Binder]
bs [GuardedExpr]
e) = [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative (forall a b. (a -> b) -> [a] -> [b]
map Binder -> Binder
f [Binder]
bs) [GuardedExpr]
e
underExpr :: (Expr -> Expr) -> CaseAlternative -> CaseAlternative
underExpr :: (Expr -> Expr) -> CaseAlternative -> CaseAlternative
underExpr Expr -> Expr
f (CaseAlternative [Binder]
b [MkUnguarded Expr
e]) = [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder]
b (Expr -> [GuardedExpr]
unguarded (Expr -> Expr
f Expr
e))
underExpr Expr -> Expr
_ CaseAlternative
_ = forall a. HasCallStack => String -> a
internalError String
"underExpr: expected unguarded alternative"
toRepTy :: [SourceType] -> SourceType
toRepTy :: [SourceType] -> SourceType
toRepTy [] = Qualified (ProperName 'TypeName) -> SourceType
srcTypeConstructor Qualified (ProperName 'TypeName)
Libs.NoConstructors
toRepTy [SourceType
only] = SourceType
only
toRepTy [SourceType]
ctors = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\SourceType
f -> SourceType -> SourceType -> SourceType
srcTypeApp (SourceType -> SourceType -> SourceType
srcTypeApp (Qualified (ProperName 'TypeName) -> SourceType
srcTypeConstructor Qualified (ProperName 'TypeName)
Libs.Sum) SourceType
f)) [SourceType]
ctors
checkIsWildcard :: MonadError MultipleErrors m => SourceSpan -> ProperName 'TypeName -> SourceType -> m ()
checkIsWildcard :: forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan -> ProperName 'TypeName -> SourceType -> m ()
checkIsWildcard SourceSpan
_ ProperName 'TypeName
_ (TypeWildcard SourceAnn
_ WildcardData
UnnamedWildcard) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkIsWildcard SourceSpan
ss ProperName 'TypeName
tyConNm SourceType
_ =
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss forall a b. (a -> b) -> a -> b
$ ProperName 'TypeName -> SimpleErrorMessage
ExpectedWildcard ProperName 'TypeName
tyConNm
deriveNewtype
:: forall m
. MonadError MultipleErrors m
=> Declaration
-> [SourceType]
-> m ([Declaration], SourceType)
deriveNewtype :: forall (m :: * -> *).
MonadError MultipleErrors m =>
Declaration -> [SourceType] -> m ([Declaration], SourceType)
deriveNewtype Declaration
tyCon [SourceType]
tyConArgs =
case Declaration
tyCon of
DataDeclaration (SourceSpan
ss', [Comment]
_) DataDeclType
Data ProperName 'TypeName
name [(Text, Maybe SourceType)]
_ [DataConstructorDeclaration]
_ ->
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss' forall a b. (a -> b) -> a -> b
$ ProperName 'TypeName -> SimpleErrorMessage
CannotDeriveNewtypeForData ProperName 'TypeName
name
DataDeclaration SourceAnn
_ DataDeclType
Newtype ProperName 'TypeName
name [(Text, Maybe SourceType)]
args [DataConstructorDeclaration]
dctors -> do
(DataConstructorDeclaration
_, (Ident
_, SourceType
ty)) <- forall (m :: * -> *).
MonadError MultipleErrors m =>
ProperName 'TypeName
-> [DataConstructorDeclaration]
-> m (DataConstructorDeclaration, (Ident, SourceType))
checkNewtype ProperName 'TypeName
name [DataConstructorDeclaration]
dctors
let subst :: [(Text, SourceType)]
subst = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, Maybe SourceType)]
args [SourceType]
tyConArgs
forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. [(Text, Type a)] -> Type a -> Type a
replaceAllTypeVars [(Text, SourceType)]
subst SourceType
ty)
Declaration
_ -> forall a. HasCallStack => String -> a
internalError String
"deriveNewtype: expected DataDeclaration"
findTypeDecl
:: (MonadError MultipleErrors m)
=> SourceSpan
-> ProperName 'TypeName
-> [Declaration]
-> m Declaration
findTypeDecl :: forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceSpan
-> ProperName 'TypeName -> [Declaration] -> m Declaration
findTypeDecl SourceSpan
ss ProperName 'TypeName
tyConNm = forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
note (SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss forall a b. (a -> b) -> a -> b
$ ProperName 'TypeName -> SimpleErrorMessage
CannotFindDerivingType ProperName 'TypeName
tyConNm) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Declaration -> Bool
isTypeDecl
where
isTypeDecl :: Declaration -> Bool
isTypeDecl :: Declaration -> Bool
isTypeDecl (DataDeclaration SourceAnn
_ DataDeclType
_ ProperName 'TypeName
nm [(Text, Maybe SourceType)]
_ [DataConstructorDeclaration]
_) = ProperName 'TypeName
nm forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
tyConNm
isTypeDecl Declaration
_ = Bool
False