{-# LANGUAGE GADTs #-}

-- |
-- Monads for type checking and type inference and associated data types
--
module Language.PureScript.TypeChecker.Monad where

import Prelude

import Control.Arrow (second)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State (MonadState(..), StateT(..), forM_, gets, guard, join, modify, when, (<=<))
import Control.Monad.Writer.Class (MonadWriter(..), censor)

import Data.Maybe (fromMaybe)
import Data.Map qualified as M
import Data.Set qualified as S
import Data.Text (Text, isPrefixOf, unpack)
import Data.List.NonEmpty qualified as NEL

import Language.PureScript.Crash (internalError)
import Language.PureScript.Environment (Environment(..), NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..))
import Language.PureScript.Errors (Context, ErrorMessageHint, ExportSource, Expr, ImportDeclarationType, MultipleErrors, SimpleErrorMessage(..), SourceAnn, SourceSpan(..), addHint, errorMessage, positionedError, rethrow, warnWithPosition)
import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName)
import Language.PureScript.Pretty.Types (prettyPrintType)
import Language.PureScript.Pretty.Values (prettyPrintValue)
import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..))
import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar)
import Text.PrettyPrint.Boxes (render)

newtype UnkLevel = UnkLevel (NEL.NonEmpty Unknown)
  deriving (UnkLevel -> UnkLevel -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnkLevel -> UnkLevel -> Bool
$c/= :: UnkLevel -> UnkLevel -> Bool
== :: UnkLevel -> UnkLevel -> Bool
$c== :: UnkLevel -> UnkLevel -> Bool
Eq, Int -> UnkLevel -> ShowS
[UnkLevel] -> ShowS
UnkLevel -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnkLevel] -> ShowS
$cshowList :: [UnkLevel] -> ShowS
show :: UnkLevel -> String
$cshow :: UnkLevel -> String
showsPrec :: Int -> UnkLevel -> ShowS
$cshowsPrec :: Int -> UnkLevel -> ShowS
Show)

-- This instance differs from the NEL instance in that longer but otherwise
-- equal paths are LT rather than GT. An extended path puts it *before* its root.
instance Ord UnkLevel where
  compare :: UnkLevel -> UnkLevel -> Ordering
compare (UnkLevel NonEmpty Int
a) (UnkLevel NonEmpty Int
b) =
    forall {a}. Ord a => [a] -> [a] -> Ordering
go (forall a. NonEmpty a -> [a]
NEL.toList NonEmpty Int
a) (forall a. NonEmpty a -> [a]
NEL.toList NonEmpty Int
b)
    where
    go :: [a] -> [a] -> Ordering
go [] [] = Ordering
EQ
    go [a]
_  [] = Ordering
LT
    go [] [a]
_  = Ordering
GT
    go (a
x:[a]
xs) (a
y:[a]
ys) =
      forall a. Ord a => a -> a -> Ordering
compare a
x a
y forall a. Semigroup a => a -> a -> a
<> [a] -> [a] -> Ordering
go [a]
xs [a]
ys

-- | A substitution of unification variables for types.
data Substitution = Substitution
  { Substitution -> Map Int SourceType
substType :: M.Map Int SourceType
  -- ^ Type substitution
  , Substitution -> Map Int (UnkLevel, SourceType)
substUnsolved :: M.Map Int (UnkLevel, SourceType)
  -- ^ Unsolved unification variables with their level (scope ordering) and kind
  , Substitution -> Map Int Text
substNames :: M.Map Int Text
  -- ^ The original names of unknowns
  }

insertUnkName :: (MonadState CheckState m) => Unknown -> Text -> m ()
insertUnkName :: forall (m :: * -> *).
MonadState CheckState m =>
Int -> Text -> m ()
insertUnkName Int
u Text
t = do
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\CheckState
s ->
            CheckState
s { checkSubstitution :: Substitution
checkSubstitution =
                  (CheckState -> Substitution
checkSubstitution CheckState
s) { substNames :: Map Int Text
substNames =
                                            forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
u Text
t forall a b. (a -> b) -> a -> b
$ Substitution -> Map Int Text
substNames forall a b. (a -> b) -> a -> b
$ CheckState -> Substitution
checkSubstitution CheckState
s
                                        }
              }
         )

lookupUnkName :: (MonadState CheckState m) => Unknown -> m (Maybe Text)
lookupUnkName :: forall (m :: * -> *).
MonadState CheckState m =>
Int -> m (Maybe Text)
lookupUnkName Int
u = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. Substitution -> Map Int Text
substNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckState -> Substitution
checkSubstitution

-- | An empty substitution
emptySubstitution :: Substitution
emptySubstitution :: Substitution
emptySubstitution = Map Int SourceType
-> Map Int (UnkLevel, SourceType) -> Map Int Text -> Substitution
Substitution forall k a. Map k a
M.empty forall k a. Map k a
M.empty forall k a. Map k a
M.empty

