{-# LANGUAGE GADTs #-}
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)
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
data Substitution = Substitution
{ Substitution -> Map Int SourceType
substType :: M.Map Int SourceType
, Substitution -> Map Int (UnkLevel, SourceType)
substUnsolved :: M.Map Int (UnkLevel, SourceType)
, Substitution -> Map Int Text
substNames :: M.Map Int Text
}
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
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
data CheckState = CheckState
{ CheckState -> Environment
checkEnv :: Environment
, CheckState -> Int
checkNextType :: Int
, CheckState -> Int
checkNextSkolem :: Int
, CheckState -> Int
checkNextSkolemScope :: Int
, CheckState -> Maybe ModuleName
checkCurrentModule :: Maybe ModuleName
, 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)
)
]
, CheckState -> Substitution
checkSubstitution :: Substitution
, CheckState -> [ErrorMessageHint]
checkHints :: [ErrorMessageHint]
, CheckState
-> Set (ModuleName, Qualified (ProperName 'ConstructorName))
checkConstructorImportsForCoercible :: S.Set (ModuleName, Qualified (ProperName 'ConstructorName))
}
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
type Unknown = Int
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
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
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 }
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
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
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
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
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
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
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)))
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)))
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) }
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
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
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
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
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 ()
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
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
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) ]
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 })
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) })
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
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