-- | This module implements the generic deriving elaboration that takes place during desugaring.
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)

-- | Elaborates deriving instance declarations by code generation.
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

-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,
-- elaborates that into an instance declaration via code generation.
--
-- More instance deriving happens during type checking. The instances
-- derived here are special for two reasons:
-- * they depend only on the structure of the data, not types; and
-- * they expect wildcard types from the user and generate type expressions
--   to replace them.
--
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 =
                   -- If there are no cases, spin
                   [ 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