-- | State required for type checking
data CheckState = CheckState
  { CheckState -> Environment
checkEnv :: Environment
  -- ^ The current @Environment@
  , CheckState -> Int
checkNextType :: Int
  -- ^ The next type unification variable
  , CheckState -> Int
checkNextSkolem :: Int
  -- ^ The next skolem variable
  , CheckState -> Int
checkNextSkolemScope :: Int
  -- ^ The next skolem scope constant
  , CheckState -> Maybe ModuleName
checkCurrentModule :: Maybe ModuleName
  -- ^ The current module
  , CheckState
-> [(SourceAnn, ModuleName, ImportDeclarationType,
     Maybe ModuleName,
     Map
       (ProperName 'TypeName)
       ([ProperName 'ConstructorName], ExportSource))]
checkCurrentModuleImports ::
      [ ( SourceAnn
        , ModuleName
        , ImportDeclarationType
        , Maybe ModuleName
        , M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
        )
      ]
  -- ^ The current module imports and their exported types.
  -- Newtype constructors have to be in scope for some Coercible constraints to
  -- be solvable, so we need to know which constructors are imported and whether
  -- they are actually defined in or re-exported from the imported modules.
  , CheckState -> Substitution
checkSubstitution :: Substitution
  -- ^ The current substitution
  , CheckState -> [ErrorMessageHint]
checkHints :: [ErrorMessageHint]
  -- ^ The current error message hint stack.
  -- This goes into state, rather than using 'rethrow',
  -- since this way, we can provide good error messages
  -- during instance resolution.
  , CheckState
-> Set (ModuleName, Qualified (ProperName 'ConstructorName))
checkConstructorImportsForCoercible :: S.Set (ModuleName, Qualified (ProperName 'ConstructorName))
  -- ^ Newtype constructors imports required to solve Coercible constraints.
  -- We have to keep track of them so that we don't emit unused import warnings.
  }

-- | Create an empty @CheckState@
emptyCheckState :: Environment -> CheckState
emptyCheckState :: Environment -> CheckState
emptyCheckState Environment
env = Environment
-> Int
-> Int
-> Int
-> Maybe ModuleName
-> [(SourceAnn, ModuleName, ImportDeclarationType,
     Maybe ModuleName,
     Map
       (ProperName 'TypeName)
       ([ProperName 'ConstructorName], ExportSource))]
-> Substitution
-> [ErrorMessageHint]
-> Set (ModuleName, Qualified (ProperName 'ConstructorName))
-> CheckState
CheckState Environment
env Int
0 Int
0 Int
0 forall a. Maybe a
Nothing [] Substitution
emptySubstitution [] forall a. Monoid a => a
mempty

-- | Unification variables
type Unknown = Int

-- | Temporarily bind a collection of names to values
bindNames
  :: MonadState CheckState m
  => M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
  -> m a
  -> m a
bindNames :: forall (m :: * -> *) a.
MonadState CheckState m =>
Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
-> m a -> m a
bindNames Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
newNames m a
action = do
  CheckState
orig <- forall s (m :: * -> *). MonadState s m => m s
get
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CheckState
st -> CheckState
st { checkEnv :: Environment
checkEnv = (CheckState -> Environment
checkEnv CheckState
st) { names :: Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names = Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
newNames forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` (Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckState -> Environment
checkEnv forall a b. (a -> b) -> a -> b
$ CheckState
st) } }
  a
a <- m a
action
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CheckState
st -> CheckState
st { checkEnv :: Environment
checkEnv = (CheckState -> Environment
checkEnv CheckState
st) { names :: Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names = Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckState -> Environment
checkEnv forall a b. (a -> b) -> a -> b
$ CheckState
orig } }
  forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Temporarily bind a collection of names to types
bindTypes
  :: MonadState CheckState m
  => M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
  -> m a
  -> m a
bindTypes :: forall (m :: * -> *) a.
MonadState CheckState m =>
Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
-> m a -> m a
bindTypes Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
newNames m a
action = do
  CheckState
orig <- forall s (m :: * -> *). MonadState s m => m s
get
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CheckState
st -> CheckState
st { checkEnv :: Environment
checkEnv = (CheckState -> Environment
checkEnv CheckState
st) { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
newNames forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckState -> Environment
checkEnv forall a b. (a -> b) -> a -> b
$ CheckState
st) } }
  a
a <- m a
action
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CheckState
st -> CheckState
st { checkEnv :: Environment
checkEnv = (CheckState -> Environment
checkEnv CheckState
st) { types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types = Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckState -> Environment
checkEnv forall a b. (a -> b) -> a -> b
$ CheckState
orig } }
  forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Temporarily bind a collection of names to types
withScopedTypeVars
  :: (MonadState CheckState m, MonadWriter MultipleErrors m)
  => ModuleName
  -> [(Text, SourceType)]
  -> m a
  -> m a
withScopedTypeVars :: forall (m :: * -> *) a.
(MonadState CheckState m, MonadWriter MultipleErrors m) =>
ModuleName -> [(Text, SourceType)] -> m a -> m a
withScopedTypeVars ModuleName
mn [(Text, SourceType)]
ks m a
ma = do
  CheckState
orig <- forall s (m :: * -> *). MonadState s m => m s
get
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, SourceType)]
ks forall a b. (a -> b) -> a -> b
$ \(Text
name, SourceType
_) ->
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn) (forall (a :: ProperNameType). Text -> ProperName a
ProperName Text
name) forall k a. Ord k => k -> Map k a -> Bool
`M.member` Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types (CheckState -> Environment
checkEnv CheckState
orig)) forall a b. (a -> b) -> a -> b
$
      forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Text -> SimpleErrorMessage
ShadowedTypeVar Text
name
  forall (m :: * -> *) a.
MonadState CheckState m =>
Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
-> m a -> m a
bindTypes (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b. (a -> b) -> [a] -> [b]
map (\(Text
name, SourceType
k) -> (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn) (forall (a :: ProperNameType). Text -> ProperName a
ProperName Text
name), (SourceType
k, TypeKind
ScopedTypeVar))) [(Text, SourceType)]
ks)) m a
ma

withErrorMessageHint
  :: (MonadState CheckState m, MonadError MultipleErrors m)
  => ErrorMessageHint
  -> m a
  -> m a
withErrorMessageHint :: forall (m :: * -> *) a.
(MonadState CheckState m, MonadError MultipleErrors m) =>
ErrorMessageHint -> m a -> m a
withErrorMessageHint ErrorMessageHint
hint m a
action = do
  CheckState
orig <- forall s (m :: * -> *). MonadState s m => m s
get
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CheckState
st -> CheckState
st { checkHints :: [ErrorMessageHint]
checkHints = ErrorMessageHint
hint forall a. a -> [a] -> [a]
: CheckState -> [ErrorMessageHint]
checkHints CheckState
st }
  -- Need to use 'rethrow' anyway, since we have to handle regular errors
  a
a <- forall e (m :: * -> *) a. MonadError e m => (e -> e) -> m a -> m a
rethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint ErrorMessageHint
hint) m a
action
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CheckState
st -> CheckState
st { checkHints :: [ErrorMessageHint]
checkHints = CheckState -> [ErrorMessageHint]
checkHints CheckState
orig }
  forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | These hints are added at the front, so the most nested hint occurs
-- at the front, but the simplifier assumes the reverse order.
getHints :: MonadState CheckState m => m [ErrorMessageHint]
getHints :: forall (m :: * -> *).
MonadState CheckState m =>
m [ErrorMessageHint]
getHints = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckState -> [ErrorMessageHint]
checkHints)

rethrowWithPositionTC
  :: (MonadState CheckState m, MonadError MultipleErrors m)
  => SourceSpan
  -> m a
  -> m a
rethrowWithPositionTC :: forall (m :: * -> *) a.
(MonadState CheckState m, MonadError MultipleErrors m) =>
SourceSpan -> m a -> m a
rethrowWithPositionTC SourceSpan
pos = forall (m :: * -> *) a.
(MonadState CheckState m, MonadError MultipleErrors m) =>
ErrorMessageHint -> m a -> m a
withErrorMessageHint (SourceSpan -> ErrorMessageHint
positionedError SourceSpan
pos)

warnAndRethrowWithPositionTC
  :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
  => SourceSpan
  -> m a
  -> m a
warnAndRethrowWithPositionTC :: forall (m :: * -> *) a.
(MonadState CheckState m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
SourceSpan -> m a -> m a
warnAndRethrowWithPositionTC SourceSpan
pos = forall (m :: * -> *) a.
(MonadState CheckState m, MonadError MultipleErrors m) =>
SourceSpan -> m a -> m a
rethrowWithPositionTC SourceSpan
pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadWriter MultipleErrors m =>
SourceSpan -> m a -> m a
warnWithPosition SourceSpan
pos

-- | Temporarily make a collection of type class dictionaries available
withTypeClassDictionaries
  :: MonadState CheckState m
  => [NamedDict]
  -> m a
  -> m a
withTypeClassDictionaries :: forall (m :: * -> *) a.
MonadState CheckState m =>
[NamedDict] -> m a -> m a
withTypeClassDictionaries [NamedDict]
entries m a
action = do
  CheckState
orig <- forall s (m :: * -> *). MonadState s m => m s
get

  let mentries :: Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
mentries =
        forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith forall a. Semigroup a => a -> a -> a
(<>)))
          [ (QualifiedBy
qb, forall k a. k -> a -> Map k a
M.singleton Qualified (ProperName 'ClassName)
className (forall k a. k -> a -> Map k a
M.singleton Qualified Ident
tcdValue (forall (f :: * -> *) a. Applicative f => a -> f a
pure NamedDict
entry)))
          | entry :: NamedDict
entry@TypeClassDictionaryInScope{ tcdValue :: forall v. TypeClassDictionaryInScope v -> v
tcdValue = tcdValue :: Qualified Ident
tcdValue@(Qualified QualifiedBy
qb Ident
_), tcdClassName :: forall v.
TypeClassDictionaryInScope v -> Qualified (ProperName 'ClassName)
tcdClassName = Qualified (ProperName 'ClassName)
className }
              <- [NamedDict]
entries
          ]

  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CheckState
st -> CheckState
st { checkEnv :: Environment
checkEnv = (CheckState -> Environment
checkEnv CheckState
st) { typeClassDictionaries :: Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
typeClassDictionaries = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith forall a. Semigroup a => a -> a -> a
(<>))) (Environment
-> Map
     QualifiedBy
     (Map
        (Qualified (ProperName 'ClassName))
        (Map (Qualified Ident) (NonEmpty NamedDict)))
typeClassDictionaries forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckState -> Environment
checkEnv forall a b. (a -> b) -> a -> b
$ CheckState
st) Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
mentries } }
  a
a <- m a
action
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CheckState
st -> CheckState
st { checkEnv :: Environment
checkEnv = (CheckState -> Environment
checkEnv CheckState
st) { typeClassDictionaries :: Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
typeClassDictionaries = Environment
-> Map
     QualifiedBy
     (Map
        (Qualified (ProperName 'ClassName))
        (Map (Qualified Ident) (NonEmpty NamedDict)))
typeClassDictionaries forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckState -> Environment
checkEnv forall a b. (a -> b) -> a -> b
$ CheckState
orig } }
  forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Get the currently available map of type class dictionaries
getTypeClassDictionaries
  :: (MonadState CheckState m)
  => m (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))))
getTypeClassDictionaries :: forall (m :: * -> *).
MonadState CheckState m =>
m (Map
     QualifiedBy
     (Map
        (Qualified (ProperName 'ClassName))
        (Map (Qualified Ident) (NonEmpty NamedDict))))
getTypeClassDictionaries = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ Environment
-> Map
     QualifiedBy
     (Map
        (Qualified (ProperName 'ClassName))
        (Map (Qualified Ident) (NonEmpty NamedDict)))
typeClassDictionaries forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckState -> Environment
checkEnv

-- | Lookup type class dictionaries in a module.
lookupTypeClassDictionaries
  :: (MonadState CheckState m)
  => QualifiedBy
  -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))
lookupTypeClassDictionaries :: forall (m :: * -> *).
MonadState CheckState m =>
QualifiedBy
-> m (Map
        (Qualified (ProperName 'ClassName))
        (Map (Qualified Ident) (NonEmpty NamedDict)))
lookupTypeClassDictionaries QualifiedBy
mn = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall k a. Map k a
M.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QualifiedBy
mn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment
-> Map
     QualifiedBy
     (Map
        (Qualified (ProperName 'ClassName))
        (Map (Qualified Ident) (NonEmpty NamedDict)))
typeClassDictionaries forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckState -> Environment
checkEnv

-- | Lookup type class dictionaries in a module.
lookupTypeClassDictionariesForClass
  :: (MonadState CheckState m)
  => QualifiedBy
  -> Qualified (ProperName 'ClassName)
  -> m (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))
lookupTypeClassDictionariesForClass :: forall (m :: * -> *).
MonadState CheckState m =>
QualifiedBy
-> Qualified (ProperName 'ClassName)
-> m (Map (Qualified Ident) (NonEmpty NamedDict))
lookupTypeClassDictionariesForClass QualifiedBy
mn Qualified (ProperName 'ClassName)
cn = forall a. a -> Maybe a -> a
fromMaybe forall k a. Map k a
M.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'ClassName)
cn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadState CheckState m =>
QualifiedBy
-> m (Map
        (Qualified (ProperName 'ClassName))
        (Map (Qualified Ident) (NonEmpty NamedDict)))
lookupTypeClassDictionaries QualifiedBy
mn

-- | Temporarily bind a collection of names to local variables
bindLocalVariables
  :: (MonadState CheckState m)
  => [(SourceSpan, Ident, SourceType, NameVisibility)]
  -> m a
  -> m a
bindLocalVariables :: forall (m :: * -> *) a.
MonadState CheckState m =>
[(SourceSpan, Ident, SourceType, NameVisibility)] -> m a -> m a
bindLocalVariables [(SourceSpan, Ident, SourceType, NameVisibility)]
bindings =
  forall (m :: * -> *) a.
MonadState CheckState m =>
Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
-> m a -> m a
bindNames (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [(SourceSpan, Ident, SourceType, NameVisibility)]
bindings forall a b. (a -> b) -> a -> b
$ \(SourceSpan
ss, Ident
name, SourceType
ty, NameVisibility
visibility) -> (forall a. QualifiedBy -> a -> Qualified a
Qualified (SourcePos -> QualifiedBy
BySourcePos forall a b. (a -> b) -> a -> b
$ SourceSpan -> SourcePos
spanStart SourceSpan
ss) Ident
name, (SourceType
ty, NameKind
Private, NameVisibility
visibility)))

-- | Temporarily bind a collection of names to local type variables
bindLocalTypeVariables
  :: (MonadState CheckState m)
  => ModuleName
  -> [(ProperName 'TypeName, SourceType)]
  -> m a
  -> m a
bindLocalTypeVariables :: forall (m :: * -> *) a.
MonadState CheckState m =>
ModuleName -> [(ProperName 'TypeName, SourceType)] -> m a -> m a
bindLocalTypeVariables ModuleName
moduleName [(ProperName 'TypeName, SourceType)]
bindings =
  forall (m :: * -> *) a.
MonadState CheckState m =>
Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
-> m a -> m a
bindTypes (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [(ProperName 'TypeName, SourceType)]
bindings forall a b. (a -> b) -> a -> b
$ \(ProperName 'TypeName
pn, SourceType
kind) -> (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
moduleName) ProperName 'TypeName
pn, (SourceType
kind, TypeKind
LocalTypeVariable)))

-- | Update the visibility of all names to Defined
makeBindingGroupVisible :: (MonadState CheckState m) => m ()
makeBindingGroupVisible :: forall (m :: * -> *). MonadState CheckState m => m ()
makeBindingGroupVisible = forall (m :: * -> *).
MonadState CheckState m =>
(Environment -> Environment) -> m ()
modifyEnv forall a b. (a -> b) -> a -> b
$ \Environment
e -> Environment
e { names :: Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (\(SourceType
ty, NameKind
nk, NameVisibility
_) -> (SourceType
ty, NameKind
nk, NameVisibility
Defined)) (Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names Environment
e) }

-- | Update the visibility of all names to Defined in the scope of the provided action
withBindingGroupVisible :: (MonadState CheckState m) => m a -> m a
withBindingGroupVisible :: forall (m :: * -> *) a. MonadState CheckState m => m a -> m a
withBindingGroupVisible m a
action = forall (m :: * -> *) a. MonadState CheckState m => m a -> m a
preservingNames forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadState CheckState m => m ()
makeBindingGroupVisible forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
action

-- | Perform an action while preserving the names from the @Environment@.
preservingNames :: (MonadState CheckState m) => m a -> m a
preservingNames :: forall (m :: * -> *) a. MonadState CheckState m => m a -> m a
preservingNames m a
action = do
  Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
orig <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckState -> Environment
checkEnv)
  a
a <- m a
action
  forall (m :: * -> *).
MonadState CheckState m =>
(Environment -> Environment) -> m ()
modifyEnv forall a b. (a -> b) -> a -> b
$ \Environment
e -> Environment
e { names :: Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names = Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
orig }
  forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Lookup the type of a value by name in the @Environment@
lookupVariable
  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
  => Qualified Ident
  -> m SourceType
lookupVariable :: forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
Qualified Ident -> m SourceType
lookupVariable Qualified Ident
qual = do
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified Ident
qual (Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names Environment
env) of
    Maybe (SourceType, NameKind, NameVisibility)
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Ident -> SimpleErrorMessage
NameIsUndefined (forall a. Qualified a -> a
disqualify Qualified Ident
qual)
    Just (SourceType
ty, NameKind
_, NameVisibility
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return SourceType
ty

-- | Lookup the visibility of a value by name in the @Environment@
getVisibility
  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
  => Qualified Ident
  -> m NameVisibility
getVisibility :: forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
Qualified Ident -> m NameVisibility
getVisibility Qualified Ident
qual = do
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified Ident
qual (Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names Environment
env) of
    Maybe (SourceType, NameKind, NameVisibility)
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Ident -> SimpleErrorMessage
NameIsUndefined (forall a. Qualified a -> a
disqualify Qualified Ident
qual)
    Just (SourceType
_, NameKind
_, NameVisibility
vis) -> forall (m :: * -> *) a. Monad m => a -> m a
return NameVisibility
vis

-- | Assert that a name is visible
checkVisibility
  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
  => Qualified Ident
  -> m ()
checkVisibility :: forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
Qualified Ident -> m ()
checkVisibility name :: Qualified Ident
name@(Qualified QualifiedBy
_ Ident
var) = do
  NameVisibility
vis <- forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
Qualified Ident -> m NameVisibility
getVisibility Qualified Ident
name
  case NameVisibility
vis of
    NameVisibility
Undefined -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Ident -> SimpleErrorMessage
CycleInDeclaration Ident
var
    NameVisibility
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Lookup the kind of a type by name in the @Environment@
lookupTypeVariable
  :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m)
  => ModuleName
  -> Qualified (ProperName 'TypeName)
  -> m SourceType
lookupTypeVariable :: forall e (m :: * -> *).
(e ~ MultipleErrors, MonadState CheckState m, MonadError e m) =>
ModuleName -> Qualified (ProperName 'TypeName) -> m SourceType
lookupTypeVariable ModuleName
currentModule (Qualified QualifiedBy
qb ProperName 'TypeName
name) = do
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
qb' ProperName 'TypeName
name) (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types Environment
env) of
    Maybe (SourceType, TypeKind)
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ ProperName 'TypeName -> SimpleErrorMessage
UndefinedTypeVariable ProperName 'TypeName
name
    Just (SourceType
k, TypeKind
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return SourceType
k
  where
  qb' :: QualifiedBy
qb' = ModuleName -> QualifiedBy
ByModuleName forall a b. (a -> b) -> a -> b
$ case QualifiedBy
qb of
    ByModuleName ModuleName
m -> ModuleName
m
    BySourcePos SourcePos
_ -> ModuleName
currentModule

-- | Get the current @Environment@
getEnv :: (MonadState CheckState m) => m Environment
getEnv :: forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CheckState -> Environment
checkEnv

-- | Get locally-bound names in context, to create an error message.
getLocalContext :: MonadState CheckState m => m Context
getLocalContext :: forall (m :: * -> *). MonadState CheckState m => m Context
getLocalContext = do
  Environment
env <- forall (m :: * -> *). MonadState CheckState m => m Environment
getEnv
  forall (m :: * -> *) a. Monad m => a -> m a
return [ (Ident
ident, SourceType
ty') | (Qualified (BySourcePos SourcePos
_) ident :: Ident
ident@Ident{}, (SourceType
ty', NameKind
_, NameVisibility
Defined)) <- forall k a. Map k a -> [(k, a)]
M.toList (Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names Environment
env) ]

-- | Update the @Environment@
putEnv :: (MonadState CheckState m) => Environment -> m ()
putEnv :: forall (m :: * -> *).
MonadState CheckState m =>
Environment -> m ()
putEnv Environment
env = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\CheckState
s -> CheckState
s { checkEnv :: Environment
checkEnv = Environment
env })

-- | Modify the @Environment@
modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()
modifyEnv :: forall (m :: * -> *).
MonadState CheckState m =>
(Environment -> Environment) -> m ()
modifyEnv Environment -> Environment
f = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\CheckState
s -> CheckState
s { checkEnv :: Environment
checkEnv = Environment -> Environment
f (CheckState -> Environment
checkEnv CheckState
s) })

-- | Run a computation in the typechecking monad, failing with an error, or succeeding with a return value and the final @Environment@.
runCheck :: (Functor m) => CheckState -> StateT CheckState m a -> m (a, Environment)
runCheck :: forall (m :: * -> *) a.
Functor m =>
CheckState -> StateT CheckState m a -> m (a, Environment)
runCheck CheckState
st StateT CheckState m a
check = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second CheckState -> Environment
checkEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT CheckState m a
check CheckState
st

-- | Make an assertion, failing with an error message
guardWith :: (MonadError e m) => e -> Bool -> m ()
guardWith :: forall e (m :: * -> *). MonadError e m => e -> Bool -> m ()
guardWith e
_ Bool
True = forall (m :: * -> *) a. Monad m => a -> m a
return ()
guardWith e
e Bool
False = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e

capturingSubstitution
  :: MonadState CheckState m
  => (a -> Substitution -> b)
  -> m a
  -> m b
capturingSubstitution :: forall (m :: * -> *) a b.
MonadState CheckState m =>
(a -> Substitution -> b) -> m a -> m b
capturingSubstitution a -> Substitution -> b
f m a
ma = do
  a
a <- m a
ma
  Substitution
subst <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CheckState -> Substitution
checkSubstitution
  forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Substitution -> b
f a
a Substitution
subst)

withFreshSubstitution
  :: MonadState CheckState m
  => m a
  -> m a
withFreshSubstitution :: forall (m :: * -> *) a. MonadState CheckState m => m a -> m a
withFreshSubstitution m a
ma = do
  CheckState
orig <- forall s (m :: * -> *). MonadState s m => m s
get
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CheckState
st -> CheckState
st { checkSubstitution :: Substitution
checkSubstitution = Substitution
emptySubstitution }
  a
a <- m a
ma
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CheckState
st -> CheckState
st { checkSubstitution :: Substitution
checkSubstitution = CheckState -> Substitution
checkSubstitution CheckState
orig }
  forall (m :: * -> *) a. Monad m => a -> m a
return a
a

withoutWarnings
  :: MonadWriter w m
  => m a
  -> m (a, w)
withoutWarnings :: forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
withoutWarnings = forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen

unsafeCheckCurrentModule
  :: forall m
   . (MonadError MultipleErrors m, MonadState CheckState m)
  => m ModuleName
unsafeCheckCurrentModule :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadState CheckState m) =>
m ModuleName
unsafeCheckCurrentModule = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CheckState -> Maybe ModuleName
checkCurrentModule forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe ModuleName
Nothing -> forall a. HasCallStack => String -> a
internalError String
"No module name set in scope"
  Just ModuleName
name -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleName
name

debugEnv :: Environment -> [String]
debugEnv :: Environment -> [String]
debugEnv Environment
env = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
  [ Environment -> [String]
debugTypes Environment
env
  , Environment -> [String]
debugTypeSynonyms Environment
env
  , Environment -> [String]
debugTypeClasses Environment
env
  , Environment -> [String]
debugTypeClassDictionaries Environment
env
  , Environment -> [String]
debugDataConstructors Environment
env
  , Environment -> [String]
debugNames Environment
env
  ]

debugType :: Type a -> String
debugType :: forall a. Type a -> String
debugType = forall a. [a] -> [a]
init forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Type a -> String
prettyPrintType Int
100

debugConstraint :: Constraint a -> String
debugConstraint :: forall a. Constraint a -> String
debugConstraint (Constraint a
ann Qualified (ProperName 'ClassName)
clsName [Type a]
kinds [Type a]
args Maybe ConstraintData
_) =
  forall a. Type a -> String
debugType forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall a. a -> Type a -> Type a -> Type a
TypeApp a
ann) (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall a. a -> Type a -> Type a -> Type a
KindApp a
ann) (forall a. a -> Qualified (ProperName 'TypeName) -> Type a
TypeConstructor a
ann (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
coerceProperName Qualified (ProperName 'ClassName)
clsName)) [Type a]
kinds) [Type a]
args

debugTypes :: Environment -> [String]
debugTypes :: Environment -> [String]
debugTypes = forall {m :: * -> *} {a :: ProperNameType} {a}.
(Monad m, Alternative m) =>
(Qualified (ProperName a), (Type a, TypeKind)) -> m String
go forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall k a. Map k a -> [(k, a)]
M.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types
  where
  go :: (Qualified (ProperName a), (Type a, TypeKind)) -> m String
go (Qualified (ProperName a)
qual, (Type a
srcTy, TypeKind
which)) = do
    let
      ppTy :: String
ppTy = forall a. Int -> Type a -> String
prettyPrintType Int
100 Type a
srcTy
      name :: Text
name = forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName a)
qual
      decl :: String
decl = case TypeKind
which of
        DataType DataDeclType
_ [(Text, Maybe SourceType, Role)]
_ [(ProperName 'ConstructorName, [SourceType])]
_    -> String
"data"
        TypeKind
TypeSynonym       -> String
"type"
        ExternData [Role]
_      -> String
"extern"
        TypeKind
LocalTypeVariable -> String
"local"
        TypeKind
ScopedTypeVar     -> String
"scoped"
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Text
"Prim" Text -> Text -> Bool
`isPrefixOf` Text
name))
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
decl forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
name forall a. Semigroup a => a -> a -> a
<> String
" :: " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [a]
init String
ppTy

debugNames :: Environment -> [String]
debugNames :: Environment -> [String]
debugNames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {b} {c}. (Qualified Ident, (Type a, b, c)) -> String
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names
  where
  go :: (Qualified Ident, (Type a, b, c)) -> String
go (Qualified Ident
qual, (Type a
srcTy, b
_, c
_)) = do
    let
      ppTy :: String
ppTy = forall a. Int -> Type a -> String
prettyPrintType Int
100 Type a
srcTy
      name :: Text
name = forall a. (a -> Text) -> Qualified a -> Text
showQualified Ident -> Text
runIdent Qualified Ident
qual
    Text -> String
unpack Text
name forall a. Semigroup a => a -> a -> a
<> String
" :: " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [a]
init String
ppTy

debugDataConstructors :: Environment -> [String]
debugDataConstructors :: Environment -> [String]
debugDataConstructors = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a :: ProperNameType} {a} {b} {a} {d}.
(Qualified (ProperName a), (a, b, Type a, d)) -> String
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment
-> Map
     (Qualified (ProperName 'ConstructorName))
     (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dataConstructors
  where
  go :: (Qualified (ProperName a), (a, b, Type a, d)) -> String
go (Qualified (ProperName a)
qual, (a
_, b
_, Type a
ty, d
_)) = do
    let
      ppTy :: String
ppTy = forall a. Int -> Type a -> String
prettyPrintType Int
100 Type a
ty
      name :: Text
name = forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName a)
qual
    Text -> String
unpack Text
name forall a. Semigroup a => a -> a -> a
<> String
" :: " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [a]
init String
ppTy

debugTypeSynonyms :: Environment -> [String]
debugTypeSynonyms :: Environment -> [String]
debugTypeSynonyms = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a :: ProperNameType} {a} {a}.
(Qualified (ProperName a), ([(Text, Maybe (Type a))], Type a))
-> String
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment
-> Map
     (Qualified (ProperName 'TypeName))
     ([(Text, Maybe SourceType)], SourceType)
typeSynonyms
  where
  go :: (Qualified (ProperName a), ([(Text, Maybe (Type a))], Type a))
-> String
go (Qualified (ProperName a)
qual, ([(Text, Maybe (Type a))]
binders, Type a
subTy)) = do
    let
      vars :: String
vars = [String] -> String
unwords forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Text, Maybe (Type a))]
binders forall a b. (a -> b) -> a -> b
$ \case
               (Text
v, Just Type a
k) -> String
"(" forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
v forall a. Semigroup a => a -> a -> a
<> String
" :: " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [a]
init (forall a. Int -> Type a -> String
prettyPrintType Int
100 Type a
k) forall a. Semigroup a => a -> a -> a
<> String
")"
               (Text
v, Maybe (Type a)
Nothing) -> Text -> String
unpack Text
v
      ppTy :: String
ppTy = forall a. Int -> Type a -> String
prettyPrintType Int
100 Type a
subTy
      name :: Text
name = forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName a)
qual
    String
"type " forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
name forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> String
vars forall a. Semigroup a => a -> a -> a
<> String
" = " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [a]
init String
ppTy

debugTypeClassDictionaries :: Environment -> [String]
debugTypeClassDictionaries :: Environment -> [String]
debugTypeClassDictionaries = forall {a :: ProperNameType} {v}.
Map
  QualifiedBy
  (Map
     (Qualified (ProperName a))
     (Map (Qualified Ident) (NonEmpty (TypeClassDictionaryInScope v))))
-> [String]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment
-> Map
     QualifiedBy
     (Map
        (Qualified (ProperName 'ClassName))
        (Map (Qualified Ident) (NonEmpty NamedDict)))
typeClassDictionaries
  where
  go :: Map
  QualifiedBy
  (Map
     (Qualified (ProperName a))
     (Map (Qualified Ident) (NonEmpty (TypeClassDictionaryInScope v))))
-> [String]
go Map
  QualifiedBy
  (Map
     (Qualified (ProperName a))
     (Map (Qualified Ident) (NonEmpty (TypeClassDictionaryInScope v))))
tcds = do
    (QualifiedBy
mbModuleName, Map
  (Qualified (ProperName a))
  (Map (Qualified Ident) (NonEmpty (TypeClassDictionaryInScope v)))
classes) <- forall k a. Map k a -> [(k, a)]
M.toList Map
  QualifiedBy
  (Map
     (Qualified (ProperName a))
     (Map (Qualified Ident) (NonEmpty (TypeClassDictionaryInScope v))))
tcds
    (Qualified (ProperName a)
className, Map (Qualified Ident) (NonEmpty (TypeClassDictionaryInScope v))
instances) <- forall k a. Map k a -> [(k, a)]
M.toList Map
  (Qualified (ProperName a))
  (Map (Qualified Ident) (NonEmpty (TypeClassDictionaryInScope v)))
classes
    (Qualified Ident
ident, NonEmpty (TypeClassDictionaryInScope v)
dicts) <- forall k a. Map k a -> [(k, a)]
M.toList Map (Qualified Ident) (NonEmpty (TypeClassDictionaryInScope v))
instances
    let
      moduleName :: Text
moduleName = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\ModuleName
m -> Text
"[" forall a. Semigroup a => a -> a -> a
<> ModuleName -> Text
runModuleName ModuleName
m forall a. Semigroup a => a -> a -> a
<> Text
"] ") (QualifiedBy -> Maybe ModuleName
toMaybeModuleName QualifiedBy
mbModuleName)
      className' :: Text
className' = forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName a)
className
      ident' :: Text
ident' = forall a. (a -> Text) -> Qualified a -> Text
showQualified Ident -> Text
runIdent Qualified Ident
ident
      kds :: String
kds = [String] -> String
unwords forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((\String
a -> String
"@(" forall a. Semigroup a => a -> a -> a
<> String
a forall a. Semigroup a => a -> a -> a
<> String
")") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Type a -> String
debugType) forall a b. (a -> b) -> a -> b
$ forall v. TypeClassDictionaryInScope v -> [SourceType]
tcdInstanceKinds forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NEL.head NonEmpty (TypeClassDictionaryInScope v)
dicts
      tys :: String
tys = [String] -> String
unwords forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((\String
a -> String
"(" forall a. Semigroup a => a -> a -> a
<> String
a forall a. Semigroup a => a -> a -> a
<> String
")") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Type a -> String
debugType) forall a b. (a -> b) -> a -> b
$ forall v. TypeClassDictionaryInScope v -> [SourceType]
tcdInstanceTypes forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NEL.head NonEmpty (TypeClassDictionaryInScope v)
dicts
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
"dict " forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
moduleName forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
className' forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
ident' forall a. Semigroup a => a -> a -> a
<> String
" (" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (TypeClassDictionaryInScope v)
dicts) forall a. Semigroup a => a -> a -> a
<> String
")" forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> String
kds forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> String
tys

debugTypeClasses :: Environment -> [String]
debugTypeClasses :: Environment -> [String]
debugTypeClasses = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a :: ProperNameType}.
(Qualified (ProperName a), TypeClassData) -> String
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses
  where
  go :: (Qualified (ProperName a), TypeClassData) -> String
go (Qualified (ProperName a)
className, TypeClassData
tc) = do
    let
      className' :: Text
className' = forall a. (a -> Text) -> Qualified a -> Text
showQualified forall (a :: ProperNameType). ProperName a -> Text
runProperName Qualified (ProperName a)
className
      args :: String
args = [String] -> String
unwords forall a b. (a -> b) -> a -> b
$ (\(Text
a, Maybe SourceType
b) -> String
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Type a -> String
debugType (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> SourceType
srcTypeVar Text
a) (SourceType -> SourceType -> SourceType
srcKindedType (Text -> SourceType
srcTypeVar Text
a)) Maybe SourceType
b) forall a. Semigroup a => a -> a -> a
<> String
")") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeClassData -> [(Text, Maybe SourceType)]
typeClassArguments TypeClassData
tc
    String
"class " forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
className' forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> String
args

debugValue :: Expr -> String
debugValue :: Expr -> String
debugValue = forall a. [a] -> [a]
init forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box -> String
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Expr -> Box
prettyPrintValue Int
100

debugSubstitution :: Substitution -> [String]
debugSubstitution :: Substitution -> [String]
debugSubstitution (Substitution Map Int SourceType
solved Map Int (UnkLevel, SourceType)
unsolved Map Int Text
names) =
  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {a}. Show a => (a, Type a) -> String
go1 (forall k a. Map k a -> [(k, a)]
M.toList Map Int SourceType
solved)
    , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {a} {a}. Show a => (a, (a, Type a)) -> String
go2 (forall k a. Map k a -> [(k, a)]
M.toList Map Int (UnkLevel, SourceType)
unsolved')
    , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}. Show a => (a, Text) -> String
go3 (forall k a. Map k a -> [(k, a)]
M.toList Map Int Text
names)
    ]
  where
  unsolved' :: Map Int (UnkLevel, SourceType)
unsolved' =
    forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\Int
k (UnkLevel, SourceType)
_ -> forall k a. Ord k => k -> Map k a -> Bool
M.notMember Int
k Map Int SourceType
solved) Map Int (UnkLevel, SourceType)
unsolved

  go1 :: (a, Type a) -> String
go1 (a
u, Type a
ty) =
    String
"?" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
u forall a. Semigroup a => a -> a -> a
<> String
" = " forall a. Semigroup a => a -> a -> a
<> forall a. Type a -> String
debugType Type a
ty

  go2 :: (a, (a, Type a)) -> String
go2 (a
u, (a
_, Type a
k)) =
    String
"?" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
u forall a. Semigroup a => a -> a -> a
<> String
" :: " forall a. Semigroup a => a -> a -> a
<> forall a. Type a -> String
debugType Type a
k

  go3 :: (a, Text) -> String
go3 (a
u, Text
t) =
    Text -> String
unpack Text
t forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
u