-- |
-- This module implements the desugaring pass which creates newtypes for type class dictionaries
-- and value declarations for type class instances.
--
module Language.PureScript.Sugar.TypeClasses
  ( desugarTypeClasses
  , typeClassMemberName
  , superClassDictionaryNames
  ) where

import Prelude

import Control.Arrow (first, second)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State (MonadState(..), StateT, evalStateT, modify)
import Control.Monad.Supply.Class (MonadSupply)
import Data.Graph (SCC(..), stronglyConnComp)
import Data.List (find, partition)
import Data.List.NonEmpty (nonEmpty)
import Data.Map qualified as M
import Data.Maybe (catMaybes, mapMaybe, isJust)
import Data.List.NonEmpty qualified as NEL
import Data.Set qualified as S
import Data.Text (Text)
import Data.Traversable (for)
import Language.PureScript.Constants.Prim qualified as C
import Language.PureScript.Crash (internalError)
import Language.PureScript.Environment (DataDeclType(..), NameKind(..), TypeClassData(..), dictTypeName, function, makeTypeClassData, primClasses, primCoerceClasses, primIntClasses, primRowClasses, primRowListClasses, primSymbolClasses, primTypeErrorClasses, tyRecord)
import Language.PureScript.Errors hiding (isExported, nonEmpty)
import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..))
import Language.PureScript.Label (Label(..))
import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify, runIdent)
import Language.PureScript.PSString (mkString)
import Language.PureScript.Sugar.CaseDeclarations (desugarCases)
import Language.PureScript.TypeClassDictionaries (superclassName)
import Language.PureScript.Types

