-- |
-- 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
import           Control.Monad.Supply.Class
import           Data.Graph
import           Data.List (find, partition)
import           Data.List.NonEmpty (nonEmpty)
import qualified Data.Map as M
import           Data.Maybe (catMaybes, mapMaybe, isJust)
import qualified Data.List.NonEmpty as NEL
import qualified Data.Set as S
import           Data.Text (Text)
import           Data.Traversable (for)
import qualified Language.PureScript.Constants.Prim as C
import           Language.PureScript.Crash
import           Language.PureScript.Environment
import           Language.PureScript.Errors hiding (isExported, nonEmpty)
import           Language.PureScript.Externs
import           Language.PureScript.Label (Label(..))
import           Language.PureScript.Names
import           Language.PureScript.PSString (mkString)
import           Language.PureScript.Sugar.CaseDeclarations
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.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.PrimCoerce) 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.PrimRow) 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.PrimRowList) 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.PrimSymbol) 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.PrimInt) 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.PrimTypeError) 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
  ]