type MemberMap = M.Map (ModuleName, ProperName 'ClassName) TypeClassData

type Desugar = StateT MemberMap

-- |
-- Add type synonym declarations for type class dictionary types, and value declarations for type class
-- instance dictionary expressions.
--
desugarTypeClasses
  :: (MonadSupply m, MonadError MultipleErrors m)
  => [ExternsFile]
  -> Module
  -> m Module
desugarTypeClasses :: forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
[ExternsFile] -> Module -> m Module
desugarTypeClasses [ExternsFile]
externs = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT MemberMap
initialState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
Module -> Desugar m Module
desugarModule
  where
  initialState :: MemberMap
  initialState :: MemberMap
initialState =
    forall a. Monoid a => [a] -> a
mconcat
      [ forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (forall a. ModuleName -> Qualified a -> (ModuleName, a)
qualify ModuleName
C.M_Prim) Map (Qualified (ProperName 'ClassName)) TypeClassData
primClasses
      , forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (forall a. ModuleName -> Qualified a -> (ModuleName, a)
qualify ModuleName
C.M_Prim_Coerce) Map (Qualified (ProperName 'ClassName)) TypeClassData
primCoerceClasses
      , forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (forall a. ModuleName -> Qualified a -> (ModuleName, a)
qualify ModuleName
C.M_Prim_Row) Map (Qualified (ProperName 'ClassName)) TypeClassData
primRowClasses
      , forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (forall a. ModuleName -> Qualified a -> (ModuleName, a)
qualify ModuleName
C.M_Prim_RowList) Map (Qualified (ProperName 'ClassName)) TypeClassData
primRowListClasses
      , forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (forall a. ModuleName -> Qualified a -> (ModuleName, a)
qualify ModuleName
C.M_Prim_Symbol) Map (Qualified (ProperName 'ClassName)) TypeClassData
primSymbolClasses
      , forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (forall a. ModuleName -> Qualified a -> (ModuleName, a)
qualify ModuleName
C.M_Prim_Int) Map (Qualified (ProperName 'ClassName)) TypeClassData
primIntClasses
      , forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (forall a. ModuleName -> Qualified a -> (ModuleName, a)
qualify ModuleName
C.M_Prim_TypeError) Map (Qualified (ProperName 'ClassName)) TypeClassData
primTypeErrorClasses
      , forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([ExternsFile]
externs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ExternsFile{[DeclarationRef]
[ExternsDeclaration]
[ExternsTypeFixity]
[ExternsFixity]
[ExternsImport]
Text
SourceSpan
ModuleName
efSourceSpan :: ExternsFile -> SourceSpan
efDeclarations :: ExternsFile -> [ExternsDeclaration]
efTypeFixities :: ExternsFile -> [ExternsTypeFixity]
efFixities :: ExternsFile -> [ExternsFixity]
efImports :: ExternsFile -> [ExternsImport]
efExports :: ExternsFile -> [DeclarationRef]
efModuleName :: ExternsFile -> ModuleName
efVersion :: ExternsFile -> Text
efSourceSpan :: SourceSpan
efDeclarations :: [ExternsDeclaration]
efTypeFixities :: [ExternsTypeFixity]
efFixities :: [ExternsFixity]
efImports :: [ExternsImport]
efExports :: [DeclarationRef]
efModuleName :: ModuleName
efVersion :: Text
..} -> forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (ModuleName
-> ExternsDeclaration
-> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData)
fromExternsDecl ModuleName
efModuleName) [ExternsDeclaration]
efDeclarations)
      ]

  fromExternsDecl
    :: ModuleName
    -> ExternsDeclaration
    -> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData)
  fromExternsDecl :: ModuleName
-> ExternsDeclaration
-> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData)
fromExternsDecl ModuleName
mn (EDClass ProperName 'ClassName
name [(Text, Maybe SourceType)]
args [(Ident, SourceType)]
members [SourceConstraint]
implies [FunctionalDependency]
deps Bool
tcIsEmpty) = forall a. a -> Maybe a
Just ((ModuleName
mn, ProperName 'ClassName
name), TypeClassData
typeClass) where
    typeClass :: TypeClassData
typeClass = [(Text, Maybe SourceType)]
-> [(Ident, SourceType)]
-> [SourceConstraint]
-> [FunctionalDependency]
-> Bool
-> TypeClassData
makeTypeClassData [(Text, Maybe SourceType)]
args [(Ident, SourceType)]
members [SourceConstraint]
implies [FunctionalDependency]
deps Bool
tcIsEmpty
  fromExternsDecl ModuleName
_ ExternsDeclaration
_ = forall a. Maybe a
Nothing

desugarModule
  :: (MonadSupply m, MonadError MultipleErrors m)
  => Module
  -> Desugar m Module
desugarModule :: forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
Module -> Desugar m Module
desugarModule (Module SourceSpan
ss [Comment]
coms ModuleName
name [Declaration]
decls (Just [DeclarationRef]
exps)) = do
  let ([Declaration]
classDecls, [Declaration]
restDecls) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Declaration -> Bool
isTypeClassDecl [Declaration]
decls
      classVerts :: [(Declaration, Qualified (ProperName 'ClassName),
  [Qualified (ProperName 'ClassName)])]
classVerts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Declaration
d -> (Declaration
d, Declaration -> Qualified (ProperName 'ClassName)
classDeclName Declaration
d, Declaration -> [Qualified (ProperName 'ClassName)]
superClassesNames Declaration
d)) [Declaration]
classDecls
  ([Maybe DeclarationRef]
classNewExpss, [[Declaration]]
classDeclss) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b.
MonadError MultipleErrors m =>
[a] -> (a -> m b) -> m [b]
parU (forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp [(Declaration, Qualified (ProperName 'ClassName),
  [Qualified (ProperName 'ClassName)])]
classVerts) (forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
ModuleName
-> [DeclarationRef]
-> SCC Declaration
-> Desugar m (Maybe DeclarationRef, [Declaration])
desugarClassDecl ModuleName
name [DeclarationRef]
exps)
  ([Maybe DeclarationRef]
restNewExpss, [[Declaration]]
restDeclss) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b.
MonadError MultipleErrors m =>
[a] -> (a -> m b) -> m [b]
parU [Declaration]
restDecls (forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
ModuleName
-> [DeclarationRef]
-> Declaration
-> Desugar m (Maybe DeclarationRef, [Declaration])
desugarDecl ModuleName
name [DeclarationRef]
exps)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceSpan
-> [Comment]
-> ModuleName
-> [Declaration]
-> Maybe [DeclarationRef]
-> Module
Module SourceSpan
ss [Comment]
coms ModuleName
name (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
restDeclss forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
classDeclss) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ([DeclarationRef]
exps forall a. [a] -> [a] -> [a]
++ forall a. [Maybe a] -> [a]
catMaybes [Maybe DeclarationRef]
restNewExpss forall a. [a] -> [a] -> [a]
++ forall a. [Maybe a] -> [a]
catMaybes [Maybe DeclarationRef]
classNewExpss)
  where
  desugarClassDecl :: (MonadSupply m, MonadError MultipleErrors m)
    => ModuleName
    -> [DeclarationRef]
    -> SCC Declaration
    -> Desugar m (Maybe DeclarationRef, [Declaration])
  desugarClassDecl :: forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
ModuleName
-> [DeclarationRef]
-> SCC Declaration
-> Desugar m (Maybe DeclarationRef, [Declaration])
desugarClassDecl ModuleName
name' [DeclarationRef]
exps' (AcyclicSCC Declaration
d) = forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
ModuleName
-> [DeclarationRef]
-> Declaration
-> Desugar m (Maybe DeclarationRef, [Declaration])
desugarDecl ModuleName
name' [DeclarationRef]
exps' Declaration
d
  desugarClassDecl ModuleName
_ [DeclarationRef]
_ (CyclicSCC [Declaration]
ds')
    | Just NonEmpty Declaration
ds'' <- forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Declaration]
ds' = 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' (Declaration -> SourceSpan
declSourceSpan (forall a. NonEmpty a -> a
NEL.head NonEmpty Declaration
ds'')) forall a b. (a -> b) -> a -> b
$ NonEmpty (Qualified (ProperName 'ClassName)) -> SimpleErrorMessage
CycleInTypeClassDeclaration (forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NEL.map Declaration -> Qualified (ProperName 'ClassName)
classDeclName NonEmpty Declaration
ds'')
    | Bool
otherwise = forall a. HasCallStack => String -> a
internalError String
"desugarClassDecl: empty CyclicSCC"

  superClassesNames :: Declaration -> [Qualified (ProperName 'ClassName)]
  superClassesNames :: Declaration -> [Qualified (ProperName 'ClassName)]
superClassesNames (TypeClassDeclaration SourceAnn
_ ProperName 'ClassName
_ [(Text, Maybe SourceType)]
_ [SourceConstraint]
implies [FunctionalDependency]
_ [Declaration]
_) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SourceConstraint -> Qualified (ProperName 'ClassName)
constraintName [SourceConstraint]
implies
  superClassesNames Declaration
_ = []

  constraintName :: SourceConstraint -> Qualified (ProperName 'ClassName)
  constraintName :: SourceConstraint -> Qualified (ProperName 'ClassName)
constraintName (Constraint SourceAnn
_ Qualified (ProperName 'ClassName)
cName [SourceType]
_ [SourceType]
_ Maybe ConstraintData
_) = Qualified (ProperName 'ClassName)
cName

  classDeclName :: Declaration -> Qualified (ProperName 'ClassName)
  classDeclName :: Declaration -> Qualified (ProperName 'ClassName)
classDeclName (TypeClassDeclaration SourceAnn
_ ProperName 'ClassName
pn [(Text, Maybe SourceType)]
_ [SourceConstraint]
_ [FunctionalDependency]
_ [Declaration]
_) = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
name) ProperName 'ClassName
pn
  classDeclName Declaration
_ = forall a. HasCallStack => String -> a
internalError String
"Expected TypeClassDeclaration"

desugarModule Module
_ = forall a. HasCallStack => String -> a
internalError String
"Exports should have been elaborated in name desugaring"

{- Desugar type class and type class instance declarations
--
-- Type classes become newtypes for their dictionaries, and type instances become dictionary declarations.
-- Additional values are generated to access individual members of a dictionary, with the appropriate type.
--
-- E.g. the following
--
--   module Test where
--
--   class Foo a where
--     foo :: a -> a
--
--   instance fooString :: Foo String where
--     foo s = s ++ s
--
--   instance fooArray :: (Foo a) => Foo [a] where
--     foo = map foo
--
--   {- Superclasses -}
--
--   class (Foo a) <= Sub a where
--     sub :: a
--
--   instance subString :: Sub String where
--     sub = ""
--
-- becomes:
--
--   <TypeClassDeclaration Foo ...>
--
--   newtype Foo$Dict a = Foo$Dict { foo :: a -> a }
--
--   -- this following type is marked as not needing to be checked so a new Abs
--   -- is not introduced around the definition in type checking, but when
--   -- called the dictionary value is still passed in for the `dict` argument
--   foo :: forall a. (Foo$Dict a) => a -> a
--   foo (Foo$Dict dict) = dict.foo
--
--   fooString :: Foo$Dict String
--   fooString = Foo$Dict { foo: \s -> s ++ s }
--
--   fooArray :: forall a. (Foo$Dict a) => Foo$Dict [a]
--   fooArray = Foo$Dict { foo: map foo }
--
--   {- Superclasses -}
--
--   <TypeClassDeclaration Sub ...>
--
--   newtype Sub$Dict a = Sub$Dict { sub :: a
--                                 , "Foo0" :: {} -> Foo$Dict a
--                                 }
--
--   -- As with `foo` above, this type is unchecked at the declaration
--   sub :: forall a. (Sub$Dict a) => a
--   sub (Sub$Dict dict) = dict.sub
--
--   subString :: Sub$Dict String
--   subString = Sub$Dict { sub: "",
--                        , "Foo0": \_ -> <DeferredDictionary Foo String>
--                        }
--
-- and finally as the generated javascript:
--
--   var foo = function (dict) {
--       return dict.foo;
--   };
--
--   var fooString = {
--      foo: function (s) {
--          return s + s;
--      }
--   };
--
--   var fooArray = function (dictFoo) {
--       return {
--           foo: map(foo(dictFoo))
--       };
--   };
--
--   var sub = function (dict) {
--       return dict.sub;
--   };
--
--   var subString = {
--       sub: "",
--       Foo0: function () {
--           return fooString;
--       }
--   };
-}
desugarDecl
  :: (MonadSupply m, MonadError MultipleErrors m)
  => ModuleName
  -> [DeclarationRef]
  -> Declaration
  -> Desugar m (Maybe DeclarationRef, [Declaration])
desugarDecl :: forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
ModuleName
-> [DeclarationRef]
-> Declaration
-> Desugar m (Maybe DeclarationRef, [Declaration])
desugarDecl ModuleName
mn [DeclarationRef]
exps = Declaration
-> StateT MemberMap m (Maybe DeclarationRef, [Declaration])
go
  where
  go :: Declaration
-> StateT MemberMap m (Maybe DeclarationRef, [Declaration])
go d :: Declaration
d@(TypeClassDeclaration SourceAnn
sa ProperName 'ClassName
name [(Text, Maybe SourceType)]
args [SourceConstraint]
implies [FunctionalDependency]
deps [Declaration]
members) = do
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (ModuleName
mn, ProperName 'ClassName
name) ([(Text, Maybe SourceType)]
-> [(Ident, SourceType)]
-> [SourceConstraint]
-> [FunctionalDependency]
-> Bool
-> TypeClassData
makeTypeClassData [(Text, Maybe SourceType)]
args (forall a b. (a -> b) -> [a] -> [b]
map Declaration -> (Ident, SourceType)
memberToNameAndType [Declaration]
members) [SourceConstraint]
implies [FunctionalDependency]
deps Bool
False))
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, Declaration
d forall a. a -> [a] -> [a]
: SourceAnn
-> ProperName 'ClassName
-> [(Text, Maybe SourceType)]
-> [SourceConstraint]
-> [Declaration]
-> Declaration
typeClassDictionaryDeclaration SourceAnn
sa ProperName 'ClassName
name [(Text, Maybe SourceType)]
args [SourceConstraint]
implies [Declaration]
members forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (ModuleName
-> ProperName 'ClassName
-> [(Text, Maybe SourceType)]
-> Declaration
-> Declaration
typeClassMemberToDictionaryAccessor ModuleName
mn ProperName 'ClassName
name [(Text, Maybe SourceType)]
args) [Declaration]
members)
  go (TypeInstanceDeclaration SourceAnn
sa SourceAnn
na ChainId
chainId Integer
idx Either Text Ident
name [SourceConstraint]
deps Qualified (ProperName 'ClassName)
className [SourceType]
tys TypeInstanceBody
body) = do
    Ident
name' <- forall (m :: * -> *).
MonadSupply m =>
Either Text Ident -> Desugar m Ident
desugarInstName Either Text Ident
name
    let d :: Declaration
d = SourceAnn
-> SourceAnn
-> ChainId
-> Integer
-> Either Text Ident
-> [SourceConstraint]
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> TypeInstanceBody
-> Declaration
TypeInstanceDeclaration SourceAnn
sa SourceAnn
na ChainId
chainId Integer
idx (forall a b. b -> Either a b
Right Ident
name') [SourceConstraint]
deps Qualified (ProperName 'ClassName)
className [SourceType]
tys TypeInstanceBody
body
    let explicitOrNot :: Either Expr [Declaration]
explicitOrNot = case TypeInstanceBody
body of
          TypeInstanceBody
DerivedInstance -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> InstanceDerivationStrategy -> Expr
DerivedInstancePlaceholder Qualified (ProperName 'ClassName)
className InstanceDerivationStrategy
KnownClassStrategy
          TypeInstanceBody
NewtypeInstance -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ClassName)
-> InstanceDerivationStrategy -> Expr
DerivedInstancePlaceholder Qualified (ProperName 'ClassName)
className InstanceDerivationStrategy
NewtypeStrategy
          ExplicitInstance [Declaration]
members -> forall a b. b -> Either a b
Right [Declaration]
members
    Declaration
dictDecl <- case Either Expr [Declaration]
explicitOrNot of
      Right [Declaration]
members
        | Qualified (ProperName 'ClassName)
className forall a. Eq a => a -> a -> Bool
== Qualified (ProperName 'ClassName)
C.Coercible ->
          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' (forall a b. (a, b) -> a
fst SourceAnn
sa) forall a b. (a -> b) -> a -> b
$ [SourceType] -> SimpleErrorMessage
InvalidCoercibleInstanceDeclaration [SourceType]
tys
        | Bool
otherwise -> do
          [Declaration]
desugared <- forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
[Declaration] -> m [Declaration]
desugarCases [Declaration]
members
          forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceAnn
-> Ident
-> ModuleName
-> [SourceConstraint]
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> [Declaration]
-> Desugar m Declaration
typeInstanceDictionaryDeclaration SourceAnn
sa Ident
name' ModuleName
mn [SourceConstraint]
deps Qualified (ProperName 'ClassName)
className [SourceType]
tys [Declaration]
desugared
      Left Expr
dict ->
        let
          dictTy :: SourceType
dictTy = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl SourceType -> SourceType -> SourceType
srcTypeApp (Qualified (ProperName 'TypeName) -> SourceType
srcTypeConstructor (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: ProperNameType). ProperName a -> ProperName a
dictTypeName) Qualified (ProperName 'ClassName)
className)) [SourceType]
tys
          constrainedTy :: SourceType
constrainedTy = forall a. Type a -> Type a
quantify (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SourceConstraint -> SourceType -> SourceType
srcConstrainedType SourceType
dictTy [SourceConstraint]
deps)
        in
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl SourceAnn
sa Ident
name' NameKind
Private [] [Expr -> GuardedExpr
MkUnguarded (Bool -> Expr -> SourceType -> Expr
TypedValue Bool
True Expr
dict SourceType
constrainedTy)]
    forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> Maybe DeclarationRef
expRef Ident
name' Qualified (ProperName 'ClassName)
className [SourceType]
tys, [Declaration
d, Declaration
dictDecl])
  go Declaration
other = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, [Declaration
other])

  -- Completes the name generation for type class instances that do not have
  -- a unique name defined in source code.
  desugarInstName :: MonadSupply m => Either Text Ident -> Desugar m Ident
  desugarInstName :: forall (m :: * -> *).
MonadSupply m =>
Either Text Ident -> Desugar m Ident
desugarInstName = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *). MonadSupply m => Text -> m Ident
freshIdent forall (f :: * -> *) a. Applicative f => a -> f a
pure

  expRef :: Ident -> Qualified (ProperName 'ClassName) -> [SourceType] -> Maybe DeclarationRef
  expRef :: Ident
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> Maybe DeclarationRef
expRef Ident
name Qualified (ProperName 'ClassName)
className [SourceType]
tys
    | Qualified (ProperName 'ClassName) -> Bool
isExportedClass Qualified (ProperName 'ClassName)
className Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Qualified (ProperName 'TypeName) -> Bool
isExportedType (SourceType -> [Qualified (ProperName 'TypeName)]
getConstructors forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
`concatMap` [SourceType]
tys) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SourceSpan -> Ident -> NameSource -> DeclarationRef
TypeInstanceRef SourceSpan
genSpan Ident
name NameSource
UserNamed
    | Bool
otherwise = forall a. Maybe a
Nothing

  isExportedClass :: Qualified (ProperName 'ClassName) -> Bool
  isExportedClass :: Qualified (ProperName 'ClassName) -> Bool
isExportedClass = forall (a :: ProperNameType).
(ProperName a -> [DeclarationRef] -> Bool)
-> Qualified (ProperName a) -> Bool
isExported (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> ProperName 'ClassName -> DeclarationRef
TypeClassRef SourceSpan
genSpan)

  isExportedType :: Qualified (ProperName 'TypeName) -> Bool
  isExportedType :: Qualified (ProperName 'TypeName) -> Bool
isExportedType = forall (a :: ProperNameType).
(ProperName a -> [DeclarationRef] -> Bool)
-> Qualified (ProperName a) -> Bool
isExported forall a b. (a -> b) -> a -> b
$ \ProperName 'TypeName
pn -> forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (ProperName 'TypeName -> DeclarationRef -> Bool
matchesTypeRef ProperName 'TypeName
pn)

  isExported
    :: (ProperName a -> [DeclarationRef] -> Bool)
    -> Qualified (ProperName a)
    -> Bool
  isExported :: forall (a :: ProperNameType).
(ProperName a -> [DeclarationRef] -> Bool)
-> Qualified (ProperName a) -> Bool
isExported ProperName a -> [DeclarationRef] -> Bool
test (Qualified (ByModuleName ModuleName
mn') ProperName a
pn) = ModuleName
mn forall a. Eq a => a -> a -> Bool
/= ModuleName
mn' Bool -> Bool -> Bool
|| ProperName a -> [DeclarationRef] -> Bool
test ProperName a
pn [DeclarationRef]
exps
  isExported ProperName a -> [DeclarationRef] -> Bool
_ Qualified (ProperName a)
_ = forall a. HasCallStack => String -> a
internalError String
"Names should have been qualified in name desugaring"

  matchesTypeRef :: ProperName 'TypeName -> DeclarationRef -> Bool
  matchesTypeRef :: ProperName 'TypeName -> DeclarationRef -> Bool
matchesTypeRef ProperName 'TypeName
pn (TypeRef SourceSpan
_ ProperName 'TypeName
pn' Maybe [ProperName 'ConstructorName]
_) = ProperName 'TypeName
pn forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
pn'
  matchesTypeRef ProperName 'TypeName
_ DeclarationRef
_ = Bool
False

  getConstructors :: SourceType -> [Qualified (ProperName 'TypeName)]
  getConstructors :: SourceType -> [Qualified (ProperName 'TypeName)]
getConstructors = forall r a. (r -> r -> r) -> (Type a -> r) -> Type a -> r
everythingOnTypes forall a. [a] -> [a] -> [a]
(++) forall {a}. Type a -> [Qualified (ProperName 'TypeName)]
getConstructor
    where
    getConstructor :: Type a -> [Qualified (ProperName 'TypeName)]
getConstructor (TypeConstructor a
_ Qualified (ProperName 'TypeName)
tcname) = [Qualified (ProperName 'TypeName)
tcname]
    getConstructor Type a
_ = []

  genSpan :: SourceSpan
  genSpan :: SourceSpan
genSpan = String -> SourceSpan
internalModuleSourceSpan String
"<generated>"

memberToNameAndType :: Declaration -> (Ident, SourceType)
memberToNameAndType :: Declaration -> (Ident, SourceType)
memberToNameAndType (TypeDeclaration TypeDeclarationData
td) = TypeDeclarationData -> (Ident, SourceType)
unwrapTypeDeclaration TypeDeclarationData
td
memberToNameAndType Declaration
_ = forall a. HasCallStack => String -> a
internalError String
"Invalid declaration in type class definition"

typeClassDictionaryDeclaration
  :: SourceAnn
  -> ProperName 'ClassName
  -> [(Text, Maybe SourceType)]
  -> [SourceConstraint]
  -> [Declaration]
  -> Declaration
typeClassDictionaryDeclaration :: SourceAnn
-> ProperName 'ClassName
-> [(Text, Maybe SourceType)]
-> [SourceConstraint]
-> [Declaration]
-> Declaration
typeClassDictionaryDeclaration SourceAnn
sa ProperName 'ClassName
name [(Text, Maybe SourceType)]
args [SourceConstraint]
implies [Declaration]
members =
  let superclassTypes :: [(Text, SourceType)]
superclassTypes = forall a. [Constraint a] -> [Text]
superClassDictionaryNames [SourceConstraint]
implies forall a b. [a] -> [b] -> [(a, b)]
`zip`
        [ SourceType -> SourceType -> SourceType
function SourceType
unit (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl SourceType -> SourceType -> SourceType
srcTypeApp (Qualified (ProperName 'TypeName) -> SourceType
srcTypeConstructor (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: ProperNameType). ProperName a -> ProperName a
dictTypeName) Qualified (ProperName 'ClassName)
superclass)) [SourceType]
tyArgs)
        | (Constraint SourceAnn
_ Qualified (ProperName 'ClassName)
superclass [SourceType]
_ [SourceType]
tyArgs Maybe ConstraintData
_) <- [SourceConstraint]
implies
        ]
      members' :: [(Text, SourceType)]
members' = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Ident -> Text
runIdent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> (Ident, SourceType)
memberToNameAndType) [Declaration]
members
      mtys :: [(Text, SourceType)]
mtys = [(Text, SourceType)]
members' forall a. [a] -> [a] -> [a]
++ [(Text, SourceType)]
superclassTypes
      toRowListItem :: (Text, SourceType) -> RowListItem SourceAnn
toRowListItem (Text
l, SourceType
t) = Label -> SourceType -> RowListItem SourceAnn
srcRowListItem (PSString -> Label
Label forall a b. (a -> b) -> a -> b
$ Text -> PSString
mkString Text
l) SourceType
t
      ctor :: DataConstructorDeclaration
ctor = SourceAnn
-> ProperName 'ConstructorName
-> [(Ident, SourceType)]
-> DataConstructorDeclaration
DataConstructorDeclaration SourceAnn
sa (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName forall a b. (a -> b) -> a -> b
$ forall (a :: ProperNameType). ProperName a -> ProperName a
dictTypeName ProperName 'ClassName
name)
        [(Text -> Ident
Ident Text
"dict", SourceType -> SourceType -> SourceType
srcTypeApp SourceType
tyRecord forall a b. (a -> b) -> a -> b
$ forall a. ([RowListItem a], Type a) -> Type a
rowFromList (forall a b. (a -> b) -> [a] -> [b]
map (Text, SourceType) -> RowListItem SourceAnn
toRowListItem [(Text, SourceType)]
mtys, SourceType
srcREmpty))]
  in SourceAnn
-> DataDeclType
-> ProperName 'TypeName
-> [(Text, Maybe SourceType)]
-> [DataConstructorDeclaration]
-> Declaration
DataDeclaration SourceAnn
sa DataDeclType
Newtype (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName forall a b. (a -> b) -> a -> b
$ forall (a :: ProperNameType). ProperName a -> ProperName a
dictTypeName ProperName 'ClassName
name) [(Text, Maybe SourceType)]
args [DataConstructorDeclaration
ctor]

typeClassMemberToDictionaryAccessor
  :: ModuleName
  -> ProperName 'ClassName
  -> [(Text, Maybe SourceType)]
  -> Declaration
  -> Declaration
typeClassMemberToDictionaryAccessor :: ModuleName
-> ProperName 'ClassName
-> [(Text, Maybe SourceType)]
-> Declaration
-> Declaration
typeClassMemberToDictionaryAccessor ModuleName
mn ProperName 'ClassName
name [(Text, Maybe SourceType)]
args (TypeDeclaration (TypeDeclarationData sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) Ident
ident SourceType
ty)) =
  let className :: Qualified (ProperName 'ClassName)
className = forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn) ProperName 'ClassName
name
      dictIdent :: Ident
dictIdent = Text -> Ident
Ident Text
"dict"
      dictObjIdent :: Ident
dictObjIdent = Text -> Ident
Ident Text
"v"
      ctor :: Binder
ctor = SourceSpan
-> Qualified (ProperName 'ConstructorName) -> [Binder] -> Binder
ConstructorBinder SourceSpan
ss (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: ProperNameType). ProperName a -> ProperName a
dictTypeName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Qualified (ProperName 'ClassName)
className) [SourceSpan -> Ident -> Binder
VarBinder SourceSpan
ss Ident
dictObjIdent]
      acsr :: Expr
acsr = PSString -> Expr -> Expr
Accessor (Text -> PSString
mkString forall a b. (a -> b) -> a -> b
$ Ident -> Text
runIdent Ident
ident) (SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
ss (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Ident
dictObjIdent))
  in SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl SourceAnn
sa Ident
ident NameKind
Private []
    [Expr -> GuardedExpr
MkUnguarded (
     Bool -> Expr -> SourceType -> Expr
TypedValue Bool
False (Binder -> Expr -> Expr
Abs (SourceSpan -> Ident -> Binder
VarBinder SourceSpan
ss Ident
dictIdent) ([Expr] -> [CaseAlternative] -> Expr
Case [SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
ss forall a b. (a -> b) -> a -> b
$ forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Ident
dictIdent] [[Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
ctor] [Expr -> GuardedExpr
MkUnguarded Expr
acsr]])) forall a b. (a -> b) -> a -> b
$
       forall a. Type a -> Type a
moveQuantifiersToFront (forall a. Type a -> Type a
quantify (SourceConstraint -> SourceType -> SourceType
srcConstrainedType (Qualified (ProperName 'ClassName)
-> [SourceType]
-> [SourceType]
-> Maybe ConstraintData
-> SourceConstraint
srcConstraint Qualified (ProperName 'ClassName)
className [] (forall a b. (a -> b) -> [a] -> [b]
map (Text -> SourceType
srcTypeVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, Maybe SourceType)]
args) forall a. Maybe a
Nothing) SourceType
ty))
    )]
typeClassMemberToDictionaryAccessor ModuleName
_ ProperName 'ClassName
_ [(Text, Maybe SourceType)]
_ Declaration
_ = forall a. HasCallStack => String -> a
internalError String
"Invalid declaration in type class definition"

unit :: SourceType
unit :: SourceType
unit = SourceType -> SourceType -> SourceType
srcTypeApp SourceType
tyRecord SourceType
srcREmpty

typeInstanceDictionaryDeclaration
  :: forall m
   . MonadError MultipleErrors m
  => SourceAnn
  -> Ident
  -> ModuleName
  -> [SourceConstraint]
  -> Qualified (ProperName 'ClassName)
  -> [SourceType]
  -> [Declaration]
  -> Desugar m Declaration
typeInstanceDictionaryDeclaration :: forall (m :: * -> *).
MonadError MultipleErrors m =>
SourceAnn
-> Ident
-> ModuleName
-> [SourceConstraint]
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> [Declaration]
-> Desugar m Declaration
typeInstanceDictionaryDeclaration sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) Ident
name ModuleName
mn [SourceConstraint]
deps Qualified (ProperName 'ClassName)
className [SourceType]
tys [Declaration]
decls =
  forall e (m :: * -> *) a. MonadError e m => (e -> e) -> m a -> m a
rethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (Qualified (ProperName 'ClassName)
-> [SourceType] -> ErrorMessageHint
ErrorInInstance Qualified (ProperName 'ClassName)
className [SourceType]
tys)) forall a b. (a -> b) -> a -> b
$ do
  MemberMap
m <- forall s (m :: * -> *). MonadState s m => m s
get

  -- Lookup the type arguments and member types for the type class
  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 b a. b -> (a -> b) -> Maybe a -> b
maybe (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 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 (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
      forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. ModuleName -> Qualified a -> (ModuleName, a)
qualify ModuleName
mn Qualified (ProperName 'ClassName)
className) MemberMap
m

  -- Replace the type arguments with the appropriate types in the member types
  let memberTypes :: [(Ident, SourceType)]
memberTypes = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall a. [(Text, Type a)] -> Type a -> Type a
replaceAllTypeVars (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, Maybe SourceType)]
typeClassArguments) [SourceType]
tys))) [(Ident, SourceType)]
typeClassMembers

  let declaredMembers :: Set Ident
declaredMembers = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Declaration -> Maybe Ident
declIdent [Declaration]
decls

  case forall a. (a -> Bool) -> [a] -> [a]
filter (\(Ident
ident, SourceType
_) -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Bool
S.member Ident
ident Set Ident
declaredMembers) [(Ident, SourceType)]
memberTypes of
    (Ident, SourceType)
hd : [(Ident, SourceType)]
tl -> 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
$ NonEmpty (Ident, SourceType) -> SimpleErrorMessage
MissingClassMember ((Ident, SourceType)
hd forall a. a -> [a] -> NonEmpty a
NEL.:| [(Ident, SourceType)]
tl)
    [] -> do
      -- Create values for the type instance members
      [(Text, Expr)]
members <- forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Text
typeClassMemberName [Declaration]
decls) 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 ([(Ident, SourceType)] -> Declaration -> Desugar m Expr
memberToValue [(Ident, SourceType)]
memberTypes) [Declaration]
decls

      -- Create the type of the dictionary
      -- The type is a record type, but depending on type instance dependencies, may be constrained.
      -- The dictionary itself is a record literal.
      [Expr]
superclassesDicts <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [SourceConstraint]
typeClassSuperclasses forall a b. (a -> b) -> a -> b
$ \(Constraint SourceAnn
_ Qualified (ProperName 'ClassName)
superclass [SourceType]
_ [SourceType]
suTyArgs Maybe ConstraintData
_) -> do
        let tyArgs :: [SourceType]
tyArgs = forall a b. (a -> b) -> [a] -> [b]
map (forall a. [(Text, Type a)] -> Type a -> Type a
replaceAllTypeVars (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, Maybe SourceType)]
typeClassArguments) [SourceType]
tys)) [SourceType]
suTyArgs
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Binder -> Expr -> Expr
Abs (SourceSpan -> Ident -> Binder
VarBinder SourceSpan
ss Ident
UnusedIdent) (Qualified (ProperName 'ClassName) -> [SourceType] -> Expr
DeferredDictionary Qualified (ProperName 'ClassName)
superclass [SourceType]
tyArgs)
      let superclasses :: [(Text, Expr)]
superclasses = forall a. [Constraint a] -> [Text]
superClassDictionaryNames [SourceConstraint]
typeClassSuperclasses forall a b. [a] -> [b] -> [(a, b)]
`zip` [Expr]
superclassesDicts

      let props :: Expr
props = SourceSpan -> Literal Expr -> Expr
Literal SourceSpan
ss forall a b. (a -> b) -> a -> b
$ forall a. [(PSString, a)] -> Literal a
ObjectLiteral forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Text -> PSString
mkString) ([(Text, Expr)]
members forall a. [a] -> [a] -> [a]
++ [(Text, Expr)]
superclasses)
          dictTy :: SourceType
dictTy = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl SourceType -> SourceType -> SourceType
srcTypeApp (Qualified (ProperName 'TypeName) -> SourceType
srcTypeConstructor (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: ProperNameType). ProperName a -> ProperName a
dictTypeName) Qualified (ProperName 'ClassName)
className)) [SourceType]
tys
          constrainedTy :: SourceType
constrainedTy = forall a. Type a -> Type a
quantify (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SourceConstraint -> SourceType -> SourceType
srcConstrainedType SourceType
dictTy [SourceConstraint]
deps)
          dict :: Expr
dict = Expr -> Expr -> Expr
App (SourceSpan -> Qualified (ProperName 'ConstructorName) -> Expr
Constructor SourceSpan
ss (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: ProperNameType). ProperName a -> ProperName a
dictTypeName) Qualified (ProperName 'ClassName)
className)) Expr
props
          result :: Declaration
result = SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl SourceAnn
sa Ident
name NameKind
Private [] [Expr -> GuardedExpr
MkUnguarded (Bool -> Expr -> SourceType -> Expr
TypedValue Bool
True Expr
dict SourceType
constrainedTy)]
      forall (m :: * -> *) a. Monad m => a -> m a
return Declaration
result

  where

  memberToValue :: [(Ident, SourceType)] -> Declaration -> Desugar m Expr
  memberToValue :: [(Ident, SourceType)] -> Declaration -> Desugar m Expr
memberToValue [(Ident, SourceType)]
tys' (ValueDecl (SourceSpan
ss', [Comment]
_) Ident
ident NameKind
_ [] [MkUnguarded Expr
val]) = do
    SourceType
_ <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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
$ Ident -> Qualified (ProperName 'ClassName) -> SimpleErrorMessage
ExtraneousClassMember Ident
ident Qualified (ProperName 'ClassName)
className) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Ident
ident [(Ident, SourceType)]
tys'
    forall (m :: * -> *) a. Monad m => a -> m a
return Expr
val
  memberToValue [(Ident, SourceType)]
_ Declaration
_ = forall a. HasCallStack => String -> a
internalError String
"Invalid declaration in type instance definition"

declIdent :: Declaration -> Maybe Ident
declIdent :: Declaration -> Maybe Ident
declIdent (ValueDeclaration ValueDeclarationData [GuardedExpr]
vd) = forall a. a -> Maybe a
Just (forall a. ValueDeclarationData a -> Ident
valdeclIdent ValueDeclarationData [GuardedExpr]
vd)
declIdent (TypeDeclaration TypeDeclarationData
td) = forall a. a -> Maybe a
Just (TypeDeclarationData -> Ident
tydeclIdent TypeDeclarationData
td)
declIdent Declaration
_ = forall a. Maybe a
Nothing

typeClassMemberName :: Declaration -> Text
typeClassMemberName :: Declaration -> Text
typeClassMemberName = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
internalError String
"typeClassMemberName: Invalid declaration in type class definition") Ident -> Text
runIdent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> Maybe Ident
declIdent

superClassDictionaryNames :: [Constraint a] -> [Text]
superClassDictionaryNames :: forall a. [Constraint a] -> [Text]
superClassDictionaryNames [Constraint a]
supers =
  [ Qualified (ProperName 'ClassName) -> Integer -> Text
superclassName Qualified (ProperName 'ClassName)
pn Integer
index
  | (Integer
index, Constraint a
_ Qualified (ProperName 'ClassName)
pn [Type a]
_ [Type a]
_ Maybe ConstraintData
_) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [Constraint a]
supers
  ]