{-# LANGUAGE CPP #-}
module Checks.TypeCheck (typeCheck) where
#if __GLASGOW_HASKELL__ >= 804
import Prelude hiding ((<>))
#endif
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>))
#endif
import Control.Monad.Trans (lift)
import Control.Monad.Extra (allM, filterM, foldM, liftM, (&&^),
notM, replicateM, when, unless, unlessM)
import qualified Control.Monad.State as S
(State, StateT, get, gets, put, modify,
runState, evalStateT)
import Data.Function (on)
import Data.List (nub, nubBy, partition, sortBy, (\\))
import qualified Data.Map as Map (Map, empty, insert, lookup)
import Data.Maybe (fromJust, fromMaybe, isJust)
import qualified Data.Set.Extra as Set ( Set, concatMap, deleteMin, empty
, fromList, insert, member
, notMember, partition, singleton
, toList, union, unions )
import Curry.Base.Ident
import Curry.Base.Pretty
import Curry.Base.SpanInfo
import Curry.Syntax
import Curry.Syntax.Pretty
import Base.CurryTypes
import Base.Expr
import Base.Kinds
import Base.Messages (Message, spanInfoMessage, internalError)
import Base.SCC
import Base.TopEnv
import Base.TypeExpansion
import Base.Types
import Base.TypeSubst
import Base.Utils (foldr2, fst3, snd3, thd3, uncurry3, mapAccumM)
import Env.Class
import Env.Instance
import Env.TypeConstructor
import Env.Value
typeCheck :: ModuleIdent -> TCEnv -> ValueEnv -> ClassEnv -> InstEnv -> [Decl a]
-> ([Decl PredType], ValueEnv, [Message])
typeCheck :: ModuleIdent
-> TCEnv
-> ValueEnv
-> ClassEnv
-> InstEnv
-> [Decl a]
-> ([Decl PredType], ValueEnv, [Message])
typeCheck m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv vEnv :: ValueEnv
vEnv clsEnv :: ClassEnv
clsEnv inEnv :: InstEnv
inEnv ds :: [Decl a]
ds = TCM [Decl PredType]
-> TcState -> ([Decl PredType], ValueEnv, [Message])
forall a. TCM a -> TcState -> (a, ValueEnv, [Message])
runTCM ([Decl a] -> TCM [Decl PredType]
forall a. [Decl a] -> TCM [Decl PredType]
checkDecls [Decl a]
ds) TcState
initState
where initState :: TcState
initState = ModuleIdent
-> TCEnv
-> ValueEnv
-> ClassEnv
-> InstEnv'
-> [Type]
-> TypeSubst
-> SigEnv
-> Int
-> [Message]
-> TcState
TcState ModuleIdent
m TCEnv
tcEnv ValueEnv
vEnv ClassEnv
clsEnv (InstEnv
inEnv, Map QualIdent [Type]
forall k a. Map k a
Map.empty)
[Type
intType, Type
floatType] TypeSubst
forall a b. Subst a b
idSubst SigEnv
emptySigEnv 1 []
checkDecls :: [Decl a] -> TCM [Decl PredType]
checkDecls :: [Decl a] -> TCM [Decl PredType]
checkDecls ds :: [Decl a]
ds = do
TCM ()
bindConstrs
(Decl a -> TCM ()) -> [Decl a] -> TCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Decl a -> TCM ()
forall a. Decl a -> TCM ()
checkFieldLabel ((Decl a -> Bool) -> [Decl a] -> [Decl a]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl a -> Bool
forall a. Decl a -> Bool
isTypeDecl [Decl a]
ds) TCM () -> TCM () -> TCM ()
&&> TCM ()
bindLabels
TCM ()
bindClassMethods
(Decl a -> TCM ()) -> [Decl a] -> TCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Decl a -> TCM ()
forall a. Decl a -> TCM ()
setDefaults ([Decl a] -> TCM ()) -> [Decl a] -> TCM ()
forall a b. (a -> b) -> a -> b
$ (Decl a -> Bool) -> [Decl a] -> [Decl a]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl a -> Bool
forall a. Decl a -> Bool
isDefaultDecl [Decl a]
ds
(_, bpds' :: [PDecl PredType]
bpds') <- [PDecl a] -> TCM (PredSet, [PDecl PredType])
forall a. [PDecl a] -> TCM (PredSet, [PDecl PredType])
tcPDecls [PDecl a]
bpds
[PDecl PredType]
tpds' <- (PDecl a -> StateT TcState Identity (PDecl PredType))
-> [PDecl a] -> StateT TcState Identity [PDecl PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PDecl a -> StateT TcState Identity (PDecl PredType)
forall a. PDecl a -> StateT TcState Identity (PDecl PredType)
tcTopPDecl [PDecl a]
tpds
TypeSubst
theta <- TCM TypeSubst
getTypeSubst
[Decl PredType] -> TCM [Decl PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl PredType] -> TCM [Decl PredType])
-> [Decl PredType] -> TCM [Decl PredType]
forall a b. (a -> b) -> a -> b
$ (Decl PredType -> Decl PredType)
-> [Decl PredType] -> [Decl PredType]
forall a b. (a -> b) -> [a] -> [b]
map ((PredType -> PredType) -> Decl PredType -> Decl PredType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PredType -> PredType) -> Decl PredType -> Decl PredType)
-> (PredType -> PredType) -> Decl PredType -> Decl PredType
forall a b. (a -> b) -> a -> b
$ TypeSubst -> PredType -> PredType
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta) ([Decl PredType] -> [Decl PredType])
-> [Decl PredType] -> [Decl PredType]
forall a b. (a -> b) -> a -> b
$ [PDecl PredType] -> [Decl PredType]
forall a. [PDecl a] -> [Decl a]
fromPDecls ([PDecl PredType] -> [Decl PredType])
-> [PDecl PredType] -> [Decl PredType]
forall a b. (a -> b) -> a -> b
$ [PDecl PredType]
tpds' [PDecl PredType] -> [PDecl PredType] -> [PDecl PredType]
forall a. [a] -> [a] -> [a]
++ [PDecl PredType]
bpds'
where (bpds :: [PDecl a]
bpds, tpds :: [PDecl a]
tpds) = (PDecl a -> Bool) -> [PDecl a] -> ([PDecl a], [PDecl a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Decl a -> Bool
forall a. Decl a -> Bool
isBlockDecl (Decl a -> Bool) -> (PDecl a -> Decl a) -> PDecl a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PDecl a -> Decl a
forall a b. (a, b) -> b
snd) ([PDecl a] -> ([PDecl a], [PDecl a]))
-> [PDecl a] -> ([PDecl a], [PDecl a])
forall a b. (a -> b) -> a -> b
$ [Decl a] -> [PDecl a]
forall a. [Decl a] -> [PDecl a]
toPDecls [Decl a]
ds
type TCM = S.State TcState
type InstEnv' = (InstEnv, Map.Map QualIdent [Type])
data TcState = TcState
{ TcState -> ModuleIdent
moduleIdent :: ModuleIdent
, TcState -> TCEnv
tyConsEnv :: TCEnv
, TcState -> ValueEnv
valueEnv :: ValueEnv
, TcState -> ClassEnv
classEnv :: ClassEnv
, TcState -> InstEnv'
instEnv :: InstEnv'
, TcState -> [Type]
defaultTypes :: [Type]
, TcState -> TypeSubst
typeSubst :: TypeSubst
, TcState -> SigEnv
sigEnv :: SigEnv
, TcState -> Int
nextId :: Int
, TcState -> [Message]
errors :: [Message]
}
(&&>) :: TCM () -> TCM () -> TCM ()
pre :: TCM ()
pre &&> :: TCM () -> TCM () -> TCM ()
&&> suf :: TCM ()
suf = do
[Message]
errs <- TCM ()
pre TCM ()
-> StateT TcState Identity [Message]
-> StateT TcState Identity [Message]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (TcState -> [Message]) -> StateT TcState Identity [Message]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets TcState -> [Message]
errors
Bool -> TCM () -> TCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Message] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
errs) TCM ()
suf
(>>-) :: Monad m => m (a, b, c) -> (a -> b -> m a) -> m (a, c)
m :: m (a, b, c)
m >>- :: m (a, b, c) -> (a -> b -> m a) -> m (a, c)
>>- f :: a -> b -> m a
f = do
(u :: a
u, v :: b
v, w :: c
w) <- m (a, b, c)
m
a
u' <- a -> b -> m a
f a
u b
v
(a, c) -> m (a, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
u', c
w)
(>>=-) :: TCM (a, b, d) -> (b -> TCM c) -> TCM (a, c, d)
m :: TCM (a, b, d)
m >>=- :: TCM (a, b, d) -> (b -> TCM c) -> TCM (a, c, d)
>>=- f :: b -> TCM c
f = do
(u :: a
u, v :: b
v, x :: d
x) <- TCM (a, b, d)
m
c
w <- b -> TCM c
f b
v
(a, c, d) -> TCM (a, c, d)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
u, c
w, d
x)
runTCM :: TCM a -> TcState -> (a, ValueEnv, [Message])
runTCM :: TCM a -> TcState -> (a, ValueEnv, [Message])
runTCM tcm :: TCM a
tcm ts :: TcState
ts = let (a :: a
a, s' :: TcState
s') = TCM a -> TcState -> (a, TcState)
forall s a. State s a -> s -> (a, s)
S.runState TCM a
tcm TcState
ts
in (a
a, TcState -> TypeSubst
typeSubst TcState
s' TypeSubst -> ValueEnv -> ValueEnv
forall a. SubstType a => TypeSubst -> a -> a
`subst` TcState -> ValueEnv
valueEnv TcState
s', [Message] -> [Message]
forall a. [a] -> [a]
reverse ([Message] -> [Message]) -> [Message] -> [Message]
forall a b. (a -> b) -> a -> b
$ TcState -> [Message]
errors TcState
s')
getModuleIdent :: TCM ModuleIdent
getModuleIdent :: TCM ModuleIdent
getModuleIdent = (TcState -> ModuleIdent) -> TCM ModuleIdent
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets TcState -> ModuleIdent
moduleIdent
getTyConsEnv :: TCM TCEnv
getTyConsEnv :: TCM TCEnv
getTyConsEnv = (TcState -> TCEnv) -> TCM TCEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets TcState -> TCEnv
tyConsEnv
getValueEnv :: TCM ValueEnv
getValueEnv :: TCM ValueEnv
getValueEnv = (TcState -> ValueEnv) -> TCM ValueEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets TcState -> ValueEnv
valueEnv
modifyValueEnv :: (ValueEnv -> ValueEnv) -> TCM ()
modifyValueEnv :: (ValueEnv -> ValueEnv) -> TCM ()
modifyValueEnv f :: ValueEnv -> ValueEnv
f = (TcState -> TcState) -> TCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((TcState -> TcState) -> TCM ()) -> (TcState -> TcState) -> TCM ()
forall a b. (a -> b) -> a -> b
$ \s :: TcState
s -> TcState
s { valueEnv :: ValueEnv
valueEnv = ValueEnv -> ValueEnv
f (ValueEnv -> ValueEnv) -> ValueEnv -> ValueEnv
forall a b. (a -> b) -> a -> b
$ TcState -> ValueEnv
valueEnv TcState
s }
withLocalValueEnv :: TCM a -> TCM a
withLocalValueEnv :: TCM a -> TCM a
withLocalValueEnv act :: TCM a
act = do
ValueEnv
oldEnv <- TCM ValueEnv
getValueEnv
a
res <- TCM a
act
(ValueEnv -> ValueEnv) -> TCM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> TCM ())
-> (ValueEnv -> ValueEnv) -> TCM ()
forall a b. (a -> b) -> a -> b
$ ValueEnv -> ValueEnv -> ValueEnv
forall a b. a -> b -> a
const ValueEnv
oldEnv
a -> TCM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
getClassEnv :: TCM ClassEnv
getClassEnv :: TCM ClassEnv
getClassEnv = (TcState -> ClassEnv) -> TCM ClassEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets TcState -> ClassEnv
classEnv
getInstEnv :: TCM InstEnv'
getInstEnv :: TCM InstEnv'
getInstEnv = (TcState -> InstEnv') -> TCM InstEnv'
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets TcState -> InstEnv'
instEnv
modifyInstEnv :: (InstEnv' -> InstEnv') -> TCM ()
modifyInstEnv :: (InstEnv' -> InstEnv') -> TCM ()
modifyInstEnv f :: InstEnv' -> InstEnv'
f = (TcState -> TcState) -> TCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((TcState -> TcState) -> TCM ()) -> (TcState -> TcState) -> TCM ()
forall a b. (a -> b) -> a -> b
$ \s :: TcState
s -> TcState
s { instEnv :: InstEnv'
instEnv = InstEnv' -> InstEnv'
f (InstEnv' -> InstEnv') -> InstEnv' -> InstEnv'
forall a b. (a -> b) -> a -> b
$ TcState -> InstEnv'
instEnv TcState
s }
getDefaultTypes :: TCM [Type]
getDefaultTypes :: TCM [Type]
getDefaultTypes = (TcState -> [Type]) -> TCM [Type]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets TcState -> [Type]
defaultTypes
setDefaultTypes :: [Type] -> TCM ()
setDefaultTypes :: [Type] -> TCM ()
setDefaultTypes tys :: [Type]
tys = (TcState -> TcState) -> TCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((TcState -> TcState) -> TCM ()) -> (TcState -> TcState) -> TCM ()
forall a b. (a -> b) -> a -> b
$ \s :: TcState
s -> TcState
s { defaultTypes :: [Type]
defaultTypes = [Type]
tys }
getTypeSubst :: TCM TypeSubst
getTypeSubst :: TCM TypeSubst
getTypeSubst = (TcState -> TypeSubst) -> TCM TypeSubst
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets TcState -> TypeSubst
typeSubst
modifyTypeSubst :: (TypeSubst -> TypeSubst) -> TCM ()
modifyTypeSubst :: (TypeSubst -> TypeSubst) -> TCM ()
modifyTypeSubst f :: TypeSubst -> TypeSubst
f = (TcState -> TcState) -> TCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((TcState -> TcState) -> TCM ()) -> (TcState -> TcState) -> TCM ()
forall a b. (a -> b) -> a -> b
$ \s :: TcState
s -> TcState
s { typeSubst :: TypeSubst
typeSubst = TypeSubst -> TypeSubst
f (TypeSubst -> TypeSubst) -> TypeSubst -> TypeSubst
forall a b. (a -> b) -> a -> b
$ TcState -> TypeSubst
typeSubst TcState
s }
getSigEnv :: TCM SigEnv
getSigEnv :: TCM SigEnv
getSigEnv = (TcState -> SigEnv) -> TCM SigEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets TcState -> SigEnv
sigEnv
setSigEnv :: SigEnv -> TCM ()
setSigEnv :: SigEnv -> TCM ()
setSigEnv sigs :: SigEnv
sigs = (TcState -> TcState) -> TCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((TcState -> TcState) -> TCM ()) -> (TcState -> TcState) -> TCM ()
forall a b. (a -> b) -> a -> b
$ \s :: TcState
s -> TcState
s { sigEnv :: SigEnv
sigEnv = SigEnv
sigs }
withLocalSigEnv :: TCM a -> TCM a
withLocalSigEnv :: TCM a -> TCM a
withLocalSigEnv act :: TCM a
act = do
SigEnv
oldSigs <- TCM SigEnv
getSigEnv
a
res <- TCM a
act
SigEnv -> TCM ()
setSigEnv SigEnv
oldSigs
a -> TCM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
getNextId :: TCM Int
getNextId :: TCM Int
getNextId = do
Int
nid <- (TcState -> Int) -> TCM Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets TcState -> Int
nextId
(TcState -> TcState) -> TCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((TcState -> TcState) -> TCM ()) -> (TcState -> TcState) -> TCM ()
forall a b. (a -> b) -> a -> b
$ \s :: TcState
s -> TcState
s { nextId :: Int
nextId = Int -> Int
forall a. Enum a => a -> a
succ Int
nid }
Int -> TCM Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
nid
report :: Message -> TCM ()
report :: Message -> TCM ()
report err :: Message
err = (TcState -> TcState) -> TCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((TcState -> TcState) -> TCM ()) -> (TcState -> TcState) -> TCM ()
forall a b. (a -> b) -> a -> b
$ \s :: TcState
s -> TcState
s { errors :: [Message]
errors = Message
err Message -> [Message] -> [Message]
forall a. a -> [a] -> [a]
: TcState -> [Message]
errors TcState
s }
ok :: TCM ()
ok :: TCM ()
ok = () -> TCM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
type PDecl a = (Int, Decl a)
toPDecls :: [Decl a] -> [PDecl a]
toPDecls :: [Decl a] -> [PDecl a]
toPDecls = [Int] -> [Decl a] -> [PDecl a]
forall a b. [a] -> [b] -> [(a, b)]
zip [0 ..]
fromPDecls :: [PDecl a] -> [Decl a]
fromPDecls :: [PDecl a] -> [Decl a]
fromPDecls = (PDecl a -> Decl a) -> [PDecl a] -> [Decl a]
forall a b. (a -> b) -> [a] -> [b]
map PDecl a -> Decl a
forall a b. (a, b) -> b
snd ([PDecl a] -> [Decl a])
-> ([PDecl a] -> [PDecl a]) -> [PDecl a] -> [Decl a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PDecl a -> PDecl a -> Ordering) -> [PDecl a] -> [PDecl a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> (PDecl a -> Int) -> PDecl a -> PDecl a -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PDecl a -> Int
forall a b. (a, b) -> a
fst)
untyped :: PDecl a -> PDecl b
untyped :: PDecl a -> PDecl b
untyped = (Decl a -> Decl b) -> PDecl a -> PDecl b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Decl a -> Decl b) -> PDecl a -> PDecl b)
-> (Decl a -> Decl b) -> PDecl a -> PDecl b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> Decl a -> Decl b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Decl a -> Decl b) -> (a -> b) -> Decl a -> Decl b
forall a b. (a -> b) -> a -> b
$ String -> a -> b
forall a. String -> a
internalError "TypeCheck.untyped"
bindConstrs :: TCM ()
bindConstrs :: TCM ()
bindConstrs = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
TCEnv
tcEnv <- TCM TCEnv
getTyConsEnv
(ValueEnv -> ValueEnv) -> TCM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> TCM ())
-> (ValueEnv -> ValueEnv) -> TCM ()
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv
bindConstrs' ModuleIdent
m TCEnv
tcEnv
bindConstrs' :: ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv
bindConstrs' :: ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv
bindConstrs' m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv vEnv :: ValueEnv
vEnv = ((Ident, TypeInfo) -> ValueEnv -> ValueEnv)
-> ValueEnv -> [(Ident, TypeInfo)] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TypeInfo -> ValueEnv -> ValueEnv
bindData (TypeInfo -> ValueEnv -> ValueEnv)
-> ((Ident, TypeInfo) -> TypeInfo)
-> (Ident, TypeInfo)
-> ValueEnv
-> ValueEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident, TypeInfo) -> TypeInfo
forall a b. (a, b) -> b
snd) ValueEnv
vEnv ([(Ident, TypeInfo)] -> ValueEnv)
-> [(Ident, TypeInfo)] -> ValueEnv
forall a b. (a -> b) -> a -> b
$ TCEnv -> [(Ident, TypeInfo)]
forall a. TopEnv a -> [(Ident, a)]
localBindings TCEnv
tcEnv
where
bindData :: TypeInfo -> ValueEnv -> ValueEnv
bindData (DataType tc :: QualIdent
tc k :: Kind
k cs :: [DataConstr]
cs) vEnv' :: ValueEnv
vEnv' =
let n :: Int
n = Kind -> Int
kindArity Kind
k in (DataConstr -> ValueEnv -> ValueEnv)
-> ValueEnv -> [DataConstr] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ModuleIdent -> Int -> Type -> DataConstr -> ValueEnv -> ValueEnv
bindConstr ModuleIdent
m Int
n (QualIdent -> Int -> Type
constrType' QualIdent
tc Int
n)) ValueEnv
vEnv' [DataConstr]
cs
bindData (RenamingType tc :: QualIdent
tc k :: Kind
k c :: DataConstr
c) vEnv' :: ValueEnv
vEnv' =
let n :: Int
n = Kind -> Int
kindArity Kind
k in ModuleIdent -> Int -> Type -> DataConstr -> ValueEnv -> ValueEnv
bindNewConstr ModuleIdent
m Int
n (QualIdent -> Int -> Type
constrType' QualIdent
tc Int
n) DataConstr
c ValueEnv
vEnv'
bindData _ vEnv' :: ValueEnv
vEnv' = ValueEnv
vEnv'
bindConstr :: ModuleIdent -> Int -> Type -> DataConstr -> ValueEnv -> ValueEnv
bindConstr :: ModuleIdent -> Int -> Type -> DataConstr -> ValueEnv -> ValueEnv
bindConstr m :: ModuleIdent
m n :: Int
n ty :: Type
ty (DataConstr c :: Ident
c tys :: [Type]
tys) =
(QualIdent -> TypeScheme -> ValueInfo)
-> ModuleIdent -> Ident -> TypeScheme -> ValueEnv -> ValueEnv
forall a.
(QualIdent -> a -> ValueInfo)
-> ModuleIdent -> Ident -> a -> ValueEnv -> ValueEnv
bindGlobalInfo (\qc :: QualIdent
qc tyScheme :: TypeScheme
tyScheme -> QualIdent -> Int -> [Ident] -> TypeScheme -> ValueInfo
DataConstructor QualIdent
qc Int
arity [Ident]
ls TypeScheme
tyScheme) ModuleIdent
m Ident
c
(Int -> PredType -> TypeScheme
ForAll Int
n (PredSet -> Type -> PredType
PredType PredSet
emptyPredSet ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
TypeArrow Type
ty [Type]
tys)))
where arity :: Int
arity = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys
ls :: [Ident]
ls = Int -> Ident -> [Ident]
forall a. Int -> a -> [a]
replicate Int
arity Ident
anonId
bindConstr m :: ModuleIdent
m n :: Int
n ty :: Type
ty (RecordConstr c :: Ident
c ls :: [Ident]
ls tys :: [Type]
tys) =
(QualIdent -> TypeScheme -> ValueInfo)
-> ModuleIdent -> Ident -> TypeScheme -> ValueEnv -> ValueEnv
forall a.
(QualIdent -> a -> ValueInfo)
-> ModuleIdent -> Ident -> a -> ValueEnv -> ValueEnv
bindGlobalInfo (\qc :: QualIdent
qc tyScheme :: TypeScheme
tyScheme -> QualIdent -> Int -> [Ident] -> TypeScheme -> ValueInfo
DataConstructor QualIdent
qc Int
arity [Ident]
ls TypeScheme
tyScheme) ModuleIdent
m Ident
c
(Int -> PredType -> TypeScheme
ForAll Int
n (PredSet -> Type -> PredType
PredType PredSet
emptyPredSet ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
TypeArrow Type
ty [Type]
tys)))
where arity :: Int
arity = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys
bindNewConstr :: ModuleIdent -> Int -> Type -> DataConstr -> ValueEnv
-> ValueEnv
bindNewConstr :: ModuleIdent -> Int -> Type -> DataConstr -> ValueEnv -> ValueEnv
bindNewConstr m :: ModuleIdent
m n :: Int
n cty :: Type
cty (DataConstr c :: Ident
c [lty :: Type
lty]) =
(QualIdent -> TypeScheme -> ValueInfo)
-> ModuleIdent -> Ident -> TypeScheme -> ValueEnv -> ValueEnv
forall a.
(QualIdent -> a -> ValueInfo)
-> ModuleIdent -> Ident -> a -> ValueEnv -> ValueEnv
bindGlobalInfo (\qc :: QualIdent
qc tyScheme :: TypeScheme
tyScheme -> QualIdent -> Ident -> TypeScheme -> ValueInfo
NewtypeConstructor QualIdent
qc Ident
anonId TypeScheme
tyScheme) ModuleIdent
m Ident
c
(Int -> PredType -> TypeScheme
ForAll Int
n (Type -> PredType
predType (Type -> Type -> Type
TypeArrow Type
lty Type
cty)))
bindNewConstr m :: ModuleIdent
m n :: Int
n cty :: Type
cty (RecordConstr c :: Ident
c [l :: Ident
l] [lty :: Type
lty]) =
(QualIdent -> TypeScheme -> ValueInfo)
-> ModuleIdent -> Ident -> TypeScheme -> ValueEnv -> ValueEnv
forall a.
(QualIdent -> a -> ValueInfo)
-> ModuleIdent -> Ident -> a -> ValueEnv -> ValueEnv
bindGlobalInfo (\qc :: QualIdent
qc tyScheme :: TypeScheme
tyScheme -> QualIdent -> Ident -> TypeScheme -> ValueInfo
NewtypeConstructor QualIdent
qc Ident
l TypeScheme
tyScheme) ModuleIdent
m Ident
c
(Int -> PredType -> TypeScheme
ForAll Int
n (Type -> PredType
predType (Type -> Type -> Type
TypeArrow Type
lty Type
cty)))
bindNewConstr _ _ _ _ = String -> ValueEnv -> ValueEnv
forall a. String -> a
internalError
"TypeCheck.bindConstrs'.bindNewConstr: newtype with illegal constructors"
constrType' :: QualIdent -> Int -> Type
constrType' :: QualIdent -> Int -> Type
constrType' tc :: QualIdent
tc n :: Int
n =
Type -> [Type] -> Type
applyType (QualIdent -> Type
TypeConstructor QualIdent
tc) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (Int -> Type) -> [Int] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Type
TypeVariable [0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]
checkFieldLabel :: Decl a -> TCM ()
checkFieldLabel :: Decl a -> TCM ()
checkFieldLabel (DataDecl _ _ tvs :: [Ident]
tvs cs :: [ConstrDecl]
cs _) = do
[(Ident, SpanInfo, Type)]
ls' <- ((Ident, SpanInfo, TypeExpr)
-> StateT TcState Identity (Ident, SpanInfo, Type))
-> [(Ident, SpanInfo, TypeExpr)]
-> StateT TcState Identity [(Ident, SpanInfo, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Ident]
-> (Ident, SpanInfo, TypeExpr)
-> StateT TcState Identity (Ident, SpanInfo, Type)
forall p.
HasSpanInfo p =>
[Ident] -> (Ident, p, TypeExpr) -> TCM (Ident, p, Type)
tcFieldLabel [Ident]
tvs) [(Ident, SpanInfo, TypeExpr)]
labels
((Ident, SpanInfo, [Type]) -> TCM ())
-> [(Ident, SpanInfo, [Type])] -> TCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Ident, SpanInfo, [Type]) -> TCM ()
forall p. HasSpanInfo p => (Ident, p, [Type]) -> TCM ()
tcFieldLabels ([(Ident, SpanInfo, Type)] -> [(Ident, SpanInfo, [Type])]
forall a b c. Eq a => [(a, b, c)] -> [(a, b, [c])]
groupLabels [(Ident, SpanInfo, Type)]
ls')
where labels :: [(Ident, SpanInfo, TypeExpr)]
labels = [(Ident
l, SpanInfo
p, TypeExpr
ty) | RecordDecl _ _ fs :: [FieldDecl]
fs <- [ConstrDecl]
cs,
FieldDecl p :: SpanInfo
p ls :: [Ident]
ls ty :: TypeExpr
ty <- [FieldDecl]
fs, Ident
l <- [Ident]
ls]
checkFieldLabel (NewtypeDecl _ _ tvs :: [Ident]
tvs (NewRecordDecl p :: SpanInfo
p _ (l :: Ident
l, ty :: TypeExpr
ty)) _) = do
(Ident, SpanInfo, Type)
_ <- [Ident]
-> (Ident, SpanInfo, TypeExpr)
-> StateT TcState Identity (Ident, SpanInfo, Type)
forall p.
HasSpanInfo p =>
[Ident] -> (Ident, p, TypeExpr) -> TCM (Ident, p, Type)
tcFieldLabel [Ident]
tvs (Ident
l, SpanInfo
p, TypeExpr
ty)
TCM ()
ok
checkFieldLabel _ = TCM ()
ok
tcFieldLabel :: HasSpanInfo p => [Ident] -> (Ident, p, TypeExpr)
-> TCM (Ident, p, Type)
tcFieldLabel :: [Ident] -> (Ident, p, TypeExpr) -> TCM (Ident, p, Type)
tcFieldLabel tvs :: [Ident]
tvs (l :: Ident
l, p :: p
p, ty :: TypeExpr
ty) = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
TCEnv
tcEnv <- TCM TCEnv
getTyConsEnv
let ForAll n :: Int
n (PredType _ ty' :: Type
ty') = Type -> TypeScheme
polyType (Type -> TypeScheme) -> Type -> TypeScheme
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> TCEnv -> [Ident] -> TypeExpr -> Type
expandMonoType ModuleIdent
m TCEnv
tcEnv [Ident]
tvs TypeExpr
ty
Bool -> TCM () -> TCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [Ident] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ident]
tvs) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ Message -> TCM ()
report (Message -> TCM ()) -> Message -> TCM ()
forall a b. (a -> b) -> a -> b
$ p -> Ident -> Message
forall a. HasSpanInfo a => a -> Ident -> Message
errSkolemFieldLabel p
p Ident
l
(Ident, p, Type) -> TCM (Ident, p, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
l, p
p, Type
ty')
groupLabels :: Eq a => [(a, b, c)] -> [(a, b, [c])]
groupLabels :: [(a, b, c)] -> [(a, b, [c])]
groupLabels [] = []
groupLabels ((x :: a
x, y :: b
y, z :: c
z):xyzs :: [(a, b, c)]
xyzs) =
(a
x, b
y, c
z c -> [c] -> [c]
forall a. a -> [a] -> [a]
: ((a, b, c) -> c) -> [(a, b, c)] -> [c]
forall a b. (a -> b) -> [a] -> [b]
map (a, b, c) -> c
forall a b c. (a, b, c) -> c
thd3 [(a, b, c)]
xyzs') (a, b, [c]) -> [(a, b, [c])] -> [(a, b, [c])]
forall a. a -> [a] -> [a]
: [(a, b, c)] -> [(a, b, [c])]
forall a b c. Eq a => [(a, b, c)] -> [(a, b, [c])]
groupLabels [(a, b, c)]
xyzs''
where (xyzs' :: [(a, b, c)]
xyzs', xyzs'' :: [(a, b, c)]
xyzs'') = ((a, b, c) -> Bool) -> [(a, b, c)] -> ([(a, b, c)], [(a, b, c)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==) (a -> Bool) -> ((a, b, c) -> a) -> (a, b, c) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b, c) -> a
forall a b c. (a, b, c) -> a
fst3) [(a, b, c)]
xyzs
tcFieldLabels :: HasSpanInfo p => (Ident, p, [Type]) -> TCM ()
tcFieldLabels :: (Ident, p, [Type]) -> TCM ()
tcFieldLabels (_, _, []) = () -> TCM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
tcFieldLabels (l :: Ident
l, p :: p
p, ty :: Type
ty:tys :: [Type]
tys) = Bool -> TCM () -> TCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> Bool
not ((Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/=) [Type]
tys)) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
Message -> TCM ()
report (Message -> TCM ()) -> Message -> TCM ()
forall a b. (a -> b) -> a -> b
$ p -> ModuleIdent -> Ident -> Type -> Type -> Message
forall a.
HasSpanInfo a =>
a -> ModuleIdent -> Ident -> Type -> Type -> Message
errIncompatibleLabelTypes p
p ModuleIdent
m Ident
l Type
ty ([Type] -> Type
forall a. [a] -> a
head [Type]
tys)
bindLabels :: TCM ()
bindLabels :: TCM ()
bindLabels = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
TCEnv
tcEnv <- TCM TCEnv
getTyConsEnv
(ValueEnv -> ValueEnv) -> TCM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> TCM ())
-> (ValueEnv -> ValueEnv) -> TCM ()
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv
bindLabels' ModuleIdent
m TCEnv
tcEnv
bindLabels' :: ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv
bindLabels' :: ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv
bindLabels' m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv vEnv :: ValueEnv
vEnv = ((Ident, TypeInfo) -> ValueEnv -> ValueEnv)
-> ValueEnv -> [(Ident, TypeInfo)] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TypeInfo -> ValueEnv -> ValueEnv
bindData (TypeInfo -> ValueEnv -> ValueEnv)
-> ((Ident, TypeInfo) -> TypeInfo)
-> (Ident, TypeInfo)
-> ValueEnv
-> ValueEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident, TypeInfo) -> TypeInfo
forall a b. (a, b) -> b
snd) ValueEnv
vEnv ([(Ident, TypeInfo)] -> ValueEnv)
-> [(Ident, TypeInfo)] -> ValueEnv
forall a b. (a -> b) -> a -> b
$ TCEnv -> [(Ident, TypeInfo)]
forall a. TopEnv a -> [(Ident, a)]
localBindings TCEnv
tcEnv
where
bindData :: TypeInfo -> ValueEnv -> ValueEnv
bindData (DataType tc :: QualIdent
tc k :: Kind
k cs :: [DataConstr]
cs) vEnv' :: ValueEnv
vEnv' =
((Ident, [QualIdent], Type) -> ValueEnv -> ValueEnv)
-> ValueEnv -> [(Ident, [QualIdent], Type)] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ModuleIdent
-> Int
-> Type
-> (Ident, [QualIdent], Type)
-> ValueEnv
-> ValueEnv
bindLabel ModuleIdent
m Int
n (QualIdent -> Int -> Type
constrType' QualIdent
tc Int
n)) ValueEnv
vEnv' ([(Ident, [QualIdent], Type)] -> ValueEnv)
-> [(Ident, [QualIdent], Type)] -> ValueEnv
forall a b. (a -> b) -> a -> b
$ ((Ident, [QualIdent], Type) -> (Ident, [QualIdent], Type) -> Bool)
-> [(Ident, [QualIdent], Type)] -> [(Ident, [QualIdent], Type)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Ident, [QualIdent], Type) -> (Ident, [QualIdent], Type) -> Bool
forall a b c b c. Eq a => (a, b, c) -> (a, b, c) -> Bool
sameLabel [(Ident, [QualIdent], Type)]
clabels
where
n :: Int
n = Kind -> Int
kindArity Kind
k
labels :: [(Ident, Type)]
labels = [Ident] -> [Type] -> [(Ident, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((DataConstr -> [Ident]) -> [DataConstr] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DataConstr -> [Ident]
recLabels [DataConstr]
cs) ((DataConstr -> [Type]) -> [DataConstr] -> [Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DataConstr -> [Type]
recLabelTypes [DataConstr]
cs)
clabels :: [(Ident, [QualIdent], Type)]
clabels = [(Ident
l, Ident -> [QualIdent]
constr Ident
l, Type
ty) | (l :: Ident
l, ty :: Type
ty) <- [(Ident, Type)]
labels]
constr :: Ident -> [QualIdent]
constr l :: Ident
l = [QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
tc (DataConstr -> Ident
constrIdent DataConstr
c)
| DataConstr
c <- [DataConstr]
cs, Ident
l Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DataConstr -> [Ident]
recLabels DataConstr
c]
sameLabel :: (a, b, c) -> (a, b, c) -> Bool
sameLabel (l1 :: a
l1, _, _) (l2 :: a
l2, _, _) = a
l1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
l2
bindData (RenamingType tc :: QualIdent
tc k :: Kind
k (RecordConstr c :: Ident
c [l :: Ident
l] [lty :: Type
lty])) vEnv' :: ValueEnv
vEnv'
= ModuleIdent
-> Int
-> Type
-> (Ident, [QualIdent], Type)
-> ValueEnv
-> ValueEnv
bindLabel ModuleIdent
m Int
n (QualIdent -> Int -> Type
constrType' QualIdent
tc Int
n) (Ident
l, [QualIdent
qc], Type
lty) ValueEnv
vEnv'
where
n :: Int
n = Kind -> Int
kindArity Kind
k
qc :: QualIdent
qc = QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
tc Ident
c
bindData (RenamingType _ _ (RecordConstr _ _ _)) _ =
String -> ValueEnv
forall a. String -> a
internalError (String -> ValueEnv) -> String -> ValueEnv
forall a b. (a -> b) -> a -> b
$ "Checks.TypeCheck.bindLabels'.bindData: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
"RenamingType with more than one record label"
bindData _ vEnv' :: ValueEnv
vEnv' = ValueEnv
vEnv'
bindLabel :: ModuleIdent -> Int -> Type -> (Ident, [QualIdent], Type)
-> ValueEnv -> ValueEnv
bindLabel :: ModuleIdent
-> Int
-> Type
-> (Ident, [QualIdent], Type)
-> ValueEnv
-> ValueEnv
bindLabel m :: ModuleIdent
m n :: Int
n ty :: Type
ty (l :: Ident
l, lcs :: [QualIdent]
lcs, lty :: Type
lty) =
(QualIdent -> TypeScheme -> ValueInfo)
-> ModuleIdent -> Ident -> TypeScheme -> ValueEnv -> ValueEnv
forall a.
(QualIdent -> a -> ValueInfo)
-> ModuleIdent -> Ident -> a -> ValueEnv -> ValueEnv
bindGlobalInfo (\qc :: QualIdent
qc tyScheme :: TypeScheme
tyScheme -> QualIdent -> [QualIdent] -> TypeScheme -> ValueInfo
Label QualIdent
qc [QualIdent]
lcs TypeScheme
tyScheme) ModuleIdent
m Ident
l
(Int -> PredType -> TypeScheme
ForAll Int
n (Type -> PredType
predType (Type -> Type -> Type
TypeArrow Type
ty Type
lty)))
bindClassMethods :: TCM ()
bindClassMethods :: TCM ()
bindClassMethods = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
TCEnv
tcEnv <- TCM TCEnv
getTyConsEnv
(ValueEnv -> ValueEnv) -> TCM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> TCM ())
-> (ValueEnv -> ValueEnv) -> TCM ()
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv
bindClassMethods' ModuleIdent
m TCEnv
tcEnv
bindClassMethods' :: ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv
bindClassMethods' :: ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv
bindClassMethods' m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv vEnv :: ValueEnv
vEnv =
((Ident, TypeInfo) -> ValueEnv -> ValueEnv)
-> ValueEnv -> [(Ident, TypeInfo)] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TypeInfo -> ValueEnv -> ValueEnv
bindMethods (TypeInfo -> ValueEnv -> ValueEnv)
-> ((Ident, TypeInfo) -> TypeInfo)
-> (Ident, TypeInfo)
-> ValueEnv
-> ValueEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident, TypeInfo) -> TypeInfo
forall a b. (a, b) -> b
snd) ValueEnv
vEnv ([(Ident, TypeInfo)] -> ValueEnv)
-> [(Ident, TypeInfo)] -> ValueEnv
forall a b. (a -> b) -> a -> b
$ TCEnv -> [(Ident, TypeInfo)]
forall a. TopEnv a -> [(Ident, a)]
localBindings TCEnv
tcEnv
where
bindMethods :: TypeInfo -> ValueEnv -> ValueEnv
bindMethods (TypeClass cls :: QualIdent
cls _ ms :: [ClassMethod]
ms) vEnv' :: ValueEnv
vEnv' =
(ClassMethod -> ValueEnv -> ValueEnv)
-> ValueEnv -> [ClassMethod] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ModuleIdent -> QualIdent -> ClassMethod -> ValueEnv -> ValueEnv
bindClassMethod ModuleIdent
m QualIdent
cls) ValueEnv
vEnv' [ClassMethod]
ms
bindMethods _ vEnv' :: ValueEnv
vEnv' =
ValueEnv
vEnv'
bindClassMethod :: ModuleIdent -> QualIdent -> ClassMethod -> ValueEnv
-> ValueEnv
bindClassMethod :: ModuleIdent -> QualIdent -> ClassMethod -> ValueEnv -> ValueEnv
bindClassMethod m :: ModuleIdent
m cls :: QualIdent
cls (ClassMethod f :: Ident
f _ ty :: PredType
ty) =
(QualIdent -> TypeScheme -> ValueInfo)
-> ModuleIdent -> Ident -> TypeScheme -> ValueEnv -> ValueEnv
forall a.
(QualIdent -> a -> ValueInfo)
-> ModuleIdent -> Ident -> a -> ValueEnv -> ValueEnv
bindGlobalInfo (\qc :: QualIdent
qc tySc :: TypeScheme
tySc -> QualIdent -> Maybe QualIdent -> Int -> TypeScheme -> ValueInfo
Value QualIdent
qc (QualIdent -> Maybe QualIdent
forall a. a -> Maybe a
Just QualIdent
cls) 0 TypeScheme
tySc) ModuleIdent
m Ident
f (PredType -> TypeScheme
typeScheme PredType
ty)
setDefaults :: Decl a -> TCM ()
setDefaults :: Decl a -> TCM ()
setDefaults (DefaultDecl _ tys :: [TypeExpr]
tys) = (TypeExpr -> StateT TcState Identity Type)
-> [TypeExpr] -> TCM [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeExpr -> StateT TcState Identity Type
toDefaultType [TypeExpr]
tys TCM [Type] -> ([Type] -> TCM ()) -> TCM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Type] -> TCM ()
setDefaultTypes
where
toDefaultType :: TypeExpr -> StateT TcState Identity Type
toDefaultType =
((PredSet, Type) -> Type)
-> StateT TcState Identity (PredSet, Type)
-> StateT TcState Identity Type
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PredSet, Type) -> Type
forall a b. (a, b) -> b
snd (StateT TcState Identity (PredSet, Type)
-> StateT TcState Identity Type)
-> (TypeExpr -> StateT TcState Identity (PredSet, Type))
-> TypeExpr
-> StateT TcState Identity Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeScheme -> StateT TcState Identity (PredSet, Type)
inst (TypeScheme -> StateT TcState Identity (PredSet, Type))
-> StateT TcState Identity TypeScheme
-> StateT TcState Identity (PredSet, Type)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (StateT TcState Identity TypeScheme
-> StateT TcState Identity (PredSet, Type))
-> (TypeExpr -> StateT TcState Identity TypeScheme)
-> TypeExpr
-> StateT TcState Identity (PredSet, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PredType -> TypeScheme)
-> StateT TcState Identity PredType
-> StateT TcState Identity TypeScheme
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM PredType -> TypeScheme
typeScheme
(StateT TcState Identity PredType
-> StateT TcState Identity TypeScheme)
-> (TypeExpr -> StateT TcState Identity PredType)
-> TypeExpr
-> StateT TcState Identity TypeScheme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualTypeExpr -> StateT TcState Identity PredType
expandPoly (QualTypeExpr -> StateT TcState Identity PredType)
-> (TypeExpr -> QualTypeExpr)
-> TypeExpr
-> StateT TcState Identity PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanInfo -> Context -> TypeExpr -> QualTypeExpr
QualTypeExpr SpanInfo
NoSpanInfo []
setDefaults _ = TCM ()
ok
type SigEnv = Map.Map Ident QualTypeExpr
emptySigEnv :: SigEnv
emptySigEnv :: SigEnv
emptySigEnv = SigEnv
forall k a. Map k a
Map.empty
bindTypeSig :: Ident -> QualTypeExpr -> SigEnv -> SigEnv
bindTypeSig :: Ident -> QualTypeExpr -> SigEnv -> SigEnv
bindTypeSig = Ident -> QualTypeExpr -> SigEnv -> SigEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
bindTypeSigs :: Decl a -> SigEnv -> SigEnv
bindTypeSigs :: Decl a -> SigEnv -> SigEnv
bindTypeSigs (TypeSig _ vs :: [Ident]
vs ty :: QualTypeExpr
ty) env :: SigEnv
env = (Ident -> SigEnv -> SigEnv) -> SigEnv -> [Ident] -> SigEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Ident -> QualTypeExpr -> SigEnv -> SigEnv
`bindTypeSig` QualTypeExpr
ty) SigEnv
env [Ident]
vs
bindTypeSigs _ env :: SigEnv
env = SigEnv
env
lookupTypeSig :: Ident -> SigEnv -> Maybe QualTypeExpr
lookupTypeSig :: Ident -> SigEnv -> Maybe QualTypeExpr
lookupTypeSig = Ident -> SigEnv -> Maybe QualTypeExpr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup
tcDecls :: [Decl a] -> TCM (PredSet, [Decl PredType])
tcDecls :: [Decl a] -> TCM (PredSet, [Decl PredType])
tcDecls = ((PredSet, [PDecl PredType]) -> (PredSet, [Decl PredType]))
-> TCM (PredSet, [PDecl PredType])
-> TCM (PredSet, [Decl PredType])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([PDecl PredType] -> [Decl PredType])
-> (PredSet, [PDecl PredType]) -> (PredSet, [Decl PredType])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [PDecl PredType] -> [Decl PredType]
forall a. [PDecl a] -> [Decl a]
fromPDecls) (TCM (PredSet, [PDecl PredType]) -> TCM (PredSet, [Decl PredType]))
-> ([Decl a] -> TCM (PredSet, [PDecl PredType]))
-> [Decl a]
-> TCM (PredSet, [Decl PredType])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PDecl a] -> TCM (PredSet, [PDecl PredType])
forall a. [PDecl a] -> TCM (PredSet, [PDecl PredType])
tcPDecls ([PDecl a] -> TCM (PredSet, [PDecl PredType]))
-> ([Decl a] -> [PDecl a])
-> [Decl a]
-> TCM (PredSet, [PDecl PredType])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Decl a] -> [PDecl a]
forall a. [Decl a] -> [PDecl a]
toPDecls
tcPDecls :: [PDecl a] -> TCM (PredSet, [PDecl PredType])
tcPDecls :: [PDecl a] -> TCM (PredSet, [PDecl PredType])
tcPDecls pds :: [PDecl a]
pds = TCM (PredSet, [PDecl PredType]) -> TCM (PredSet, [PDecl PredType])
forall a. TCM a -> TCM a
withLocalSigEnv (TCM (PredSet, [PDecl PredType])
-> TCM (PredSet, [PDecl PredType]))
-> TCM (PredSet, [PDecl PredType])
-> TCM (PredSet, [PDecl PredType])
forall a b. (a -> b) -> a -> b
$ do
let (vpds :: [PDecl a]
vpds, opds :: [PDecl a]
opds) = (PDecl a -> Bool) -> [PDecl a] -> ([PDecl a], [PDecl a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Decl a -> Bool
forall a. Decl a -> Bool
isValueDecl (Decl a -> Bool) -> (PDecl a -> Decl a) -> PDecl a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PDecl a -> Decl a
forall a b. (a, b) -> b
snd) [PDecl a]
pds
SigEnv -> TCM ()
setSigEnv (SigEnv -> TCM ()) -> SigEnv -> TCM ()
forall a b. (a -> b) -> a -> b
$ (PDecl a -> SigEnv -> SigEnv) -> SigEnv -> [PDecl a] -> SigEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Decl a -> SigEnv -> SigEnv
forall a. Decl a -> SigEnv -> SigEnv
bindTypeSigs (Decl a -> SigEnv -> SigEnv)
-> (PDecl a -> Decl a) -> PDecl a -> SigEnv -> SigEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PDecl a -> Decl a
forall a b. (a, b) -> b
snd) SigEnv
emptySigEnv ([PDecl a] -> SigEnv) -> [PDecl a] -> SigEnv
forall a b. (a -> b) -> a -> b
$ [PDecl a]
opds
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
(ps :: PredSet
ps, vpdss' :: [[PDecl PredType]]
vpdss') <-
(PredSet -> [PDecl a] -> TCM (PredSet, [PDecl PredType]))
-> PredSet
-> [[PDecl a]]
-> StateT TcState Identity (PredSet, [[PDecl PredType]])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM PredSet -> [PDecl a] -> TCM (PredSet, [PDecl PredType])
forall a. PredSet -> [PDecl a] -> TCM (PredSet, [PDecl PredType])
tcPDeclGroup PredSet
emptyPredSet ([[PDecl a]]
-> StateT TcState Identity (PredSet, [[PDecl PredType]]))
-> [[PDecl a]]
-> StateT TcState Identity (PredSet, [[PDecl PredType]])
forall a b. (a -> b) -> a -> b
$ (PDecl a -> [Ident])
-> (PDecl a -> [Ident]) -> [PDecl a] -> [[PDecl a]]
forall b a. Eq b => (a -> [b]) -> (a -> [b]) -> [a] -> [[a]]
scc (Decl a -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv (Decl a -> [Ident]) -> (PDecl a -> Decl a) -> PDecl a -> [Ident]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PDecl a -> Decl a
forall a b. (a, b) -> b
snd) (ModuleIdent -> Decl a -> [Ident]
forall e. QualExpr e => ModuleIdent -> e -> [Ident]
qfv ModuleIdent
m (Decl a -> [Ident]) -> (PDecl a -> Decl a) -> PDecl a -> [Ident]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PDecl a -> Decl a
forall a b. (a, b) -> b
snd) [PDecl a]
vpds
(PredSet, [PDecl PredType]) -> TCM (PredSet, [PDecl PredType])
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, (PDecl a -> PDecl PredType) -> [PDecl a] -> [PDecl PredType]
forall a b. (a -> b) -> [a] -> [b]
map PDecl a -> PDecl PredType
forall a b. PDecl a -> PDecl b
untyped [PDecl a]
opds [PDecl PredType] -> [PDecl PredType] -> [PDecl PredType]
forall a. [a] -> [a] -> [a]
++ [[PDecl PredType]] -> [PDecl PredType]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[PDecl PredType]]
vpdss' :: [[PDecl PredType]]))
tcPDeclGroup :: PredSet -> [PDecl a] -> TCM (PredSet, [PDecl PredType])
tcPDeclGroup :: PredSet -> [PDecl a] -> TCM (PredSet, [PDecl PredType])
tcPDeclGroup ps :: PredSet
ps [(i :: Int
i, ExternalDecl p :: SpanInfo
p fs :: [Var a]
fs)] = do
[Type]
tys <- (Var a -> StateT TcState Identity Type) -> [Var a] -> TCM [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Ident -> StateT TcState Identity Type
tcExternal (Ident -> StateT TcState Identity Type)
-> (Var a -> Ident) -> Var a -> StateT TcState Identity Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var a -> Ident
forall a. Var a -> Ident
varIdent) [Var a]
fs
(PredSet, [PDecl PredType]) -> TCM (PredSet, [PDecl PredType])
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, [(Int
i, SpanInfo -> [Var PredType] -> Decl PredType
forall a. SpanInfo -> [Var a] -> Decl a
ExternalDecl SpanInfo
p ((Type -> Var a -> Var PredType)
-> [Type] -> [Var a] -> [Var PredType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((a -> PredType) -> Var a -> Var PredType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> PredType) -> Var a -> Var PredType)
-> (Type -> a -> PredType) -> Type -> Var a -> Var PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredType -> a -> PredType
forall a b. a -> b -> a
const (PredType -> a -> PredType)
-> (Type -> PredType) -> Type -> a -> PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> PredType
predType) [Type]
tys [Var a]
fs))])
tcPDeclGroup ps :: PredSet
ps [(i :: Int
i, FreeDecl p :: SpanInfo
p fvs :: [Var a]
fvs)] = do
[(Ident, Int, TypeScheme)]
vs <- (Ident -> StateT TcState Identity (Ident, Int, TypeScheme))
-> [Ident] -> StateT TcState Identity [(Ident, Int, TypeScheme)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Ident -> StateT TcState Identity (Ident, Int, TypeScheme)
tcDeclVar Bool
False) ([Var a] -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv [Var a]
fvs)
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
(vs' :: [(Ident, Int, TypeScheme)]
vs', ps' :: [PredSet]
ps') <- [((Ident, Int, TypeScheme), PredSet)]
-> ([(Ident, Int, TypeScheme)], [PredSet])
forall a b. [(a, b)] -> ([a], [b])
unzip ([((Ident, Int, TypeScheme), PredSet)]
-> ([(Ident, Int, TypeScheme)], [PredSet]))
-> StateT TcState Identity [((Ident, Int, TypeScheme), PredSet)]
-> StateT TcState Identity ([(Ident, Int, TypeScheme)], [PredSet])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Ident, Int, TypeScheme)
-> StateT TcState Identity ((Ident, Int, TypeScheme), PredSet))
-> [(Ident, Int, TypeScheme)]
-> StateT TcState Identity [((Ident, Int, TypeScheme), PredSet)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Ident, Int, TypeScheme)
-> StateT TcState Identity ((Ident, Int, TypeScheme), PredSet)
forall b.
(Ident, b, TypeScheme)
-> StateT TcState Identity ((Ident, b, TypeScheme), PredSet)
addDataPred [(Ident, Int, TypeScheme)]
vs
(ValueEnv -> ValueEnv) -> TCM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> TCM ())
-> (ValueEnv -> ValueEnv) -> TCM ()
forall a b. (a -> b) -> a -> b
$ (ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv)
-> [(Ident, Int, TypeScheme)] -> ValueEnv -> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleIdent -> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv
bindVars ModuleIdent
m) [(Ident, Int, TypeScheme)]
vs'
let d :: Decl PredType
d = SpanInfo -> [Var PredType] -> Decl PredType
forall a. SpanInfo -> [Var a] -> Decl a
FreeDecl SpanInfo
p (((Ident, Int, TypeScheme) -> Var PredType)
-> [(Ident, Int, TypeScheme)] -> [Var PredType]
forall a b. (a -> b) -> [a] -> [b]
map (\(v :: Ident
v, _, ForAll _ ty :: PredType
ty) -> PredType -> Ident -> Var PredType
forall a. a -> Ident -> Var a
Var PredType
ty Ident
v) [(Ident, Int, TypeScheme)]
vs')
(PredSet, [PDecl PredType]) -> TCM (PredSet, [PDecl PredType])
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [PredSet] -> PredSet
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [PredSet]
ps', [(Int
i, Decl PredType
d)])
where
addDataPred :: (Ident, b, TypeScheme)
-> StateT TcState Identity ((Ident, b, TypeScheme), PredSet)
addDataPred (idt :: Ident
idt, n :: b
n, ForAll ids :: Int
ids ty1 :: PredType
ty1) = do
(ps2 :: PredSet
ps2, ty2 :: Type
ty2) <- StateT TcState Identity (PredSet, Type)
freshDataType
PredSet
ps' <- Ident
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unify Ident
idt "free variable" (Ident -> Doc
ppIdent Ident
idt) PredSet
emptyPredSet (PredType -> Type
unpredType PredType
ty1) PredSet
ps2 Type
ty2
((Ident, b, TypeScheme), PredSet)
-> StateT TcState Identity ((Ident, b, TypeScheme), PredSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Ident
idt, b
n, Int -> PredType -> TypeScheme
ForAll Int
ids PredType
ty1), PredSet
ps')
tcPDeclGroup ps :: PredSet
ps pds :: [PDecl a]
pds = do
ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
[[(Ident, Int, TypeScheme)]]
vss <- (PDecl a -> StateT TcState Identity [(Ident, Int, TypeScheme)])
-> [PDecl a]
-> StateT TcState Identity [[(Ident, Int, TypeScheme)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Decl a -> StateT TcState Identity [(Ident, Int, TypeScheme)]
forall a.
Decl a -> StateT TcState Identity [(Ident, Int, TypeScheme)]
tcDeclVars (Decl a -> StateT TcState Identity [(Ident, Int, TypeScheme)])
-> (PDecl a -> Decl a)
-> PDecl a
-> StateT TcState Identity [(Ident, Int, TypeScheme)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PDecl a -> Decl a
forall a b. (a, b) -> b
snd) [PDecl a]
pds
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
(ValueEnv -> ValueEnv) -> TCM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> TCM ())
-> (ValueEnv -> ValueEnv) -> TCM ()
forall a b. (a -> b) -> a -> b
$ (ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv)
-> [(Ident, Int, TypeScheme)] -> ValueEnv -> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleIdent -> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv
bindVars ModuleIdent
m) ([(Ident, Int, TypeScheme)] -> ValueEnv -> ValueEnv)
-> [(Ident, Int, TypeScheme)] -> ValueEnv -> ValueEnv
forall a b. (a -> b) -> a -> b
$ [[(Ident, Int, TypeScheme)]] -> [(Ident, Int, TypeScheme)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Ident, Int, TypeScheme)]]
vss
SigEnv
sigs <- TCM SigEnv
getSigEnv
let (impPds :: [PDecl a]
impPds, expPds :: [(QualTypeExpr, PDecl a)]
expPds) = SigEnv -> [PDecl a] -> ([PDecl a], [(QualTypeExpr, PDecl a)])
forall a.
SigEnv -> [PDecl a] -> ([PDecl a], [(QualTypeExpr, PDecl a)])
partitionPDecls SigEnv
sigs [PDecl a]
pds
(ps' :: PredSet
ps', impPds' :: [(Type, PDecl PredType)]
impPds') <- (PredSet
-> PDecl a
-> StateT TcState Identity (PredSet, (Type, PDecl PredType)))
-> PredSet
-> [PDecl a]
-> StateT TcState Identity (PredSet, [(Type, PDecl PredType)])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM PredSet
-> PDecl a
-> StateT TcState Identity (PredSet, (Type, PDecl PredType))
forall a.
PredSet
-> PDecl a
-> StateT TcState Identity (PredSet, (Type, PDecl PredType))
tcPDecl PredSet
ps [PDecl a]
impPds
TypeSubst
theta <- TCM TypeSubst
getTypeSubst
[Int]
tvs <- ((Type, PDecl PredType) -> [Int])
-> [(Type, PDecl PredType)] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Type -> [Int]
forall t. IsType t => t -> [Int]
typeVars (Type -> [Int])
-> ((Type, PDecl PredType) -> Type)
-> (Type, PDecl PredType)
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeSubst -> Type -> Type
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta (Type -> Type)
-> ((Type, PDecl PredType) -> Type)
-> (Type, PDecl PredType)
-> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, PDecl PredType) -> Type
forall a b. (a, b) -> a
fst) ([(Type, PDecl PredType)] -> [Int])
-> StateT TcState Identity [(Type, PDecl PredType)]
-> StateT TcState Identity [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
((Type, PDecl PredType) -> StateT TcState Identity Bool)
-> [(Type, PDecl PredType)]
-> StateT TcState Identity [(Type, PDecl PredType)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (StateT TcState Identity Bool -> StateT TcState Identity Bool
forall (m :: * -> *). Functor m => m Bool -> m Bool
notM (StateT TcState Identity Bool -> StateT TcState Identity Bool)
-> ((Type, PDecl PredType) -> StateT TcState Identity Bool)
-> (Type, PDecl PredType)
-> StateT TcState Identity Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decl PredType -> StateT TcState Identity Bool
forall a. Binding a => a -> StateT TcState Identity Bool
isNonExpansive (Decl PredType -> StateT TcState Identity Bool)
-> ((Type, PDecl PredType) -> Decl PredType)
-> (Type, PDecl PredType)
-> StateT TcState Identity Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PDecl PredType -> Decl PredType
forall a b. (a, b) -> b
snd (PDecl PredType -> Decl PredType)
-> ((Type, PDecl PredType) -> PDecl PredType)
-> (Type, PDecl PredType)
-> Decl PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, PDecl PredType) -> PDecl PredType
forall a b. (a, b) -> b
snd) [(Type, PDecl PredType)]
impPds'
let fvs :: Set Int
fvs = (Int -> Set Int -> Set Int) -> Set Int -> [Int] -> Set Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
Set.insert (ValueEnv -> Set Int
fvEnv (TypeSubst -> ValueEnv -> ValueEnv
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta ValueEnv
vEnv)) [Int]
tvs
(gps :: PredSet
gps, lps :: PredSet
lps) = Set Int -> PredSet -> (PredSet, PredSet)
splitPredSet Set Int
fvs PredSet
ps'
PredSet
lps' <- (PredSet -> (Type, PDecl PredType) -> TCM PredSet)
-> PredSet -> [(Type, PDecl PredType)] -> TCM PredSet
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Type -> PDecl PredType -> TCM PredSet)
-> (Type, PDecl PredType) -> TCM PredSet
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Type -> PDecl PredType -> TCM PredSet)
-> (Type, PDecl PredType) -> TCM PredSet)
-> (PredSet -> Type -> PDecl PredType -> TCM PredSet)
-> PredSet
-> (Type, PDecl PredType)
-> TCM PredSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Int -> PredSet -> Type -> PDecl PredType -> TCM PredSet
forall a. Set Int -> PredSet -> Type -> PDecl a -> TCM PredSet
defaultPDecl Set Int
fvs) PredSet
lps [(Type, PDecl PredType)]
impPds'
TypeSubst
theta' <- TCM TypeSubst
getTypeSubst
let impPds'' :: [PDecl PredType]
impPds'' = ((Type, PDecl PredType) -> PDecl PredType)
-> [(Type, PDecl PredType)] -> [PDecl PredType]
forall a b. (a -> b) -> [a] -> [b]
map ((Type -> PDecl PredType -> PDecl PredType)
-> (Type, PDecl PredType) -> PDecl PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (TypeScheme -> PDecl PredType -> PDecl PredType
fixType (TypeScheme -> PDecl PredType -> PDecl PredType)
-> (Type -> TypeScheme) -> Type -> PDecl PredType -> PDecl PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Int -> PredSet -> Type -> TypeScheme
gen Set Int
fvs PredSet
lps' (Type -> TypeScheme) -> (Type -> Type) -> Type -> TypeScheme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeSubst -> Type -> Type
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta')) [(Type, PDecl PredType)]
impPds'
(ValueEnv -> ValueEnv) -> TCM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> TCM ())
-> (ValueEnv -> ValueEnv) -> TCM ()
forall a b. (a -> b) -> a -> b
$ (ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv)
-> [(Ident, Int, TypeScheme)] -> ValueEnv -> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleIdent -> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv
rebindVars ModuleIdent
m) ((PDecl PredType -> [(Ident, Int, TypeScheme)])
-> [PDecl PredType] -> [(Ident, Int, TypeScheme)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Decl PredType -> [(Ident, Int, TypeScheme)]
declVars (Decl PredType -> [(Ident, Int, TypeScheme)])
-> (PDecl PredType -> Decl PredType)
-> PDecl PredType
-> [(Ident, Int, TypeScheme)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PDecl PredType -> Decl PredType
forall a b. (a, b) -> b
snd) [PDecl PredType]
impPds'')
(ps'' :: PredSet
ps'', expPds' :: [PDecl PredType]
expPds') <- (PredSet
-> (QualTypeExpr, PDecl a)
-> StateT TcState Identity (PredSet, PDecl PredType))
-> PredSet
-> [(QualTypeExpr, PDecl a)]
-> TCM (PredSet, [PDecl PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM ((QualTypeExpr
-> PDecl a -> StateT TcState Identity (PredSet, PDecl PredType))
-> (QualTypeExpr, PDecl a)
-> StateT TcState Identity (PredSet, PDecl PredType)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((QualTypeExpr
-> PDecl a -> StateT TcState Identity (PredSet, PDecl PredType))
-> (QualTypeExpr, PDecl a)
-> StateT TcState Identity (PredSet, PDecl PredType))
-> (PredSet
-> QualTypeExpr
-> PDecl a
-> StateT TcState Identity (PredSet, PDecl PredType))
-> PredSet
-> (QualTypeExpr, PDecl a)
-> StateT TcState Identity (PredSet, PDecl PredType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredSet
-> QualTypeExpr
-> PDecl a
-> StateT TcState Identity (PredSet, PDecl PredType)
forall a.
PredSet
-> QualTypeExpr
-> PDecl a
-> StateT TcState Identity (PredSet, PDecl PredType)
tcCheckPDecl) PredSet
gps [(QualTypeExpr, PDecl a)]
expPds
(PredSet, [PDecl PredType]) -> TCM (PredSet, [PDecl PredType])
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps'', [PDecl PredType]
impPds'' [PDecl PredType] -> [PDecl PredType] -> [PDecl PredType]
forall a. [a] -> [a] -> [a]
++ [PDecl PredType]
expPds')
partitionPDecls :: SigEnv -> [PDecl a] -> ([PDecl a], [(QualTypeExpr, PDecl a)])
partitionPDecls :: SigEnv -> [PDecl a] -> ([PDecl a], [(QualTypeExpr, PDecl a)])
partitionPDecls sigs :: SigEnv
sigs =
(PDecl a
-> ([PDecl a], [(QualTypeExpr, PDecl a)])
-> ([PDecl a], [(QualTypeExpr, PDecl a)]))
-> ([PDecl a], [(QualTypeExpr, PDecl a)])
-> [PDecl a]
-> ([PDecl a], [(QualTypeExpr, PDecl a)])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\pd :: PDecl a
pd -> (([PDecl a], [(QualTypeExpr, PDecl a)])
-> ([PDecl a], [(QualTypeExpr, PDecl a)]))
-> (QualTypeExpr
-> ([PDecl a], [(QualTypeExpr, PDecl a)])
-> ([PDecl a], [(QualTypeExpr, PDecl a)]))
-> Maybe QualTypeExpr
-> ([PDecl a], [(QualTypeExpr, PDecl a)])
-> ([PDecl a], [(QualTypeExpr, PDecl a)])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PDecl a
-> ([PDecl a], [(QualTypeExpr, PDecl a)])
-> ([PDecl a], [(QualTypeExpr, PDecl a)])
forall a b. a -> ([a], b) -> ([a], b)
implicit PDecl a
pd) (PDecl a
-> QualTypeExpr
-> ([PDecl a], [(QualTypeExpr, PDecl a)])
-> ([PDecl a], [(QualTypeExpr, PDecl a)])
forall b a a. b -> a -> (a, [(a, b)]) -> (a, [(a, b)])
explicit PDecl a
pd) (Decl a -> Maybe QualTypeExpr
forall a. Decl a -> Maybe QualTypeExpr
typeSig (Decl a -> Maybe QualTypeExpr) -> Decl a -> Maybe QualTypeExpr
forall a b. (a -> b) -> a -> b
$ PDecl a -> Decl a
forall a b. (a, b) -> b
snd PDecl a
pd)) ([], [])
where implicit :: a -> ([a], b) -> ([a], b)
implicit pd :: a
pd ~(impPds :: [a]
impPds, expPds :: b
expPds) = (a
pd a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
impPds, b
expPds)
explicit :: b -> a -> (a, [(a, b)]) -> (a, [(a, b)])
explicit pd :: b
pd qty :: a
qty ~(impPds :: a
impPds, expPds :: [(a, b)]
expPds) = (a
impPds, (a
qty, b
pd) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
expPds)
typeSig :: Decl a -> Maybe QualTypeExpr
typeSig (FunctionDecl _ _ f :: Ident
f _) = Ident -> SigEnv -> Maybe QualTypeExpr
lookupTypeSig Ident
f SigEnv
sigs
typeSig (PatternDecl _ (VariablePattern _ _ v :: Ident
v) _) = Ident -> SigEnv -> Maybe QualTypeExpr
lookupTypeSig Ident
v SigEnv
sigs
typeSig _ = Maybe QualTypeExpr
forall a. Maybe a
Nothing
bindVars :: ModuleIdent -> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv
bindVars :: ModuleIdent -> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv
bindVars m :: ModuleIdent
m = ((Ident, Int, TypeScheme) -> ValueEnv -> ValueEnv)
-> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (((Ident, Int, TypeScheme) -> ValueEnv -> ValueEnv)
-> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv)
-> ((Ident, Int, TypeScheme) -> ValueEnv -> ValueEnv)
-> ValueEnv
-> [(Ident, Int, TypeScheme)]
-> ValueEnv
forall a b. (a -> b) -> a -> b
$ (Ident -> Int -> TypeScheme -> ValueEnv -> ValueEnv)
-> (Ident, Int, TypeScheme) -> ValueEnv -> ValueEnv
forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 ((Ident -> Int -> TypeScheme -> ValueEnv -> ValueEnv)
-> (Ident, Int, TypeScheme) -> ValueEnv -> ValueEnv)
-> (Ident -> Int -> TypeScheme -> ValueEnv -> ValueEnv)
-> (Ident, Int, TypeScheme)
-> ValueEnv
-> ValueEnv
forall a b. (a -> b) -> a -> b
$ (Ident
-> Maybe QualIdent -> Int -> TypeScheme -> ValueEnv -> ValueEnv)
-> Maybe QualIdent
-> Ident
-> Int
-> TypeScheme
-> ValueEnv
-> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleIdent
-> Ident
-> Maybe QualIdent
-> Int
-> TypeScheme
-> ValueEnv
-> ValueEnv
bindFun ModuleIdent
m) Maybe QualIdent
forall a. Maybe a
Nothing
rebindVars :: ModuleIdent -> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv
rebindVars :: ModuleIdent -> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv
rebindVars m :: ModuleIdent
m = ((Ident, Int, TypeScheme) -> ValueEnv -> ValueEnv)
-> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (((Ident, Int, TypeScheme) -> ValueEnv -> ValueEnv)
-> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv)
-> ((Ident, Int, TypeScheme) -> ValueEnv -> ValueEnv)
-> ValueEnv
-> [(Ident, Int, TypeScheme)]
-> ValueEnv
forall a b. (a -> b) -> a -> b
$ (Ident -> Int -> TypeScheme -> ValueEnv -> ValueEnv)
-> (Ident, Int, TypeScheme) -> ValueEnv -> ValueEnv
forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 ((Ident -> Int -> TypeScheme -> ValueEnv -> ValueEnv)
-> (Ident, Int, TypeScheme) -> ValueEnv -> ValueEnv)
-> (Ident -> Int -> TypeScheme -> ValueEnv -> ValueEnv)
-> (Ident, Int, TypeScheme)
-> ValueEnv
-> ValueEnv
forall a b. (a -> b) -> a -> b
$ (Ident
-> Maybe QualIdent -> Int -> TypeScheme -> ValueEnv -> ValueEnv)
-> Maybe QualIdent
-> Ident
-> Int
-> TypeScheme
-> ValueEnv
-> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleIdent
-> Ident
-> Maybe QualIdent
-> Int
-> TypeScheme
-> ValueEnv
-> ValueEnv
rebindFun ModuleIdent
m) Maybe QualIdent
forall a. Maybe a
Nothing
tcDeclVars :: Decl a -> TCM [(Ident, Int, TypeScheme)]
tcDeclVars :: Decl a -> StateT TcState Identity [(Ident, Int, TypeScheme)]
tcDeclVars (FunctionDecl _ _ f :: Ident
f eqs :: [Equation a]
eqs) = do
SigEnv
sigs <- TCM SigEnv
getSigEnv
let n :: Int
n = Equation a -> Int
forall a. Equation a -> Int
eqnArity (Equation a -> Int) -> Equation a -> Int
forall a b. (a -> b) -> a -> b
$ [Equation a] -> Equation a
forall a. [a] -> a
head [Equation a]
eqs
case Ident -> SigEnv -> Maybe QualTypeExpr
lookupTypeSig Ident
f SigEnv
sigs of
Just qty :: QualTypeExpr
qty -> do
PredType
pty <- QualTypeExpr -> StateT TcState Identity PredType
expandPoly QualTypeExpr
qty
[(Ident, Int, TypeScheme)]
-> StateT TcState Identity [(Ident, Int, TypeScheme)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Ident
f, Int
n, PredType -> TypeScheme
typeScheme PredType
pty)]
Nothing -> do
[Type]
tys <- Int -> StateT TcState Identity Type -> TCM [Type]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) StateT TcState Identity Type
freshTypeVar
[(Ident, Int, TypeScheme)]
-> StateT TcState Identity [(Ident, Int, TypeScheme)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Ident
f, Int
n, Type -> TypeScheme
monoType (Type -> TypeScheme) -> Type -> TypeScheme
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
TypeArrow [Type]
tys)]
tcDeclVars (PatternDecl _ t :: Pattern a
t _) = case Pattern a
t of
VariablePattern _ _ v :: Ident
v -> (Ident, Int, TypeScheme) -> [(Ident, Int, TypeScheme)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Ident, Int, TypeScheme) -> [(Ident, Int, TypeScheme)])
-> StateT TcState Identity (Ident, Int, TypeScheme)
-> StateT TcState Identity [(Ident, Int, TypeScheme)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Ident -> StateT TcState Identity (Ident, Int, TypeScheme)
tcDeclVar Bool
True Ident
v
_ -> (Ident -> StateT TcState Identity (Ident, Int, TypeScheme))
-> [Ident] -> StateT TcState Identity [(Ident, Int, TypeScheme)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Ident -> StateT TcState Identity (Ident, Int, TypeScheme)
tcDeclVar Bool
False) (Pattern a -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv Pattern a
t)
tcDeclVars _ = String -> StateT TcState Identity [(Ident, Int, TypeScheme)]
forall a. String -> a
internalError "TypeCheck.tcDeclVars"
tcDeclVar :: Bool -> Ident -> TCM (Ident, Int, TypeScheme)
tcDeclVar :: Bool -> Ident -> StateT TcState Identity (Ident, Int, TypeScheme)
tcDeclVar poly :: Bool
poly v :: Ident
v = do
SigEnv
sigs <- TCM SigEnv
getSigEnv
case Ident -> SigEnv -> Maybe QualTypeExpr
lookupTypeSig Ident
v SigEnv
sigs of
Just qty :: QualTypeExpr
qty
| Bool
poly Bool -> Bool -> Bool
|| [Ident] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (QualTypeExpr -> [Ident]
forall e. Expr e => e -> [Ident]
fv QualTypeExpr
qty) -> do
PredType
pty <- QualTypeExpr -> StateT TcState Identity PredType
expandPoly QualTypeExpr
qty
(Ident, Int, TypeScheme)
-> StateT TcState Identity (Ident, Int, TypeScheme)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
v, 0, PredType -> TypeScheme
typeScheme PredType
pty)
| Bool
otherwise -> do
Message -> TCM ()
report (Message -> TCM ()) -> Message -> TCM ()
forall a b. (a -> b) -> a -> b
$ Ident -> Message
errPolymorphicVar Ident
v
Ident -> StateT TcState Identity (Ident, Int, TypeScheme)
lambdaVar Ident
v
Nothing -> Ident -> StateT TcState Identity (Ident, Int, TypeScheme)
lambdaVar Ident
v
tcPDecl :: PredSet -> PDecl a -> TCM (PredSet, (Type, PDecl PredType))
tcPDecl :: PredSet
-> PDecl a
-> StateT TcState Identity (PredSet, (Type, PDecl PredType))
tcPDecl ps :: PredSet
ps (i :: Int
i, FunctionDecl p :: SpanInfo
p _ f :: Ident
f eqs :: [Equation a]
eqs) = do
ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
Int
-> PredSet
-> TypeScheme
-> SpanInfo
-> Ident
-> [Equation a]
-> StateT TcState Identity (PredSet, (Type, PDecl PredType))
forall a.
Int
-> PredSet
-> TypeScheme
-> SpanInfo
-> Ident
-> [Equation a]
-> StateT TcState Identity (PredSet, (Type, PDecl PredType))
tcFunctionPDecl Int
i PredSet
ps (Ident -> ValueEnv -> TypeScheme
varType Ident
f ValueEnv
vEnv) SpanInfo
p Ident
f [Equation a]
eqs
tcPDecl ps :: PredSet
ps (i :: Int
i, d :: Decl a
d@(PatternDecl p :: SpanInfo
p t :: Pattern a
t rhs :: Rhs a
rhs)) = do
(ps' :: PredSet
ps', ty' :: Type
ty', t' :: Pattern PredType
t') <- SpanInfo -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern SpanInfo
p Pattern a
t
(ps'' :: PredSet
ps'', rhs' :: Rhs PredType
rhs') <- Rhs a -> TCM (PredSet, Type, Rhs PredType)
forall a. Rhs a -> TCM (PredSet, Type, Rhs PredType)
tcRhs Rhs a
rhs TCM (PredSet, Type, Rhs PredType)
-> (PredSet -> Type -> TCM PredSet)
-> StateT TcState Identity (PredSet, Rhs PredType)
forall (m :: * -> *) a b c.
Monad m =>
m (a, b, c) -> (a -> b -> m a) -> m (a, c)
>>-
SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unifyDecl SpanInfo
p "pattern declaration" (Decl a -> Doc
forall a. Pretty a => a -> Doc
pPrint Decl a
d) (PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps') Type
ty'
(PredSet, (Type, PDecl PredType))
-> StateT TcState Identity (PredSet, (Type, PDecl PredType))
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps'', (Type
ty', (Int
i, SpanInfo -> Pattern PredType -> Rhs PredType -> Decl PredType
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p Pattern PredType
t' Rhs PredType
rhs')))
tcPDecl _ _ = String -> StateT TcState Identity (PredSet, (Type, PDecl PredType))
forall a. String -> a
internalError "TypeCheck.tcPDecl"
tcFunctionPDecl :: Int -> PredSet -> TypeScheme -> SpanInfo -> Ident
-> [Equation a] -> TCM (PredSet, (Type, PDecl PredType))
tcFunctionPDecl :: Int
-> PredSet
-> TypeScheme
-> SpanInfo
-> Ident
-> [Equation a]
-> StateT TcState Identity (PredSet, (Type, PDecl PredType))
tcFunctionPDecl i :: Int
i ps :: PredSet
ps tySc :: TypeScheme
tySc@(ForAll _ pty :: PredType
pty) p :: SpanInfo
p f :: Ident
f eqs :: [Equation a]
eqs = do
(_, ty :: Type
ty) <- TypeScheme -> StateT TcState Identity (PredSet, Type)
inst TypeScheme
tySc
(ps' :: PredSet
ps', eqs' :: [Equation PredType]
eqs') <- (PredSet
-> Equation a
-> StateT TcState Identity (PredSet, Equation PredType))
-> PredSet
-> [Equation a]
-> StateT TcState Identity (PredSet, [Equation PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM (Type
-> PredSet
-> Equation a
-> StateT TcState Identity (PredSet, Equation PredType)
forall a.
Type
-> PredSet
-> Equation a
-> StateT TcState Identity (PredSet, Equation PredType)
tcEquation Type
ty) PredSet
ps [Equation a]
eqs
(PredSet, (Type, PDecl PredType))
-> StateT TcState Identity (PredSet, (Type, PDecl PredType))
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps', (Type
ty, (Int
i, SpanInfo
-> PredType -> Ident -> [Equation PredType] -> Decl PredType
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
p PredType
pty Ident
f [Equation PredType]
eqs')))
tcEquation :: Type -> PredSet -> Equation a
-> TCM (PredSet, Equation PredType)
tcEquation :: Type
-> PredSet
-> Equation a
-> StateT TcState Identity (PredSet, Equation PredType)
tcEquation ty :: Type
ty ps :: PredSet
ps eqn :: Equation a
eqn@(Equation p :: SpanInfo
p lhs :: Lhs a
lhs rhs :: Rhs a
rhs) =
SpanInfo
-> Lhs a -> Rhs a -> TCM (PredSet, Type, Equation PredType)
forall a.
SpanInfo
-> Lhs a -> Rhs a -> TCM (PredSet, Type, Equation PredType)
tcEqn SpanInfo
p Lhs a
lhs Rhs a
rhs TCM (PredSet, Type, Equation PredType)
-> (PredSet -> Type -> TCM PredSet)
-> StateT TcState Identity (PredSet, Equation PredType)
forall (m :: * -> *) a b c.
Monad m =>
m (a, b, c) -> (a -> b -> m a) -> m (a, c)
>>- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unifyDecl SpanInfo
p "equation" (Equation a -> Doc
forall a. Pretty a => a -> Doc
pPrint Equation a
eqn) PredSet
ps Type
ty
tcEqn :: SpanInfo -> Lhs a -> Rhs a
-> TCM (PredSet, Type, Equation PredType)
tcEqn :: SpanInfo
-> Lhs a -> Rhs a -> TCM (PredSet, Type, Equation PredType)
tcEqn p :: SpanInfo
p lhs :: Lhs a
lhs rhs :: Rhs a
rhs = do
(ps :: PredSet
ps, tys :: [Type]
tys, lhs' :: Lhs PredType
lhs', ps' :: PredSet
ps', ty :: Type
ty, rhs' :: Rhs PredType
rhs') <- TCM (PredSet, [Type], Lhs PredType, PredSet, Type, Rhs PredType)
-> TCM (PredSet, [Type], Lhs PredType, PredSet, Type, Rhs PredType)
forall a. TCM a -> TCM a
withLocalValueEnv (TCM (PredSet, [Type], Lhs PredType, PredSet, Type, Rhs PredType)
-> TCM
(PredSet, [Type], Lhs PredType, PredSet, Type, Rhs PredType))
-> TCM (PredSet, [Type], Lhs PredType, PredSet, Type, Rhs PredType)
-> TCM (PredSet, [Type], Lhs PredType, PredSet, Type, Rhs PredType)
forall a b. (a -> b) -> a -> b
$ do
Lhs a -> TCM ()
forall t. QuantExpr t => t -> TCM ()
bindLambdaVars Lhs a
lhs
(ps :: PredSet
ps, tys :: [Type]
tys, lhs' :: Lhs PredType
lhs') <- StateT (Set Ident) TCM (PredSet, [Type], Lhs PredType)
-> Set Ident -> TCM (PredSet, [Type], Lhs PredType)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
S.evalStateT (SpanInfo
-> Lhs a -> StateT (Set Ident) TCM (PredSet, [Type], Lhs PredType)
forall p a.
HasSpanInfo p =>
p
-> Lhs a -> StateT (Set Ident) TCM (PredSet, [Type], Lhs PredType)
tcLhs SpanInfo
p Lhs a
lhs) Set Ident
forall a. Set a
Set.empty
(ps' :: PredSet
ps', ty :: Type
ty, rhs' :: Rhs PredType
rhs') <- Rhs a -> TCM (PredSet, Type, Rhs PredType)
forall a. Rhs a -> TCM (PredSet, Type, Rhs PredType)
tcRhs Rhs a
rhs
(PredSet, [Type], Lhs PredType, PredSet, Type, Rhs PredType)
-> TCM (PredSet, [Type], Lhs PredType, PredSet, Type, Rhs PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, [Type]
tys, Lhs PredType
lhs', PredSet
ps', Type
ty, Rhs PredType
rhs')
PredSet
ps'' <- SpanInfo -> String -> Doc -> PredSet -> TCM PredSet
forall p.
HasSpanInfo p =>
p -> String -> Doc -> PredSet -> TCM PredSet
reducePredSet SpanInfo
p "equation" (Equation PredType -> Doc
forall a. Pretty a => a -> Doc
pPrint (SpanInfo -> Lhs PredType -> Rhs PredType -> Equation PredType
forall a. SpanInfo -> Lhs a -> Rhs a -> Equation a
Equation SpanInfo
p Lhs PredType
lhs' Rhs PredType
rhs'))
(PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps')
(PredSet, Type, Equation PredType)
-> TCM (PredSet, Type, Equation PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps'', (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
TypeArrow Type
ty [Type]
tys, SpanInfo -> Lhs PredType -> Rhs PredType -> Equation PredType
forall a. SpanInfo -> Lhs a -> Rhs a -> Equation a
Equation SpanInfo
p Lhs PredType
lhs' Rhs PredType
rhs')
bindLambdaVars :: QuantExpr t => t -> TCM ()
bindLambdaVars :: t -> TCM ()
bindLambdaVars t :: t
t = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
[(Ident, Int, TypeScheme)]
vs <- (Ident -> StateT TcState Identity (Ident, Int, TypeScheme))
-> [Ident] -> StateT TcState Identity [(Ident, Int, TypeScheme)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Ident -> StateT TcState Identity (Ident, Int, TypeScheme)
lambdaVar ([Ident] -> [Ident]
forall a. Eq a => [a] -> [a]
nub ([Ident] -> [Ident]) -> [Ident] -> [Ident]
forall a b. (a -> b) -> a -> b
$ t -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv t
t)
(ValueEnv -> ValueEnv) -> TCM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> TCM ())
-> (ValueEnv -> ValueEnv) -> TCM ()
forall a b. (a -> b) -> a -> b
$ (ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv)
-> [(Ident, Int, TypeScheme)] -> ValueEnv -> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleIdent -> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv
bindVars ModuleIdent
m) [(Ident, Int, TypeScheme)]
vs
lambdaVar :: Ident -> TCM (Ident, Int, TypeScheme)
lambdaVar :: Ident -> StateT TcState Identity (Ident, Int, TypeScheme)
lambdaVar v :: Ident
v = do
Type
ty <- StateT TcState Identity Type
freshTypeVar
(Ident, Int, TypeScheme)
-> StateT TcState Identity (Ident, Int, TypeScheme)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
v, 0, Type -> TypeScheme
monoType Type
ty)
unifyDecl :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type -> PredSet
-> Type
-> TCM PredSet
unifyDecl :: p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unifyDecl p :: p
p what :: String
what doc :: Doc
doc psLhs :: PredSet
psLhs tyLhs :: Type
tyLhs psRhs :: PredSet
psRhs tyRhs :: Type
tyRhs = do
PredSet
ps <- p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unify p
p String
what Doc
doc PredSet
psLhs Type
tyLhs PredSet
psRhs Type
tyRhs
Set Int
fvs <- TCM (Set Int)
computeFvEnv
p -> String -> Doc -> Set Int -> PredSet -> Type -> TCM PredSet
forall p.
HasSpanInfo p =>
p -> String -> Doc -> Set Int -> PredSet -> Type -> TCM PredSet
applyDefaultsDecl p
p String
what Doc
doc Set Int
fvs PredSet
ps Type
tyLhs
defaultPDecl :: Set.Set Int -> PredSet -> Type -> PDecl a -> TCM PredSet
defaultPDecl :: Set Int -> PredSet -> Type -> PDecl a -> TCM PredSet
defaultPDecl fvs :: Set Int
fvs ps :: PredSet
ps ty :: Type
ty (_, FunctionDecl p :: SpanInfo
p _ f :: Ident
f _) =
SpanInfo
-> String -> Doc -> Set Int -> PredSet -> Type -> TCM PredSet
forall p.
HasSpanInfo p =>
p -> String -> Doc -> Set Int -> PredSet -> Type -> TCM PredSet
applyDefaultsDecl SpanInfo
p ("function " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
escName Ident
f) Doc
empty Set Int
fvs PredSet
ps Type
ty
defaultPDecl fvs :: Set Int
fvs ps :: PredSet
ps ty :: Type
ty (_, PatternDecl p :: SpanInfo
p t :: Pattern a
t _) = case Pattern a
t of
VariablePattern _ _ v :: Ident
v ->
SpanInfo
-> String -> Doc -> Set Int -> PredSet -> Type -> TCM PredSet
forall p.
HasSpanInfo p =>
p -> String -> Doc -> Set Int -> PredSet -> Type -> TCM PredSet
applyDefaultsDecl SpanInfo
p ("variable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
escName Ident
v) Doc
empty Set Int
fvs PredSet
ps Type
ty
_ -> PredSet -> TCM PredSet
forall (m :: * -> *) a. Monad m => a -> m a
return PredSet
ps
defaultPDecl _ _ _ _ = String -> TCM PredSet
forall a. String -> a
internalError "TypeCheck.defaultPDecl"
applyDefaultsDecl :: HasSpanInfo p => p -> String -> Doc -> Set.Set Int
-> PredSet -> Type -> TCM PredSet
applyDefaultsDecl :: p -> String -> Doc -> Set Int -> PredSet -> Type -> TCM PredSet
applyDefaultsDecl p :: p
p what :: String
what doc :: Doc
doc fvs :: Set Int
fvs ps :: PredSet
ps ty :: Type
ty = do
TypeSubst
theta <- TCM TypeSubst
getTypeSubst
let ty' :: Type
ty' = TypeSubst -> Type -> Type
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta Type
ty
fvs' :: Set Int
fvs' = (Int -> Set Int -> Set Int) -> Set Int -> [Int] -> Set Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
Set.insert Set Int
fvs ([Int] -> Set Int) -> [Int] -> Set Int
forall a b. (a -> b) -> a -> b
$ Type -> [Int]
forall t. IsType t => t -> [Int]
typeVars Type
ty'
p -> String -> Doc -> Set Int -> PredSet -> Type -> TCM PredSet
forall p.
HasSpanInfo p =>
p -> String -> Doc -> Set Int -> PredSet -> Type -> TCM PredSet
applyDefaults p
p String
what Doc
doc Set Int
fvs' PredSet
ps Type
ty'
fixType :: TypeScheme -> PDecl PredType -> PDecl PredType
fixType :: TypeScheme -> PDecl PredType -> PDecl PredType
fixType ~(ForAll _ pty :: PredType
pty) (i :: Int
i, FunctionDecl p :: SpanInfo
p _ f :: Ident
f eqs :: [Equation PredType]
eqs) =
(Int
i, SpanInfo
-> PredType -> Ident -> [Equation PredType] -> Decl PredType
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
p PredType
pty Ident
f [Equation PredType]
eqs)
fixType ~(ForAll _ pty :: PredType
pty) pd :: PDecl PredType
pd@(i :: Int
i, PatternDecl p :: SpanInfo
p t :: Pattern PredType
t rhs :: Rhs PredType
rhs) = case Pattern PredType
t of
VariablePattern spi :: SpanInfo
spi _ v :: Ident
v
-> (Int
i, SpanInfo -> Pattern PredType -> Rhs PredType -> Decl PredType
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
spi PredType
pty Ident
v) Rhs PredType
rhs)
_ -> PDecl PredType
pd
fixType _ _ = String -> PDecl PredType
forall a. String -> a
internalError "TypeCheck.fixType"
declVars :: Decl PredType -> [(Ident, Int, TypeScheme)]
declVars :: Decl PredType -> [(Ident, Int, TypeScheme)]
declVars (FunctionDecl _ pty :: PredType
pty f :: Ident
f eqs :: [Equation PredType]
eqs) = [(Ident
f, Equation PredType -> Int
forall a. Equation a -> Int
eqnArity (Equation PredType -> Int) -> Equation PredType -> Int
forall a b. (a -> b) -> a -> b
$ [Equation PredType] -> Equation PredType
forall a. [a] -> a
head [Equation PredType]
eqs, PredType -> TypeScheme
typeScheme PredType
pty)]
declVars (PatternDecl _ t :: Pattern PredType
t _) = case Pattern PredType
t of
VariablePattern _ pty :: PredType
pty v :: Ident
v -> [(Ident
v, 0, PredType -> TypeScheme
typeScheme PredType
pty)]
_ -> []
declVars _ = String -> [(Ident, Int, TypeScheme)]
forall a. String -> a
internalError "TypeCheck.declVars"
tcCheckPDecl :: PredSet -> QualTypeExpr -> PDecl a
-> TCM (PredSet, PDecl PredType)
tcCheckPDecl :: PredSet
-> QualTypeExpr
-> PDecl a
-> StateT TcState Identity (PredSet, PDecl PredType)
tcCheckPDecl ps :: PredSet
ps qty :: QualTypeExpr
qty pd :: PDecl a
pd = do
(ps' :: PredSet
ps', (ty :: Type
ty, pd' :: PDecl PredType
pd')) <- PredSet
-> PDecl a
-> StateT TcState Identity (PredSet, (Type, PDecl PredType))
forall a.
PredSet
-> PDecl a
-> StateT TcState Identity (PredSet, (Type, PDecl PredType))
tcPDecl PredSet
ps PDecl a
pd
Set Int
fvs <- TCM (Set Int)
computeFvEnv
TypeSubst
theta <- TCM TypeSubst
getTypeSubst
Bool
poly <- Decl a -> StateT TcState Identity Bool
forall a. Binding a => a -> StateT TcState Identity Bool
isNonExpansive (Decl a -> StateT TcState Identity Bool)
-> Decl a -> StateT TcState Identity Bool
forall a b. (a -> b) -> a -> b
$ PDecl a -> Decl a
forall a b. (a, b) -> b
snd PDecl a
pd
let (gps :: PredSet
gps, lps :: PredSet
lps) = Set Int -> PredSet -> (PredSet, PredSet)
splitPredSet Set Int
fvs PredSet
ps'
ty' :: Type
ty' = TypeSubst -> Type -> Type
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta Type
ty
tySc :: TypeScheme
tySc = if Bool
poly then Set Int -> PredSet -> Type -> TypeScheme
gen Set Int
fvs PredSet
lps Type
ty' else Type -> TypeScheme
monoType Type
ty'
QualTypeExpr
-> PredSet
-> TypeScheme
-> PDecl PredType
-> StateT TcState Identity (PredSet, PDecl PredType)
checkPDeclType QualTypeExpr
qty PredSet
gps TypeScheme
tySc PDecl PredType
pd'
checkPDeclType :: QualTypeExpr -> PredSet -> TypeScheme -> PDecl PredType
-> TCM (PredSet, PDecl PredType)
checkPDeclType :: QualTypeExpr
-> PredSet
-> TypeScheme
-> PDecl PredType
-> StateT TcState Identity (PredSet, PDecl PredType)
checkPDeclType qty :: QualTypeExpr
qty ps :: PredSet
ps tySc :: TypeScheme
tySc (i :: Int
i, FunctionDecl p :: SpanInfo
p _ f :: Ident
f eqs :: [Equation PredType]
eqs) = do
PredType
pty <- QualTypeExpr -> StateT TcState Identity PredType
expandPoly QualTypeExpr
qty
StateT TcState Identity Bool -> TCM () -> TCM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PredType -> TypeScheme -> StateT TcState Identity Bool
checkTypeSig PredType
pty TypeScheme
tySc) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
Message -> TCM ()
report (Message -> TCM ()) -> Message -> TCM ()
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> Doc -> QualTypeExpr -> TypeScheme -> Message
errTypeSigTooGeneral ModuleIdent
m (String -> Doc
text "Function:" Doc -> Doc -> Doc
<+> Ident -> Doc
ppIdent Ident
f) QualTypeExpr
qty TypeScheme
tySc
(PredSet, PDecl PredType)
-> StateT TcState Identity (PredSet, PDecl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, (Int
i, SpanInfo
-> PredType -> Ident -> [Equation PredType] -> Decl PredType
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
p PredType
pty Ident
f [Equation PredType]
eqs))
checkPDeclType qty :: QualTypeExpr
qty ps :: PredSet
ps tySc :: TypeScheme
tySc (i :: Int
i, PatternDecl p :: SpanInfo
p (VariablePattern spi :: SpanInfo
spi _ v :: Ident
v) rhs :: Rhs PredType
rhs) = do
PredType
pty <- QualTypeExpr -> StateT TcState Identity PredType
expandPoly QualTypeExpr
qty
StateT TcState Identity Bool -> TCM () -> TCM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PredType -> TypeScheme -> StateT TcState Identity Bool
checkTypeSig PredType
pty TypeScheme
tySc) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
Message -> TCM ()
report (Message -> TCM ()) -> Message -> TCM ()
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> Doc -> QualTypeExpr -> TypeScheme -> Message
errTypeSigTooGeneral ModuleIdent
m (String -> Doc
text "Variable:" Doc -> Doc -> Doc
<+> Ident -> Doc
ppIdent Ident
v) QualTypeExpr
qty TypeScheme
tySc
(PredSet, PDecl PredType)
-> StateT TcState Identity (PredSet, PDecl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, (Int
i, SpanInfo -> Pattern PredType -> Rhs PredType -> Decl PredType
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
spi PredType
pty Ident
v) Rhs PredType
rhs))
checkPDeclType _ _ _ _ = String -> StateT TcState Identity (PredSet, PDecl PredType)
forall a. String -> a
internalError "TypeCheck.checkPDeclType"
checkTypeSig :: PredType -> TypeScheme -> TCM Bool
checkTypeSig :: PredType -> TypeScheme -> StateT TcState Identity Bool
checkTypeSig (PredType sigPs :: PredSet
sigPs sigTy :: Type
sigTy) (ForAll _ (PredType ps :: PredSet
ps ty :: Type
ty)) = do
ClassEnv
clsEnv <- TCM ClassEnv
getClassEnv
Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> StateT TcState Identity Bool)
-> Bool -> StateT TcState Identity Bool
forall a b. (a -> b) -> a -> b
$
Type
ty Type -> Type -> Bool
`eqTypes` Type
sigTy Bool -> Bool -> Bool
&&
(Pred -> Bool) -> [Pred] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Pred -> PredSet -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` ClassEnv -> PredSet -> PredSet
maxPredSet ClassEnv
clsEnv PredSet
sigPs) (PredSet -> [Pred]
forall a. Set a -> [a]
Set.toList PredSet
ps)
eqTypes :: Type -> Type -> Bool
eqTypes :: Type -> Type -> Bool
eqTypes t1 :: Type
t1 t2 :: Type
t2 = (Bool, [(Int, Int)]) -> Bool
forall a b. (a, b) -> a
fst ([(Int, Int)] -> Type -> Type -> (Bool, [(Int, Int)])
eq [] Type
t1 Type
t2)
where
eq :: [(Int, Int)] -> Type -> Type -> (Bool, [(Int, Int)])
eq is :: [(Int, Int)]
is (TypeConstructor qid1 :: QualIdent
qid1) (TypeConstructor qid2 :: QualIdent
qid2) = (QualIdent
qid1 QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qid2, [(Int, Int)]
is)
eq is :: [(Int, Int)]
is (TypeVariable i1 :: Int
i1) (TypeVariable i2 :: Int
i2)
| Int
i1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = (Bool
False, [(Int, Int)]
is)
| Bool
otherwise = [(Int, Int)] -> Int -> Int -> (Bool, [(Int, Int)])
forall a a. (Eq a, Eq a) => [(a, a)] -> a -> a -> (Bool, [(a, a)])
eqVar [(Int, Int)]
is Int
i1 Int
i2
eq is :: [(Int, Int)]
is (TypeConstrained ts1 :: [Type]
ts1 i1 :: Int
i1) (TypeConstrained ts2 :: [Type]
ts2 i2 :: Int
i2)
= let (res1 :: Bool
res1, is1 :: [(Int, Int)]
is1) = [(Int, Int)] -> [Type] -> [Type] -> (Bool, [(Int, Int)])
eqs [(Int, Int)]
is [Type]
ts1 [Type]
ts2
(res2 :: Bool
res2, is2 :: [(Int, Int)]
is2) = [(Int, Int)] -> Int -> Int -> (Bool, [(Int, Int)])
forall a a. (Eq a, Eq a) => [(a, a)] -> a -> a -> (Bool, [(a, a)])
eqVar [(Int, Int)]
is1 Int
i1 Int
i2
in (Bool
res1 Bool -> Bool -> Bool
&& Bool
res2, [(Int, Int)]
is2)
eq is :: [(Int, Int)]
is (TypeApply ta1 :: Type
ta1 tb1 :: Type
tb1) (TypeApply ta2 :: Type
ta2 tb2 :: Type
tb2)
= let (res1 :: Bool
res1, is1 :: [(Int, Int)]
is1) = [(Int, Int)] -> Type -> Type -> (Bool, [(Int, Int)])
eq [(Int, Int)]
is Type
ta1 Type
ta2
(res2 :: Bool
res2, is2 :: [(Int, Int)]
is2) = [(Int, Int)] -> Type -> Type -> (Bool, [(Int, Int)])
eq [(Int, Int)]
is1 Type
tb1 Type
tb2
in (Bool
res1 Bool -> Bool -> Bool
&& Bool
res2, [(Int, Int)]
is2)
eq is :: [(Int, Int)]
is (TypeArrow tf1 :: Type
tf1 tt1 :: Type
tt1) (TypeArrow tf2 :: Type
tf2 tt2 :: Type
tt2)
= let (res1 :: Bool
res1, is1 :: [(Int, Int)]
is1) = [(Int, Int)] -> Type -> Type -> (Bool, [(Int, Int)])
eq [(Int, Int)]
is Type
tf1 Type
tf2
(res2 :: Bool
res2, is2 :: [(Int, Int)]
is2) = [(Int, Int)] -> Type -> Type -> (Bool, [(Int, Int)])
eq [(Int, Int)]
is1 Type
tt1 Type
tt2
in (Bool
res1 Bool -> Bool -> Bool
&& Bool
res2, [(Int, Int)]
is2)
eq is :: [(Int, Int)]
is (TypeForall is1 :: [Int]
is1 t1' :: Type
t1') (TypeForall is2 :: [Int]
is2 t2' :: Type
t2')
= let (res1 :: Bool
res1, is' :: [(Int, Int)]
is') = [(Int, Int)] -> [Type] -> [Type] -> (Bool, [(Int, Int)])
eqs [] ((Int -> Type) -> [Int] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Type
TypeVariable [Int]
is1) ((Int -> Type) -> [Int] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Type
TypeVariable [Int]
is2)
(res2 :: Bool
res2, _ ) = [(Int, Int)] -> Type -> Type -> (Bool, [(Int, Int)])
eq [(Int, Int)]
is' Type
t1' Type
t2'
in (Bool
res1 Bool -> Bool -> Bool
&& Bool
res2, [(Int, Int)]
is)
eq is :: [(Int, Int)]
is _ _ = (Bool
False, [(Int, Int)]
is)
eqVar :: [(a, a)] -> a -> a -> (Bool, [(a, a)])
eqVar is :: [(a, a)]
is i1 :: a
i1 i2 :: a
i2 = case a -> [(a, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
i1 [(a, a)]
is of
Nothing -> (Bool
True, (a
i1, a
i2) (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: [(a, a)]
is)
Just i2' :: a
i2' -> (a
i2 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
i2', [(a, a)]
is)
eqs :: [(Int, Int)] -> [Type] -> [Type] -> (Bool, [(Int, Int)])
eqs is :: [(Int, Int)]
is [] [] = (Bool
True , [(Int, Int)]
is)
eqs is :: [(Int, Int)]
is (t1' :: Type
t1':ts1 :: [Type]
ts1) (t2' :: Type
t2':ts2 :: [Type]
ts2)
= let (res1 :: Bool
res1, is1 :: [(Int, Int)]
is1) = [(Int, Int)] -> Type -> Type -> (Bool, [(Int, Int)])
eq [(Int, Int)]
is Type
t1' Type
t2'
(res2 :: Bool
res2, is2 :: [(Int, Int)]
is2) = [(Int, Int)] -> [Type] -> [Type] -> (Bool, [(Int, Int)])
eqs [(Int, Int)]
is1 [Type]
ts1 [Type]
ts2
in (Bool
res1 Bool -> Bool -> Bool
&& Bool
res2, [(Int, Int)]
is2)
eqs is :: [(Int, Int)]
is _ _ = (Bool
False, [(Int, Int)]
is)
class Binding a where
isNonExpansive :: a -> TCM Bool
instance Binding a => Binding [a] where
isNonExpansive :: [a] -> StateT TcState Identity Bool
isNonExpansive = (a -> StateT TcState Identity Bool)
-> [a] -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM a -> StateT TcState Identity Bool
forall a. Binding a => a -> StateT TcState Identity Bool
isNonExpansive
instance Binding (Decl a) where
isNonExpansive :: Decl a -> StateT TcState Identity Bool
isNonExpansive (InfixDecl _ _ _ _) = Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isNonExpansive (TypeSig _ _ _) = Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isNonExpansive (FunctionDecl _ _ _ _) = Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isNonExpansive (ExternalDecl _ _) = Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isNonExpansive (PatternDecl _ _ _) = Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isNonExpansive (FreeDecl _ _) = Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isNonExpansive _ =
String -> StateT TcState Identity Bool
forall a. String -> a
internalError "TypeCheck.isNonExpansive: declaration"
instance Binding (Rhs a) where
isNonExpansive :: Rhs a -> StateT TcState Identity Bool
isNonExpansive (GuardedRhs _ _ _ _) = Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isNonExpansive (SimpleRhs _ _ e :: Expression a
e ds :: [Decl a]
ds) = StateT TcState Identity Bool -> StateT TcState Identity Bool
forall a. TCM a -> TCM a
withLocalValueEnv (StateT TcState Identity Bool -> StateT TcState Identity Bool)
-> StateT TcState Identity Bool -> StateT TcState Identity Bool
forall a b. (a -> b) -> a -> b
$ do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
TCEnv
tcEnv <- TCM TCEnv
getTyConsEnv
ClassEnv
clsEnv <- TCM ClassEnv
getClassEnv
SigEnv
sigs <- TCM SigEnv
getSigEnv
(ValueEnv -> ValueEnv) -> TCM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> TCM ())
-> (ValueEnv -> ValueEnv) -> TCM ()
forall a b. (a -> b) -> a -> b
$ (ValueEnv -> [Decl a] -> ValueEnv)
-> [Decl a] -> ValueEnv -> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Decl a -> ValueEnv -> ValueEnv)
-> ValueEnv -> [Decl a] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ModuleIdent
-> TCEnv -> ClassEnv -> SigEnv -> Decl a -> ValueEnv -> ValueEnv
forall a.
ModuleIdent
-> TCEnv -> ClassEnv -> SigEnv -> Decl a -> ValueEnv -> ValueEnv
bindDeclArity ModuleIdent
m TCEnv
tcEnv ClassEnv
clsEnv SigEnv
sigs)) [Decl a]
ds
Expression a -> StateT TcState Identity Bool
forall a. Binding a => a -> StateT TcState Identity Bool
isNonExpansive Expression a
e StateT TcState Identity Bool
-> StateT TcState Identity Bool -> StateT TcState Identity Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ [Decl a] -> StateT TcState Identity Bool
forall a. Binding a => a -> StateT TcState Identity Bool
isNonExpansive [Decl a]
ds
instance Binding (Expression a) where
isNonExpansive :: Expression a -> StateT TcState Identity Bool
isNonExpansive = Int -> Expression a -> StateT TcState Identity Bool
forall a. Int -> Expression a -> StateT TcState Identity Bool
isNonExpansive' 0
isNonExpansive' :: Int -> Expression a -> TCM Bool
isNonExpansive' :: Int -> Expression a -> StateT TcState Identity Bool
isNonExpansive' _ (Literal _ _ _) = Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isNonExpansive' n :: Int
n (Variable _ _ v :: QualIdent
v)
| Ident
v' Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
anonId = Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Ident -> Bool
isRenamed Ident
v' = do
ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> StateT TcState Identity Bool)
-> Bool -> StateT TcState Identity Bool
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< QualIdent -> ValueEnv -> Int
varArity QualIdent
v ValueEnv
vEnv
| Bool
otherwise = do
ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> StateT TcState Identity Bool)
-> Bool -> StateT TcState Identity Bool
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< QualIdent -> ValueEnv -> Int
varArity QualIdent
v ValueEnv
vEnv
where v' :: Ident
v' = QualIdent -> Ident
unqualify QualIdent
v
isNonExpansive' _ (Constructor _ _ _) = Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isNonExpansive' n :: Int
n (Paren _ e :: Expression a
e) = Int -> Expression a -> StateT TcState Identity Bool
forall a. Int -> Expression a -> StateT TcState Identity Bool
isNonExpansive' Int
n Expression a
e
isNonExpansive' n :: Int
n (Typed _ e :: Expression a
e _) = Int -> Expression a -> StateT TcState Identity Bool
forall a. Int -> Expression a -> StateT TcState Identity Bool
isNonExpansive' Int
n Expression a
e
isNonExpansive' _ (Record _ _ c :: QualIdent
c fs :: [Field (Expression a)]
fs) = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
(Bool -> Bool)
-> StateT TcState Identity Bool -> StateT TcState Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Ident] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ModuleIdent -> QualIdent -> ValueEnv -> [Ident]
constrLabels ModuleIdent
m QualIdent
c ValueEnv
vEnv) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Field (Expression a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Field (Expression a)]
fs) Bool -> Bool -> Bool
&&) ([Field (Expression a)] -> StateT TcState Identity Bool
forall a. Binding a => a -> StateT TcState Identity Bool
isNonExpansive [Field (Expression a)]
fs)
isNonExpansive' _ (Tuple _ es :: [Expression a]
es) = [Expression a] -> StateT TcState Identity Bool
forall a. Binding a => a -> StateT TcState Identity Bool
isNonExpansive [Expression a]
es
isNonExpansive' _ (List _ _ es :: [Expression a]
es) = [Expression a] -> StateT TcState Identity Bool
forall a. Binding a => a -> StateT TcState Identity Bool
isNonExpansive [Expression a]
es
isNonExpansive' n :: Int
n (Apply _ f :: Expression a
f e :: Expression a
e) = Int -> Expression a -> StateT TcState Identity Bool
forall a. Int -> Expression a -> StateT TcState Identity Bool
isNonExpansive' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Expression a
f
StateT TcState Identity Bool
-> StateT TcState Identity Bool -> StateT TcState Identity Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ Expression a -> StateT TcState Identity Bool
forall a. Binding a => a -> StateT TcState Identity Bool
isNonExpansive Expression a
e
isNonExpansive' n :: Int
n (InfixApply _ e1 :: Expression a
e1 op :: InfixOp a
op e2 :: Expression a
e2)
= Int -> Expression a -> StateT TcState Identity Bool
forall a. Int -> Expression a -> StateT TcState Identity Bool
isNonExpansive' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2) (InfixOp a -> Expression a
forall a. InfixOp a -> Expression a
infixOp InfixOp a
op) StateT TcState Identity Bool
-> StateT TcState Identity Bool -> StateT TcState Identity Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ Expression a -> StateT TcState Identity Bool
forall a. Binding a => a -> StateT TcState Identity Bool
isNonExpansive Expression a
e1
StateT TcState Identity Bool
-> StateT TcState Identity Bool -> StateT TcState Identity Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ Expression a -> StateT TcState Identity Bool
forall a. Binding a => a -> StateT TcState Identity Bool
isNonExpansive Expression a
e2
isNonExpansive' n :: Int
n (LeftSection _ e :: Expression a
e op :: InfixOp a
op) = Int -> Expression a -> StateT TcState Identity Bool
forall a. Int -> Expression a -> StateT TcState Identity Bool
isNonExpansive' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (InfixOp a -> Expression a
forall a. InfixOp a -> Expression a
infixOp InfixOp a
op)
StateT TcState Identity Bool
-> StateT TcState Identity Bool -> StateT TcState Identity Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ Expression a -> StateT TcState Identity Bool
forall a. Binding a => a -> StateT TcState Identity Bool
isNonExpansive Expression a
e
isNonExpansive' n :: Int
n (Lambda _ ts :: [Pattern a]
ts e :: Expression a
e) = StateT TcState Identity Bool -> StateT TcState Identity Bool
forall a. TCM a -> TCM a
withLocalValueEnv (StateT TcState Identity Bool -> StateT TcState Identity Bool)
-> StateT TcState Identity Bool -> StateT TcState Identity Bool
forall a b. (a -> b) -> a -> b
$ do
(ValueEnv -> ValueEnv) -> TCM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> TCM ())
-> (ValueEnv -> ValueEnv) -> TCM ()
forall a b. (a -> b) -> a -> b
$ (ValueEnv -> [Ident] -> ValueEnv)
-> [Ident] -> ValueEnv -> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Ident -> ValueEnv -> ValueEnv) -> ValueEnv -> [Ident] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ident -> ValueEnv -> ValueEnv
bindVarArity) ([Pattern a] -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv [Pattern a]
ts)
(Bool -> Bool)
-> StateT TcState Identity Bool -> StateT TcState Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Pattern a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern a]
ts) Bool -> Bool -> Bool
||) (Bool -> Bool) -> (Bool -> Bool) -> Bool -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Pattern a -> Bool) -> [Pattern a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Pattern a -> Bool
forall a. Pattern a -> Bool
isVariablePattern [Pattern a]
ts Bool -> Bool -> Bool
&&))
(Int -> Expression a -> StateT TcState Identity Bool
forall a. Int -> Expression a -> StateT TcState Identity Bool
isNonExpansive' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Pattern a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern a]
ts) Expression a
e)
isNonExpansive' n :: Int
n (Let _ _ ds :: [Decl a]
ds e :: Expression a
e) = StateT TcState Identity Bool -> StateT TcState Identity Bool
forall a. TCM a -> TCM a
withLocalValueEnv (StateT TcState Identity Bool -> StateT TcState Identity Bool)
-> StateT TcState Identity Bool -> StateT TcState Identity Bool
forall a b. (a -> b) -> a -> b
$ do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
TCEnv
tcEnv <- TCM TCEnv
getTyConsEnv
ClassEnv
clsEnv <- TCM ClassEnv
getClassEnv
SigEnv
sigs <- TCM SigEnv
getSigEnv
(ValueEnv -> ValueEnv) -> TCM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> TCM ())
-> (ValueEnv -> ValueEnv) -> TCM ()
forall a b. (a -> b) -> a -> b
$ (ValueEnv -> [Decl a] -> ValueEnv)
-> [Decl a] -> ValueEnv -> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Decl a -> ValueEnv -> ValueEnv)
-> ValueEnv -> [Decl a] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ModuleIdent
-> TCEnv -> ClassEnv -> SigEnv -> Decl a -> ValueEnv -> ValueEnv
forall a.
ModuleIdent
-> TCEnv -> ClassEnv -> SigEnv -> Decl a -> ValueEnv -> ValueEnv
bindDeclArity ModuleIdent
m TCEnv
tcEnv ClassEnv
clsEnv SigEnv
sigs)) [Decl a]
ds
[Decl a] -> StateT TcState Identity Bool
forall a. Binding a => a -> StateT TcState Identity Bool
isNonExpansive [Decl a]
ds StateT TcState Identity Bool
-> StateT TcState Identity Bool -> StateT TcState Identity Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ Int -> Expression a -> StateT TcState Identity Bool
forall a. Int -> Expression a -> StateT TcState Identity Bool
isNonExpansive' Int
n Expression a
e
isNonExpansive' _ _ = Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
instance Binding a => Binding (Field a) where
isNonExpansive :: Field a -> StateT TcState Identity Bool
isNonExpansive (Field _ _ e :: a
e) = a -> StateT TcState Identity Bool
forall a. Binding a => a -> StateT TcState Identity Bool
isNonExpansive a
e
bindDeclArity :: ModuleIdent -> TCEnv -> ClassEnv -> SigEnv -> Decl a
-> ValueEnv -> ValueEnv
bindDeclArity :: ModuleIdent
-> TCEnv -> ClassEnv -> SigEnv -> Decl a -> ValueEnv -> ValueEnv
bindDeclArity _ _ _ _ (InfixDecl _ _ _ _) = ValueEnv -> ValueEnv
forall a. a -> a
id
bindDeclArity _ _ _ _ (TypeSig _ _ _) = ValueEnv -> ValueEnv
forall a. a -> a
id
bindDeclArity _ _ _ _ (FunctionDecl _ _ f :: Ident
f eqs :: [Equation a]
eqs) =
Ident -> Int -> ValueEnv -> ValueEnv
bindArity Ident
f (Equation a -> Int
forall a. Equation a -> Int
eqnArity (Equation a -> Int) -> Equation a -> Int
forall a b. (a -> b) -> a -> b
$ [Equation a] -> Equation a
forall a. [a] -> a
head [Equation a]
eqs)
bindDeclArity m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv clsEnv :: ClassEnv
clsEnv sigs :: SigEnv
sigs (ExternalDecl _ fs :: [Var a]
fs) =
(ValueEnv -> [Var a] -> ValueEnv)
-> [Var a] -> ValueEnv -> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Var a -> ValueEnv -> ValueEnv) -> ValueEnv -> [Var a] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Var a -> ValueEnv -> ValueEnv)
-> ValueEnv -> [Var a] -> ValueEnv)
-> (Var a -> ValueEnv -> ValueEnv)
-> ValueEnv
-> [Var a]
-> ValueEnv
forall a b. (a -> b) -> a -> b
$ \(Var _ f :: Ident
f) -> Ident -> Int -> ValueEnv -> ValueEnv
bindArity Ident
f (Int -> ValueEnv -> ValueEnv) -> Int -> ValueEnv -> ValueEnv
forall a b. (a -> b) -> a -> b
$ Type -> Int
arrowArity (Type -> Int) -> Type -> Int
forall a b. (a -> b) -> a -> b
$ Ident -> Type
ty Ident
f) [Var a]
fs
where ty :: Ident -> Type
ty = PredType -> Type
unpredType (PredType -> Type) -> (Ident -> PredType) -> Ident -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent -> TCEnv -> ClassEnv -> QualTypeExpr -> PredType
expandPolyType ModuleIdent
m TCEnv
tcEnv ClassEnv
clsEnv (QualTypeExpr -> PredType)
-> (Ident -> QualTypeExpr) -> Ident -> PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe QualTypeExpr -> QualTypeExpr
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe QualTypeExpr -> QualTypeExpr)
-> (Ident -> Maybe QualTypeExpr) -> Ident -> QualTypeExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Ident -> SigEnv -> Maybe QualTypeExpr)
-> SigEnv -> Ident -> Maybe QualTypeExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ident -> SigEnv -> Maybe QualTypeExpr
lookupTypeSig SigEnv
sigs
bindDeclArity _ _ _ _ (PatternDecl _ t :: Pattern a
t _) =
(ValueEnv -> [Ident] -> ValueEnv)
-> [Ident] -> ValueEnv -> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Ident -> ValueEnv -> ValueEnv) -> ValueEnv -> [Ident] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ident -> ValueEnv -> ValueEnv
bindVarArity) (Pattern a -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv Pattern a
t)
bindDeclArity _ _ _ _ (FreeDecl _ vs :: [Var a]
vs) =
(ValueEnv -> [Ident] -> ValueEnv)
-> [Ident] -> ValueEnv -> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Ident -> ValueEnv -> ValueEnv) -> ValueEnv -> [Ident] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ident -> ValueEnv -> ValueEnv
bindVarArity) ([Var a] -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv [Var a]
vs)
bindDeclArity _ _ _ _ _ =
String -> ValueEnv -> ValueEnv
forall a. String -> a
internalError "TypeCheck.bindDeclArity"
bindVarArity :: Ident -> ValueEnv -> ValueEnv
bindVarArity :: Ident -> ValueEnv -> ValueEnv
bindVarArity v :: Ident
v = Ident -> Int -> ValueEnv -> ValueEnv
bindArity Ident
v 0
bindArity :: Ident -> Int -> ValueEnv -> ValueEnv
bindArity :: Ident -> Int -> ValueEnv -> ValueEnv
bindArity v :: Ident
v n :: Int
n = Ident -> ValueInfo -> ValueEnv -> ValueEnv
forall a. Ident -> a -> TopEnv a -> TopEnv a
bindTopEnv Ident
v (QualIdent -> Maybe QualIdent -> Int -> TypeScheme -> ValueInfo
Value (Ident -> QualIdent
qualify Ident
v) Maybe QualIdent
forall a. Maybe a
Nothing Int
n TypeScheme
forall a. HasCallStack => a
undefined)
tcTopPDecl :: PDecl a -> TCM (PDecl PredType)
tcTopPDecl :: PDecl a -> StateT TcState Identity (PDecl PredType)
tcTopPDecl (i :: Int
i, DataDecl p :: SpanInfo
p tc :: Ident
tc tvs :: [Ident]
tvs cs :: [ConstrDecl]
cs clss :: [QualIdent]
clss)
= PDecl PredType -> StateT TcState Identity (PDecl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> [QualIdent] -> Decl PredType
forall a.
SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> [QualIdent] -> Decl a
DataDecl SpanInfo
p Ident
tc [Ident]
tvs [ConstrDecl]
cs [QualIdent]
clss)
tcTopPDecl (i :: Int
i, ExternalDataDecl p :: SpanInfo
p tc :: Ident
tc tvs :: [Ident]
tvs)
= PDecl PredType -> StateT TcState Identity (PDecl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, SpanInfo -> Ident -> [Ident] -> Decl PredType
forall a. SpanInfo -> Ident -> [Ident] -> Decl a
ExternalDataDecl SpanInfo
p Ident
tc [Ident]
tvs)
tcTopPDecl (i :: Int
i, NewtypeDecl p :: SpanInfo
p tc :: Ident
tc tvs :: [Ident]
tvs nc :: NewConstrDecl
nc clss :: [QualIdent]
clss)
= PDecl PredType -> StateT TcState Identity (PDecl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, SpanInfo
-> Ident
-> [Ident]
-> NewConstrDecl
-> [QualIdent]
-> Decl PredType
forall a.
SpanInfo
-> Ident -> [Ident] -> NewConstrDecl -> [QualIdent] -> Decl a
NewtypeDecl SpanInfo
p Ident
tc [Ident]
tvs NewConstrDecl
nc [QualIdent]
clss)
tcTopPDecl (i :: Int
i, TypeDecl p :: SpanInfo
p tc :: Ident
tc tvs :: [Ident]
tvs ty :: TypeExpr
ty)
= PDecl PredType -> StateT TcState Identity (PDecl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, SpanInfo -> Ident -> [Ident] -> TypeExpr -> Decl PredType
forall a. SpanInfo -> Ident -> [Ident] -> TypeExpr -> Decl a
TypeDecl SpanInfo
p Ident
tc [Ident]
tvs TypeExpr
ty)
tcTopPDecl (i :: Int
i, DefaultDecl p :: SpanInfo
p tys :: [TypeExpr]
tys)
= PDecl PredType -> StateT TcState Identity (PDecl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, SpanInfo -> [TypeExpr] -> Decl PredType
forall a. SpanInfo -> [TypeExpr] -> Decl a
DefaultDecl SpanInfo
p [TypeExpr]
tys)
tcTopPDecl (i :: Int
i, ClassDecl p :: SpanInfo
p li :: LayoutInfo
li cx :: Context
cx cls :: Ident
cls tv :: Ident
tv ds :: [Decl a]
ds) = StateT TcState Identity (PDecl PredType)
-> StateT TcState Identity (PDecl PredType)
forall a. TCM a -> TCM a
withLocalSigEnv (StateT TcState Identity (PDecl PredType)
-> StateT TcState Identity (PDecl PredType))
-> StateT TcState Identity (PDecl PredType)
-> StateT TcState Identity (PDecl PredType)
forall a b. (a -> b) -> a -> b
$ do
let (vpds :: [PDecl a]
vpds, opds :: [PDecl a]
opds) = (PDecl a -> Bool) -> [PDecl a] -> ([PDecl a], [PDecl a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Decl a -> Bool
forall a. Decl a -> Bool
isValueDecl (Decl a -> Bool) -> (PDecl a -> Decl a) -> PDecl a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PDecl a -> Decl a
forall a b. (a, b) -> b
snd) ([PDecl a] -> ([PDecl a], [PDecl a]))
-> [PDecl a] -> ([PDecl a], [PDecl a])
forall a b. (a -> b) -> a -> b
$ [Decl a] -> [PDecl a]
forall a. [Decl a] -> [PDecl a]
toPDecls [Decl a]
ds
SigEnv -> TCM ()
setSigEnv (SigEnv -> TCM ()) -> SigEnv -> TCM ()
forall a b. (a -> b) -> a -> b
$ (PDecl a -> SigEnv -> SigEnv) -> SigEnv -> [PDecl a] -> SigEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Decl a -> SigEnv -> SigEnv
forall a. Decl a -> SigEnv -> SigEnv
bindTypeSigs (Decl a -> SigEnv -> SigEnv)
-> (PDecl a -> Decl a) -> PDecl a -> SigEnv -> SigEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PDecl a -> Decl a
forall a b. (a, b) -> b
snd) SigEnv
emptySigEnv [PDecl a]
opds
[PDecl PredType]
vpds' <- (PDecl a -> StateT TcState Identity (PDecl PredType))
-> [PDecl a] -> StateT TcState Identity [PDecl PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (QualIdent
-> Ident -> PDecl a -> StateT TcState Identity (PDecl PredType)
forall a.
QualIdent
-> Ident -> PDecl a -> StateT TcState Identity (PDecl PredType)
tcClassMethodPDecl (Ident -> QualIdent
qualify Ident
cls) Ident
tv) [PDecl a]
vpds
PDecl PredType -> StateT TcState Identity (PDecl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, SpanInfo
-> LayoutInfo
-> Context
-> Ident
-> Ident
-> [Decl PredType]
-> Decl PredType
forall a.
SpanInfo
-> LayoutInfo -> Context -> Ident -> Ident -> [Decl a] -> Decl a
ClassDecl SpanInfo
p LayoutInfo
li Context
cx Ident
cls Ident
tv ([Decl PredType] -> Decl PredType)
-> [Decl PredType] -> Decl PredType
forall a b. (a -> b) -> a -> b
$ [PDecl PredType] -> [Decl PredType]
forall a. [PDecl a] -> [Decl a]
fromPDecls ([PDecl PredType] -> [Decl PredType])
-> [PDecl PredType] -> [Decl PredType]
forall a b. (a -> b) -> a -> b
$ (PDecl a -> PDecl PredType) -> [PDecl a] -> [PDecl PredType]
forall a b. (a -> b) -> [a] -> [b]
map PDecl a -> PDecl PredType
forall a b. PDecl a -> PDecl b
untyped [PDecl a]
opds [PDecl PredType] -> [PDecl PredType] -> [PDecl PredType]
forall a. [a] -> [a] -> [a]
++ [PDecl PredType]
vpds')
tcTopPDecl (i :: Int
i, InstanceDecl p :: SpanInfo
p li :: LayoutInfo
li cx :: Context
cx qcls :: QualIdent
qcls ty :: TypeExpr
ty ds :: [Decl a]
ds) = do
TCEnv
tcEnv <- TCM TCEnv
getTyConsEnv
PredType
pty <- QualTypeExpr -> StateT TcState Identity PredType
expandPoly (QualTypeExpr -> StateT TcState Identity PredType)
-> QualTypeExpr -> StateT TcState Identity PredType
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Context -> TypeExpr -> QualTypeExpr
QualTypeExpr SpanInfo
NoSpanInfo Context
cx TypeExpr
ty
ModuleIdent
mid <- TCM ModuleIdent
getModuleIdent
let origCls :: QualIdent
origCls = ModuleIdent -> QualIdent -> TCEnv -> QualIdent
getOrigName ModuleIdent
mid QualIdent
qcls TCEnv
tcEnv
clsQual :: QualIdent
clsQual = [QualIdent] -> QualIdent
forall a. [a] -> a
head ([QualIdent] -> QualIdent) -> [QualIdent] -> QualIdent
forall a b. (a -> b) -> a -> b
$ (QualIdent -> Bool) -> [QualIdent] -> [QualIdent]
forall a. (a -> Bool) -> [a] -> [a]
filter QualIdent -> Bool
isQualified ([QualIdent] -> [QualIdent]) -> [QualIdent] -> [QualIdent]
forall a b. (a -> b) -> a -> b
$ QualIdent -> TCEnv -> [QualIdent]
reverseLookupByOrigName QualIdent
origCls TCEnv
tcEnv
qQualCls :: QualIdent
qQualCls = ModuleIdent -> QualIdent -> QualIdent
qualQualify (Maybe ModuleIdent -> ModuleIdent
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ModuleIdent -> ModuleIdent)
-> Maybe ModuleIdent -> ModuleIdent
forall a b. (a -> b) -> a -> b
$ QualIdent -> Maybe ModuleIdent
qidModule QualIdent
clsQual) QualIdent
qcls
[PDecl PredType]
vpds' <- (PDecl a -> StateT TcState Identity (PDecl PredType))
-> [PDecl a] -> StateT TcState Identity [PDecl PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (QualIdent
-> PredType -> PDecl a -> StateT TcState Identity (PDecl PredType)
forall a.
QualIdent
-> PredType -> PDecl a -> StateT TcState Identity (PDecl PredType)
tcInstanceMethodPDecl QualIdent
qQualCls PredType
pty) [PDecl a]
vpds
PDecl PredType -> StateT TcState Identity (PDecl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i,SpanInfo
-> LayoutInfo
-> Context
-> QualIdent
-> TypeExpr
-> [Decl PredType]
-> Decl PredType
forall a.
SpanInfo
-> LayoutInfo
-> Context
-> QualIdent
-> TypeExpr
-> [Decl a]
-> Decl a
InstanceDecl SpanInfo
p LayoutInfo
li Context
cx QualIdent
qcls TypeExpr
ty ([Decl PredType] -> Decl PredType)
-> [Decl PredType] -> Decl PredType
forall a b. (a -> b) -> a -> b
$ [PDecl PredType] -> [Decl PredType]
forall a. [PDecl a] -> [Decl a]
fromPDecls ([PDecl PredType] -> [Decl PredType])
-> [PDecl PredType] -> [Decl PredType]
forall a b. (a -> b) -> a -> b
$ (PDecl a -> PDecl PredType) -> [PDecl a] -> [PDecl PredType]
forall a b. (a -> b) -> [a] -> [b]
map PDecl a -> PDecl PredType
forall a b. PDecl a -> PDecl b
untyped [PDecl a]
opds[PDecl PredType] -> [PDecl PredType] -> [PDecl PredType]
forall a. [a] -> [a] -> [a]
++[PDecl PredType]
vpds')
where (vpds :: [PDecl a]
vpds, opds :: [PDecl a]
opds) = (PDecl a -> Bool) -> [PDecl a] -> ([PDecl a], [PDecl a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Decl a -> Bool
forall a. Decl a -> Bool
isValueDecl (Decl a -> Bool) -> (PDecl a -> Decl a) -> PDecl a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PDecl a -> Decl a
forall a b. (a, b) -> b
snd) ([PDecl a] -> ([PDecl a], [PDecl a]))
-> [PDecl a] -> ([PDecl a], [PDecl a])
forall a b. (a -> b) -> a -> b
$ [Decl a] -> [PDecl a]
forall a. [Decl a] -> [PDecl a]
toPDecls [Decl a]
ds
tcTopPDecl _ = String -> StateT TcState Identity (PDecl PredType)
forall a. String -> a
internalError "TypeCheck.tcTopDecl"
tcClassMethodPDecl :: QualIdent -> Ident -> PDecl a -> TCM (PDecl PredType)
tcClassMethodPDecl :: QualIdent
-> Ident -> PDecl a -> StateT TcState Identity (PDecl PredType)
tcClassMethodPDecl qcls :: QualIdent
qcls tv :: Ident
tv pd :: PDecl a
pd@(_, FunctionDecl _ _ f :: Ident
f _) = do
TypeScheme
methTy <- (Ident -> QualIdent) -> Ident -> StateT TcState Identity TypeScheme
classMethodType Ident -> QualIdent
qualify Ident
f
(tySc :: TypeScheme
tySc, pd' :: PDecl PredType
pd') <- QualIdent
-> TypeScheme -> PDecl a -> TCM (TypeScheme, PDecl PredType)
forall a.
QualIdent
-> TypeScheme -> PDecl a -> TCM (TypeScheme, PDecl PredType)
tcMethodPDecl QualIdent
qcls TypeScheme
methTy PDecl a
pd
SigEnv
sigs <- TCM SigEnv
getSigEnv
let QualTypeExpr spi :: SpanInfo
spi cx :: Context
cx ty :: TypeExpr
ty = Maybe QualTypeExpr -> QualTypeExpr
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe QualTypeExpr -> QualTypeExpr)
-> Maybe QualTypeExpr -> QualTypeExpr
forall a b. (a -> b) -> a -> b
$ Ident -> SigEnv -> Maybe QualTypeExpr
lookupTypeSig Ident
f SigEnv
sigs
qty :: QualTypeExpr
qty = SpanInfo -> Context -> TypeExpr -> QualTypeExpr
QualTypeExpr SpanInfo
spi
(SpanInfo -> QualIdent -> TypeExpr -> Constraint
Constraint SpanInfo
NoSpanInfo QualIdent
qcls (SpanInfo -> Ident -> TypeExpr
VariableType SpanInfo
NoSpanInfo Ident
tv) Constraint -> Context -> Context
forall a. a -> [a] -> [a]
: Context
cx) TypeExpr
ty
QualTypeExpr
-> TypeScheme
-> PDecl PredType
-> StateT TcState Identity (PDecl PredType)
checkClassMethodType QualTypeExpr
qty TypeScheme
tySc PDecl PredType
pd'
tcClassMethodPDecl _ _ _ = String -> StateT TcState Identity (PDecl PredType)
forall a. String -> a
internalError "TypeCheck.tcClassMethodPDecl"
tcInstanceMethodPDecl :: QualIdent -> PredType -> PDecl a
-> TCM (PDecl PredType)
tcInstanceMethodPDecl :: QualIdent
-> PredType -> PDecl a -> StateT TcState Identity (PDecl PredType)
tcInstanceMethodPDecl qcls :: QualIdent
qcls pty :: PredType
pty pd :: PDecl a
pd@(_, FunctionDecl _ _ f :: Ident
f _) = do
PredType
methTy <- (Ident -> QualIdent)
-> PredType -> Ident -> StateT TcState Identity PredType
instMethodType (QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
qcls) PredType
pty Ident
f
(tySc :: TypeScheme
tySc, pd' :: PDecl PredType
pd') <- QualIdent
-> TypeScheme -> PDecl a -> TCM (TypeScheme, PDecl PredType)
forall a.
QualIdent
-> TypeScheme -> PDecl a -> TCM (TypeScheme, PDecl PredType)
tcMethodPDecl QualIdent
qcls (PredType -> TypeScheme
typeScheme PredType
methTy) PDecl a
pd
PredType
-> TypeScheme
-> PDecl PredType
-> StateT TcState Identity (PDecl PredType)
checkInstMethodType (Int -> PredType -> PredType
normalize 0 PredType
methTy) TypeScheme
tySc PDecl PredType
pd'
tcInstanceMethodPDecl _ _ _ = String -> StateT TcState Identity (PDecl PredType)
forall a. String -> a
internalError "TypeCheck.tcInstanceMethodPDecl"
tcMethodPDecl :: QualIdent -> TypeScheme -> PDecl a -> TCM (TypeScheme, PDecl PredType)
tcMethodPDecl :: QualIdent
-> TypeScheme -> PDecl a -> TCM (TypeScheme, PDecl PredType)
tcMethodPDecl qcls :: QualIdent
qcls tySc :: TypeScheme
tySc (i :: Int
i, FunctionDecl p :: SpanInfo
p _ f :: Ident
f eqs :: [Equation a]
eqs) = TCM (TypeScheme, PDecl PredType)
-> TCM (TypeScheme, PDecl PredType)
forall a. TCM a -> TCM a
withLocalValueEnv (TCM (TypeScheme, PDecl PredType)
-> TCM (TypeScheme, PDecl PredType))
-> TCM (TypeScheme, PDecl PredType)
-> TCM (TypeScheme, PDecl PredType)
forall a b. (a -> b) -> a -> b
$ do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
(ValueEnv -> ValueEnv) -> TCM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> TCM ())
-> (ValueEnv -> ValueEnv) -> TCM ()
forall a b. (a -> b) -> a -> b
$ ModuleIdent
-> Ident
-> Maybe QualIdent
-> Int
-> TypeScheme
-> ValueEnv
-> ValueEnv
bindFun ModuleIdent
m Ident
f (QualIdent -> Maybe QualIdent
forall a. a -> Maybe a
Just QualIdent
qcls) (Equation a -> Int
forall a. Equation a -> Int
eqnArity (Equation a -> Int) -> Equation a -> Int
forall a b. (a -> b) -> a -> b
$ [Equation a] -> Equation a
forall a. [a] -> a
head [Equation a]
eqs) TypeScheme
tySc
(ps :: PredSet
ps, (ty :: Type
ty, pd :: PDecl PredType
pd)) <- Int
-> PredSet
-> TypeScheme
-> SpanInfo
-> Ident
-> [Equation a]
-> StateT TcState Identity (PredSet, (Type, PDecl PredType))
forall a.
Int
-> PredSet
-> TypeScheme
-> SpanInfo
-> Ident
-> [Equation a]
-> StateT TcState Identity (PredSet, (Type, PDecl PredType))
tcFunctionPDecl Int
i PredSet
emptyPredSet TypeScheme
tySc SpanInfo
p Ident
f [Equation a]
eqs
TypeSubst
theta <- TCM TypeSubst
getTypeSubst
(TypeScheme, PDecl PredType) -> TCM (TypeScheme, PDecl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Int -> PredSet -> Type -> TypeScheme
gen Set Int
forall a. Set a
Set.empty PredSet
ps (Type -> TypeScheme) -> Type -> TypeScheme
forall a b. (a -> b) -> a -> b
$ TypeSubst -> Type -> Type
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta Type
ty, PDecl PredType
pd)
tcMethodPDecl _ _ _ = String -> TCM (TypeScheme, PDecl PredType)
forall a. String -> a
internalError "TypeCheck.tcMethodPDecl"
checkClassMethodType :: QualTypeExpr -> TypeScheme -> PDecl PredType
-> TCM (PDecl PredType)
checkClassMethodType :: QualTypeExpr
-> TypeScheme
-> PDecl PredType
-> StateT TcState Identity (PDecl PredType)
checkClassMethodType qty :: QualTypeExpr
qty tySc :: TypeScheme
tySc pd :: PDecl PredType
pd@(_, FunctionDecl _ _ f :: Ident
f _) = do
PredType
pty <- QualTypeExpr -> StateT TcState Identity PredType
expandPoly QualTypeExpr
qty
StateT TcState Identity Bool -> TCM () -> TCM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PredType -> TypeScheme -> StateT TcState Identity Bool
checkTypeSig PredType
pty TypeScheme
tySc) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
Message -> TCM ()
report (Message -> TCM ()) -> Message -> TCM ()
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> Doc -> QualTypeExpr -> TypeScheme -> Message
errTypeSigTooGeneral ModuleIdent
m (String -> Doc
text "Method:" Doc -> Doc -> Doc
<+> Ident -> Doc
ppIdent Ident
f) QualTypeExpr
qty TypeScheme
tySc
PDecl PredType -> StateT TcState Identity (PDecl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return PDecl PredType
pd
checkClassMethodType _ _ _ = String -> StateT TcState Identity (PDecl PredType)
forall a. String -> a
internalError "TypeCheck.checkClassMethodType"
checkInstMethodType :: PredType -> TypeScheme -> PDecl PredType
-> TCM (PDecl PredType)
checkInstMethodType :: PredType
-> TypeScheme
-> PDecl PredType
-> StateT TcState Identity (PDecl PredType)
checkInstMethodType pty :: PredType
pty tySc :: TypeScheme
tySc pd :: PDecl PredType
pd@(_, FunctionDecl _ _ f :: Ident
f _) = do
StateT TcState Identity Bool -> TCM () -> TCM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PredType -> TypeScheme -> StateT TcState Identity Bool
checkTypeSig PredType
pty TypeScheme
tySc) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
Message -> TCM ()
report (Message -> TCM ()) -> Message -> TCM ()
forall a b. (a -> b) -> a -> b
$
Ident -> ModuleIdent -> Doc -> PredType -> TypeScheme -> Message
forall a.
HasSpanInfo a =>
a -> ModuleIdent -> Doc -> PredType -> TypeScheme -> Message
errMethodTypeTooSpecific Ident
f ModuleIdent
m (String -> Doc
text "Method:" Doc -> Doc -> Doc
<+> Ident -> Doc
ppIdent Ident
f) PredType
pty TypeScheme
tySc
PDecl PredType -> StateT TcState Identity (PDecl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return PDecl PredType
pd
checkInstMethodType _ _ _ = String -> StateT TcState Identity (PDecl PredType)
forall a. String -> a
internalError "TypeCheck.checkInstMethodType"
classMethodType :: (Ident -> QualIdent) -> Ident -> TCM TypeScheme
classMethodType :: (Ident -> QualIdent) -> Ident -> StateT TcState Identity TypeScheme
classMethodType qual :: Ident -> QualIdent
qual f :: Ident
f = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
TypeScheme -> StateT TcState Identity TypeScheme
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeScheme -> StateT TcState Identity TypeScheme)
-> TypeScheme -> StateT TcState Identity TypeScheme
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
funType ModuleIdent
m (Ident -> QualIdent
qual (Ident -> QualIdent) -> Ident -> QualIdent
forall a b. (a -> b) -> a -> b
$ Ident -> Ident
unRenameIdent Ident
f) ValueEnv
vEnv
instMethodType :: (Ident -> QualIdent) -> PredType -> Ident -> TCM PredType
instMethodType :: (Ident -> QualIdent)
-> PredType -> Ident -> StateT TcState Identity PredType
instMethodType qual :: Ident -> QualIdent
qual (PredType ps :: PredSet
ps ty :: Type
ty) f :: Ident
f = do
ForAll _ (PredType ps' :: PredSet
ps' ty' :: Type
ty') <- (Ident -> QualIdent) -> Ident -> StateT TcState Identity TypeScheme
classMethodType Ident -> QualIdent
qual Ident
f
let PredType ps'' :: PredSet
ps'' ty'' :: Type
ty'' = Type -> PredType -> PredType
forall a. ExpandAliasType a => Type -> a -> a
instanceType Type
ty (PredSet -> Type -> PredType
PredType (PredSet -> PredSet
forall a. Set a -> Set a
Set.deleteMin PredSet
ps') Type
ty')
PredType -> StateT TcState Identity PredType
forall (m :: * -> *) a. Monad m => a -> m a
return (PredType -> StateT TcState Identity PredType)
-> PredType -> StateT TcState Identity PredType
forall a b. (a -> b) -> a -> b
$ PredSet -> Type -> PredType
PredType (PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps'') Type
ty''
tcExternal :: Ident -> TCM Type
tcExternal :: Ident -> StateT TcState Identity Type
tcExternal f :: Ident
f = do
SigEnv
sigs <- TCM SigEnv
getSigEnv
case Ident -> SigEnv -> Maybe QualTypeExpr
lookupTypeSig Ident
f SigEnv
sigs of
Nothing -> String -> StateT TcState Identity Type
forall a. String -> a
internalError "TypeCheck.tcExternal: type signature not found"
Just (QualTypeExpr _ _ ty :: TypeExpr
ty) -> do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
PredType _ ty' :: Type
ty' <- QualTypeExpr -> StateT TcState Identity PredType
expandPoly (QualTypeExpr -> StateT TcState Identity PredType)
-> QualTypeExpr -> StateT TcState Identity PredType
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Context -> TypeExpr -> QualTypeExpr
QualTypeExpr SpanInfo
NoSpanInfo [] TypeExpr
ty
(ValueEnv -> ValueEnv) -> TCM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> TCM ())
-> (ValueEnv -> ValueEnv) -> TCM ()
forall a b. (a -> b) -> a -> b
$ ModuleIdent
-> Ident
-> Maybe QualIdent
-> Int
-> TypeScheme
-> ValueEnv
-> ValueEnv
bindFun ModuleIdent
m Ident
f Maybe QualIdent
forall a. Maybe a
Nothing (Type -> Int
arrowArity Type
ty') (Type -> TypeScheme
polyType Type
ty')
Type -> StateT TcState Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty'
tcLiteral :: Bool -> Literal -> TCM (PredSet, Type)
tcLiteral :: Bool -> Literal -> StateT TcState Identity (PredSet, Type)
tcLiteral _ (Char _) = (PredSet, Type) -> StateT TcState Identity (PredSet, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
emptyPredSet, Type
charType)
tcLiteral poly :: Bool
poly (Int _)
| Bool
poly = StateT TcState Identity (PredSet, Type)
freshNumType
| Bool
otherwise = (Type -> (PredSet, Type))
-> StateT TcState Identity Type
-> StateT TcState Identity (PredSet, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) PredSet
emptyPredSet) ([Type] -> StateT TcState Identity Type
freshConstrained [Type]
numTypes)
tcLiteral poly :: Bool
poly (Float _)
| Bool
poly = StateT TcState Identity (PredSet, Type)
freshFractionalType
| Bool
otherwise = (Type -> (PredSet, Type))
-> StateT TcState Identity Type
-> StateT TcState Identity (PredSet, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) PredSet
emptyPredSet) ([Type] -> StateT TcState Identity Type
freshConstrained [Type]
fractionalTypes)
tcLiteral _ (String _) = (PredSet, Type) -> StateT TcState Identity (PredSet, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
emptyPredSet, Type
stringType)
tcLhs :: HasSpanInfo p => p -> Lhs a -> PTCM (PredSet, [Type], Lhs PredType)
tcLhs :: p
-> Lhs a -> StateT (Set Ident) TCM (PredSet, [Type], Lhs PredType)
tcLhs p :: p
p (FunLhs spi :: SpanInfo
spi f :: Ident
f ts :: [Pattern a]
ts) = do
(pss :: [PredSet]
pss, tys :: [Type]
tys, ts' :: [Pattern PredType]
ts') <- [(PredSet, Type, Pattern PredType)]
-> ([PredSet], [Type], [Pattern PredType])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(PredSet, Type, Pattern PredType)]
-> ([PredSet], [Type], [Pattern PredType]))
-> StateT (Set Ident) TCM [(PredSet, Type, Pattern PredType)]
-> StateT (Set Ident) TCM ([PredSet], [Type], [Pattern PredType])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType))
-> [Pattern a]
-> StateT (Set Ident) TCM [(PredSet, Type, Pattern PredType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
tcPatternHelper p
p) [Pattern a]
ts
(PredSet, [Type], Lhs PredType)
-> StateT (Set Ident) TCM (PredSet, [Type], Lhs PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([PredSet] -> PredSet
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [PredSet]
pss, [Type]
tys, SpanInfo -> Ident -> [Pattern PredType] -> Lhs PredType
forall a. SpanInfo -> Ident -> [Pattern a] -> Lhs a
FunLhs SpanInfo
spi Ident
f [Pattern PredType]
ts')
tcLhs p :: p
p (OpLhs spi :: SpanInfo
spi t1 :: Pattern a
t1 op :: Ident
op t2 :: Pattern a
t2) = do
(ps1 :: PredSet
ps1, ty1 :: Type
ty1, t1' :: Pattern PredType
t1') <- p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
tcPatternHelper p
p Pattern a
t1
(ps2 :: PredSet
ps2, ty2 :: Type
ty2, t2' :: Pattern PredType
t2') <- p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
tcPatternHelper p
p Pattern a
t2
(PredSet, [Type], Lhs PredType)
-> StateT (Set Ident) TCM (PredSet, [Type], Lhs PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps1 PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps2, [Type
ty1, Type
ty2], SpanInfo
-> Pattern PredType -> Ident -> Pattern PredType -> Lhs PredType
forall a. SpanInfo -> Pattern a -> Ident -> Pattern a -> Lhs a
OpLhs SpanInfo
spi Pattern PredType
t1' Ident
op Pattern PredType
t2')
tcLhs p :: p
p (ApLhs spi :: SpanInfo
spi lhs :: Lhs a
lhs ts :: [Pattern a]
ts) = do
(ps :: PredSet
ps, tys1 :: [Type]
tys1, lhs' :: Lhs PredType
lhs') <- p
-> Lhs a -> StateT (Set Ident) TCM (PredSet, [Type], Lhs PredType)
forall p a.
HasSpanInfo p =>
p
-> Lhs a -> StateT (Set Ident) TCM (PredSet, [Type], Lhs PredType)
tcLhs p
p Lhs a
lhs
(pss :: [PredSet]
pss, tys2 :: [Type]
tys2, ts' :: [Pattern PredType]
ts') <- [(PredSet, Type, Pattern PredType)]
-> ([PredSet], [Type], [Pattern PredType])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(PredSet, Type, Pattern PredType)]
-> ([PredSet], [Type], [Pattern PredType]))
-> StateT (Set Ident) TCM [(PredSet, Type, Pattern PredType)]
-> StateT (Set Ident) TCM ([PredSet], [Type], [Pattern PredType])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType))
-> [Pattern a]
-> StateT (Set Ident) TCM [(PredSet, Type, Pattern PredType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
tcPatternHelper p
p) [Pattern a]
ts
(PredSet, [Type], Lhs PredType)
-> StateT (Set Ident) TCM (PredSet, [Type], Lhs PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([PredSet] -> PredSet
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (PredSet
psPredSet -> [PredSet] -> [PredSet]
forall a. a -> [a] -> [a]
:[PredSet]
pss), [Type]
tys1 [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
tys2, SpanInfo -> Lhs PredType -> [Pattern PredType] -> Lhs PredType
forall a. SpanInfo -> Lhs a -> [Pattern a] -> Lhs a
ApLhs SpanInfo
spi Lhs PredType
lhs' [Pattern PredType]
ts')
tcPattern :: HasSpanInfo p => p -> Pattern a
-> TCM (PredSet, Type, Pattern PredType)
tcPattern :: p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern = Set Ident
-> p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
Set Ident
-> p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPatternWith Set Ident
forall a. Set a
Set.empty
tcPatternWith :: HasSpanInfo p => Set.Set Ident -> p -> Pattern a
-> TCM (PredSet, Type, Pattern PredType)
tcPatternWith :: Set Ident
-> p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPatternWith s :: Set Ident
s p :: p
p pt :: Pattern a
pt = StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
-> Set Ident -> TCM (PredSet, Type, Pattern PredType)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
S.evalStateT (p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
tcPatternHelper p
p Pattern a
pt) Set Ident
s
type PTCM a = S.StateT (Set.Set Ident) TCM a
tcPatternHelper :: HasSpanInfo p => p -> Pattern a
-> PTCM (PredSet, Type, Pattern PredType)
tcPatternHelper :: p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
tcPatternHelper _ (LiteralPattern spi :: SpanInfo
spi _ l :: Literal
l) = do
(ps :: PredSet
ps, ty :: Type
ty) <- StateT TcState Identity (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT TcState Identity (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type))
-> StateT TcState Identity (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type)
forall a b. (a -> b) -> a -> b
$ Bool -> Literal -> StateT TcState Identity (PredSet, Type)
tcLiteral Bool
False Literal
l
(PredSet, Type, Pattern PredType)
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, Type
ty, SpanInfo -> PredType -> Literal -> Pattern PredType
forall a. SpanInfo -> a -> Literal -> Pattern a
LiteralPattern SpanInfo
spi (Type -> PredType
predType Type
ty) Literal
l)
tcPatternHelper _ (NegativePattern spi :: SpanInfo
spi _ l :: Literal
l) = do
(ps :: PredSet
ps, ty :: Type
ty) <- StateT TcState Identity (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT TcState Identity (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type))
-> StateT TcState Identity (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type)
forall a b. (a -> b) -> a -> b
$ Bool -> Literal -> StateT TcState Identity (PredSet, Type)
tcLiteral Bool
False Literal
l
(PredSet, Type, Pattern PredType)
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, Type
ty, SpanInfo -> PredType -> Literal -> Pattern PredType
forall a. SpanInfo -> a -> Literal -> Pattern a
NegativePattern SpanInfo
spi (Type -> PredType
predType Type
ty) Literal
l)
tcPatternHelper _ (VariablePattern spi :: SpanInfo
spi _ v :: Ident
v) = do
ValueEnv
vEnv <- TCM ValueEnv -> StateT (Set Ident) TCM ValueEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TCM ValueEnv
getValueEnv
(_, ty :: Type
ty) <- StateT TcState Identity (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT TcState Identity (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type))
-> StateT TcState Identity (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type)
forall a b. (a -> b) -> a -> b
$ TypeScheme -> StateT TcState Identity (PredSet, Type)
inst (Ident -> ValueEnv -> TypeScheme
varType Ident
v ValueEnv
vEnv)
Set Ident
used <- StateT (Set Ident) TCM (Set Ident)
forall s (m :: * -> *). MonadState s m => m s
S.get
PredSet
ps <- if Ident -> Set Ident -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Ident
v Set Ident
used
then PredSet -> StateT (Set Ident) TCM PredSet
forall (m :: * -> *) a. Monad m => a -> m a
return (Pred -> PredSet
forall a. a -> Set a
Set.singleton (QualIdent -> Type -> Pred
Pred QualIdent
qDataId Type
ty))
else Set Ident -> StateT (Set Ident) TCM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.insert Ident
v Set Ident
used) StateT (Set Ident) TCM ()
-> StateT (Set Ident) TCM PredSet -> StateT (Set Ident) TCM PredSet
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PredSet -> StateT (Set Ident) TCM PredSet
forall (m :: * -> *) a. Monad m => a -> m a
return PredSet
forall a. Set a
Set.empty
(PredSet, Type, Pattern PredType)
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, Type
ty, SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
spi (Type -> PredType
predType Type
ty) Ident
v)
tcPatternHelper p :: p
p t :: Pattern a
t@(ConstructorPattern spi :: SpanInfo
spi _ c :: QualIdent
c ts :: [Pattern a]
ts) = do
ModuleIdent
m <- TCM ModuleIdent -> StateT (Set Ident) TCM ModuleIdent
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TCM ModuleIdent
getModuleIdent
ValueEnv
vEnv <- TCM ValueEnv -> StateT (Set Ident) TCM ValueEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TCM ValueEnv
getValueEnv
(ps :: PredSet
ps, (tys :: [Type]
tys, ty' :: Type
ty')) <- (Type -> ([Type], Type))
-> (PredSet, Type) -> (PredSet, ([Type], Type))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> ([Type], Type)
arrowUnapply ((PredSet, Type) -> (PredSet, ([Type], Type)))
-> StateT (Set Ident) TCM (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, ([Type], Type))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT TcState Identity (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TypeScheme -> StateT TcState Identity (PredSet, Type)
skol (ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
constrType ModuleIdent
m QualIdent
c ValueEnv
vEnv))
(ps' :: PredSet
ps', ts' :: [Pattern PredType]
ts') <- (PredSet
-> (Type, Pattern a)
-> StateT (Set Ident) TCM (PredSet, Pattern PredType))
-> PredSet
-> [(Type, Pattern a)]
-> StateT (Set Ident) TCM (PredSet, [Pattern PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM ((Type
-> Pattern a -> StateT (Set Ident) TCM (PredSet, Pattern PredType))
-> (Type, Pattern a)
-> StateT (Set Ident) TCM (PredSet, Pattern PredType)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Type
-> Pattern a -> StateT (Set Ident) TCM (PredSet, Pattern PredType))
-> (Type, Pattern a)
-> StateT (Set Ident) TCM (PredSet, Pattern PredType))
-> (PredSet
-> Type
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Pattern PredType))
-> PredSet
-> (Type, Pattern a)
-> StateT (Set Ident) TCM (PredSet, Pattern PredType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Pattern PredType)
ptcPatternArg p
p "pattern" (Int -> Pattern a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Pattern a
t))
PredSet
ps ([Type] -> [Pattern a] -> [(Type, Pattern a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
tys [Pattern a]
ts)
(PredSet, Type, Pattern PredType)
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps', Type
ty', SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
spi (Type -> PredType
predType Type
ty') QualIdent
c [Pattern PredType]
ts')
tcPatternHelper p :: p
p (InfixPattern spi :: SpanInfo
spi a :: a
a t1 :: Pattern a
t1 op :: QualIdent
op t2 :: Pattern a
t2) = do
(ps :: PredSet
ps, ty :: Type
ty, t' :: Pattern PredType
t') <- p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
tcPatternHelper p
p (SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo a
a QualIdent
op [Pattern a
t1,Pattern a
t2])
let ConstructorPattern _ a' :: PredType
a' op' :: QualIdent
op' [t1' :: Pattern PredType
t1', t2' :: Pattern PredType
t2'] = Pattern PredType
t'
(PredSet, Type, Pattern PredType)
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, Type
ty, SpanInfo
-> PredType
-> Pattern PredType
-> QualIdent
-> Pattern PredType
-> Pattern PredType
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern SpanInfo
spi PredType
a' Pattern PredType
t1' QualIdent
op' Pattern PredType
t2')
tcPatternHelper p :: p
p (ParenPattern spi :: SpanInfo
spi t :: Pattern a
t) = do
(ps :: PredSet
ps, ty :: Type
ty, t' :: Pattern PredType
t') <- p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
tcPatternHelper p
p Pattern a
t
(PredSet, Type, Pattern PredType)
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, Type
ty, SpanInfo -> Pattern PredType -> Pattern PredType
forall a. SpanInfo -> Pattern a -> Pattern a
ParenPattern SpanInfo
spi Pattern PredType
t')
tcPatternHelper _ t :: Pattern a
t@(RecordPattern spi :: SpanInfo
spi _ c :: QualIdent
c fs :: [Field (Pattern a)]
fs) = do
ModuleIdent
m <- TCM ModuleIdent -> StateT (Set Ident) TCM ModuleIdent
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TCM ModuleIdent
getModuleIdent
ValueEnv
vEnv <- TCM ValueEnv -> StateT (Set Ident) TCM ValueEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TCM ValueEnv
getValueEnv
(ps :: PredSet
ps, ty :: Type
ty) <- (Type -> Type) -> (PredSet, Type) -> (PredSet, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
arrowBase ((PredSet, Type) -> (PredSet, Type))
-> StateT (Set Ident) TCM (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT TcState Identity (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TypeScheme -> StateT TcState Identity (PredSet, Type)
skol (ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
constrType ModuleIdent
m QualIdent
c ValueEnv
vEnv))
Set Ident
used <- StateT (Set Ident) TCM (Set Ident)
forall s (m :: * -> *). MonadState s m => m s
S.get
(ps' :: PredSet
ps', fs' :: [Field (Pattern PredType)]
fs') <- StateT TcState Identity (PredSet, [Field (Pattern PredType)])
-> StateT (Set Ident) TCM (PredSet, [Field (Pattern PredType)])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT TcState Identity (PredSet, [Field (Pattern PredType)])
-> StateT (Set Ident) TCM (PredSet, [Field (Pattern PredType)]))
-> StateT TcState Identity (PredSet, [Field (Pattern PredType)])
-> StateT (Set Ident) TCM (PredSet, [Field (Pattern PredType)])
forall a b. (a -> b) -> a -> b
$ (PredSet
-> Field (Pattern a)
-> StateT TcState Identity (PredSet, Field (Pattern PredType)))
-> PredSet
-> [Field (Pattern a)]
-> StateT TcState Identity (PredSet, [Field (Pattern PredType)])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM ((SpanInfo -> Pattern a -> TCM (PredSet, Type, Pattern PredType))
-> String
-> (Pattern a -> Doc)
-> Type
-> PredSet
-> Field (Pattern a)
-> StateT TcState Identity (PredSet, Field (Pattern PredType))
forall (a :: * -> *) b.
(SpanInfo -> a b -> TCM (PredSet, Type, a PredType))
-> String
-> (a b -> Doc)
-> Type
-> PredSet
-> Field (a b)
-> TCM (PredSet, Field (a PredType))
tcField (Set Ident
-> SpanInfo -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
Set Ident
-> p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPatternWith Set Ident
used) "pattern"
(\t' :: Pattern a
t' -> Int -> Pattern a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Pattern a
t Doc -> Doc -> Doc
$-$ String -> Doc
text "Term:" Doc -> Doc -> Doc
<+> Int -> Pattern a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Pattern a
t') Type
ty) PredSet
ps [Field (Pattern a)]
fs
Set Ident -> StateT (Set Ident) TCM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Set Ident -> StateT (Set Ident) TCM ())
-> Set Ident -> StateT (Set Ident) TCM ()
forall a b. (a -> b) -> a -> b
$ (Ident -> Set Ident -> Set Ident)
-> Set Ident -> [Ident] -> Set Ident
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.insert Set Ident
used ([Ident] -> Set Ident) -> [Ident] -> Set Ident
forall a b. (a -> b) -> a -> b
$ (Field (Pattern a) -> [Ident]) -> [Field (Pattern a)] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Field (Pattern a) -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv [Field (Pattern a)]
fs
(PredSet, Type, Pattern PredType)
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps', Type
ty, SpanInfo
-> PredType
-> QualIdent
-> [Field (Pattern PredType)]
-> Pattern PredType
forall a.
SpanInfo -> a -> QualIdent -> [Field (Pattern a)] -> Pattern a
RecordPattern SpanInfo
spi (Type -> PredType
predType Type
ty) QualIdent
c [Field (Pattern PredType)]
fs')
tcPatternHelper p :: p
p (TuplePattern spi :: SpanInfo
spi ts :: [Pattern a]
ts) = do
(pss :: [PredSet]
pss, tys :: [Type]
tys, ts' :: [Pattern PredType]
ts') <- [(PredSet, Type, Pattern PredType)]
-> ([PredSet], [Type], [Pattern PredType])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(PredSet, Type, Pattern PredType)]
-> ([PredSet], [Type], [Pattern PredType]))
-> StateT (Set Ident) TCM [(PredSet, Type, Pattern PredType)]
-> StateT (Set Ident) TCM ([PredSet], [Type], [Pattern PredType])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType))
-> [Pattern a]
-> StateT (Set Ident) TCM [(PredSet, Type, Pattern PredType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
tcPatternHelper p
p) [Pattern a]
ts
(PredSet, Type, Pattern PredType)
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([PredSet] -> PredSet
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [PredSet]
pss, [Type] -> Type
tupleType [Type]
tys, SpanInfo -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> [Pattern a] -> Pattern a
TuplePattern SpanInfo
spi [Pattern PredType]
ts')
tcPatternHelper p :: p
p t :: Pattern a
t@(ListPattern spi :: SpanInfo
spi _ ts :: [Pattern a]
ts) = do
Type
ty <- StateT TcState Identity Type -> StateT (Set Ident) TCM Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT TcState Identity Type
freshTypeVar
(ps :: PredSet
ps, ts' :: [Pattern PredType]
ts') <- (PredSet
-> Pattern a -> StateT (Set Ident) TCM (PredSet, Pattern PredType))
-> PredSet
-> [Pattern a]
-> StateT (Set Ident) TCM (PredSet, [Pattern PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM ((PredSet
-> Type
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Pattern PredType))
-> Type
-> PredSet
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Pattern PredType)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Pattern PredType)
ptcPatternArg p
p "pattern" (Int -> Pattern a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Pattern a
t)) Type
ty)
PredSet
emptyPredSet [Pattern a]
ts
(PredSet, Type, Pattern PredType)
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, Type -> Type
listType Type
ty, SpanInfo -> PredType -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> [Pattern a] -> Pattern a
ListPattern SpanInfo
spi (Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
listType Type
ty) [Pattern PredType]
ts')
tcPatternHelper p :: p
p t :: Pattern a
t@(AsPattern spi :: SpanInfo
spi v :: Ident
v t' :: Pattern a
t') = do
ValueEnv
vEnv <- TCM ValueEnv -> StateT (Set Ident) TCM ValueEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TCM ValueEnv
getValueEnv
(_, ty :: Type
ty) <- StateT TcState Identity (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT TcState Identity (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type))
-> StateT TcState Identity (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type)
forall a b. (a -> b) -> a -> b
$ TypeScheme -> StateT TcState Identity (PredSet, Type)
inst (Ident -> ValueEnv -> TypeScheme
varType Ident
v ValueEnv
vEnv)
Set Ident
used <- StateT (Set Ident) TCM (Set Ident)
forall s (m :: * -> *). MonadState s m => m s
S.get
PredSet
ps <- if Ident -> Set Ident -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Ident
v Set Ident
used
then PredSet -> StateT (Set Ident) TCM PredSet
forall (m :: * -> *) a. Monad m => a -> m a
return (Pred -> PredSet
forall a. a -> Set a
Set.singleton (QualIdent -> Type -> Pred
Pred QualIdent
qDataId Type
ty))
else Set Ident -> StateT (Set Ident) TCM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.insert Ident
v Set Ident
used) StateT (Set Ident) TCM ()
-> StateT (Set Ident) TCM PredSet -> StateT (Set Ident) TCM PredSet
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PredSet -> StateT (Set Ident) TCM PredSet
forall (m :: * -> *) a. Monad m => a -> m a
return PredSet
forall a. Set a
Set.empty
(ps'' :: PredSet
ps'', t'' :: Pattern PredType
t'') <- p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
tcPatternHelper p
p Pattern a
t' StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
-> (PredSet -> Type -> StateT (Set Ident) TCM PredSet)
-> StateT (Set Ident) TCM (PredSet, Pattern PredType)
forall (m :: * -> *) a b c.
Monad m =>
m (a, b, c) -> (a -> b -> m a) -> m (a, c)
>>-
(\ps' :: PredSet
ps' ty' :: Type
ty' -> TCM PredSet -> StateT (Set Ident) TCM PredSet
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM PredSet -> StateT (Set Ident) TCM PredSet)
-> TCM PredSet -> StateT (Set Ident) TCM PredSet
forall a b. (a -> b) -> a -> b
$ p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unify p
p "pattern" (Int -> Pattern a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Pattern a
t) PredSet
ps Type
ty PredSet
ps' Type
ty')
(PredSet, Type, Pattern PredType)
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps'', Type
ty, SpanInfo -> Ident -> Pattern PredType -> Pattern PredType
forall a. SpanInfo -> Ident -> Pattern a -> Pattern a
AsPattern SpanInfo
spi Ident
v Pattern PredType
t'')
tcPatternHelper p :: p
p (LazyPattern spi :: SpanInfo
spi t :: Pattern a
t) = do
(ps :: PredSet
ps, ty :: Type
ty, t' :: Pattern PredType
t') <- p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
tcPatternHelper p
p Pattern a
t
(PredSet, Type, Pattern PredType)
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, Type
ty, SpanInfo -> Pattern PredType -> Pattern PredType
forall a. SpanInfo -> Pattern a -> Pattern a
LazyPattern SpanInfo
spi Pattern PredType
t')
tcPatternHelper p :: p
p t :: Pattern a
t@(FunctionPattern spi :: SpanInfo
spi _ f :: QualIdent
f ts :: [Pattern a]
ts) = do
ModuleIdent
m <- TCM ModuleIdent -> StateT (Set Ident) TCM ModuleIdent
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TCM ModuleIdent
getModuleIdent
ValueEnv
vEnv <- TCM ValueEnv -> StateT (Set Ident) TCM ValueEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TCM ValueEnv
getValueEnv
(ps :: PredSet
ps, ty :: Type
ty) <- StateT TcState Identity (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT TcState Identity (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type))
-> StateT TcState Identity (PredSet, Type)
-> StateT (Set Ident) TCM (PredSet, Type)
forall a b. (a -> b) -> a -> b
$ TypeScheme -> StateT TcState Identity (PredSet, Type)
inst (ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
funType ModuleIdent
m QualIdent
f ValueEnv
vEnv)
(Set Ident -> Set Ident) -> StateT (Set Ident) TCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((Set Ident -> [Ident] -> Set Ident)
-> [Ident] -> Set Ident -> Set Ident
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Ident -> Set Ident -> Set Ident)
-> Set Ident -> [Ident] -> Set Ident
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.insert) (Pattern a -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv Pattern a
t))
p
-> SpanInfo
-> Doc
-> QualIdent
-> ([Pattern PredType] -> [Pattern PredType])
-> PredSet
-> Type
-> [Pattern a]
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> SpanInfo
-> Doc
-> QualIdent
-> ([Pattern PredType] -> [Pattern PredType])
-> PredSet
-> Type
-> [Pattern a]
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
tcFuncPattern p
p SpanInfo
spi (Int -> Pattern a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Pattern a
t) QualIdent
f [Pattern PredType] -> [Pattern PredType]
forall a. a -> a
id PredSet
ps Type
ty [Pattern a]
ts
tcPatternHelper p :: p
p (InfixFuncPattern spi :: SpanInfo
spi a :: a
a t1 :: Pattern a
t1 op :: QualIdent
op t2 :: Pattern a
t2) = do
(ps :: PredSet
ps, ty :: Type
ty, t' :: Pattern PredType
t') <- p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
tcPatternHelper p
p (SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
FunctionPattern SpanInfo
spi a
a QualIdent
op [Pattern a
t1, Pattern a
t2])
let FunctionPattern _ a' :: PredType
a' op' :: QualIdent
op' [t1' :: Pattern PredType
t1', t2' :: Pattern PredType
t2'] = Pattern PredType
t'
(PredSet, Type, Pattern PredType)
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, Type
ty, SpanInfo
-> PredType
-> Pattern PredType
-> QualIdent
-> Pattern PredType
-> Pattern PredType
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixFuncPattern SpanInfo
spi PredType
a' Pattern PredType
t1' QualIdent
op' Pattern PredType
t2')
tcFuncPattern :: HasSpanInfo p => p -> SpanInfo -> Doc -> QualIdent
-> ([Pattern PredType] -> [Pattern PredType])
-> PredSet -> Type -> [Pattern a]
-> PTCM (PredSet, Type, Pattern PredType)
tcFuncPattern :: p
-> SpanInfo
-> Doc
-> QualIdent
-> ([Pattern PredType] -> [Pattern PredType])
-> PredSet
-> Type
-> [Pattern a]
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
tcFuncPattern _ spi :: SpanInfo
spi _ f :: QualIdent
f ts :: [Pattern PredType] -> [Pattern PredType]
ts ps :: PredSet
ps ty :: Type
ty [] =
(PredSet, Type, Pattern PredType)
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pred -> PredSet -> PredSet
forall a. Ord a => a -> Set a -> Set a
Set.insert (QualIdent -> Type -> Pred
Pred QualIdent
qDataId Type
ty) PredSet
ps, Type
ty, SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
FunctionPattern SpanInfo
spi (Type -> PredType
predType Type
ty) QualIdent
f ([Pattern PredType] -> [Pattern PredType]
ts []))
tcFuncPattern p :: p
p spi :: SpanInfo
spi doc :: Doc
doc f :: QualIdent
f ts :: [Pattern PredType] -> [Pattern PredType]
ts ps :: PredSet
ps ty :: Type
ty (t' :: Pattern a
t':ts' :: [Pattern a]
ts') = do
(alpha :: Type
alpha, beta :: Type
beta) <- StateT TcState Identity (Type, Type)
-> StateT (Set Ident) TCM (Type, Type)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT TcState Identity (Type, Type)
-> StateT (Set Ident) TCM (Type, Type))
-> StateT TcState Identity (Type, Type)
-> StateT (Set Ident) TCM (Type, Type)
forall a b. (a -> b) -> a -> b
$
p -> String -> Doc -> Type -> StateT TcState Identity (Type, Type)
forall p.
HasSpanInfo p =>
p -> String -> Doc -> Type -> StateT TcState Identity (Type, Type)
tcArrow p
p "functional pattern" (Doc
doc Doc -> Doc -> Doc
$-$ String -> Doc
text "Term:" Doc -> Doc -> Doc
<+> Int -> Pattern PredType -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Pattern PredType
t) Type
ty
(ps' :: PredSet
ps', t'' :: Pattern PredType
t'') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Pattern PredType)
ptcPatternArg p
p "functional pattern" Doc
doc PredSet
ps Type
alpha Pattern a
t'
p
-> SpanInfo
-> Doc
-> QualIdent
-> ([Pattern PredType] -> [Pattern PredType])
-> PredSet
-> Type
-> [Pattern a]
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> SpanInfo
-> Doc
-> QualIdent
-> ([Pattern PredType] -> [Pattern PredType])
-> PredSet
-> Type
-> [Pattern a]
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
tcFuncPattern p
p SpanInfo
spi Doc
doc QualIdent
f ([Pattern PredType] -> [Pattern PredType]
ts ([Pattern PredType] -> [Pattern PredType])
-> ([Pattern PredType] -> [Pattern PredType])
-> [Pattern PredType]
-> [Pattern PredType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern PredType
t'' Pattern PredType -> [Pattern PredType] -> [Pattern PredType]
forall a. a -> [a] -> [a]
:)) PredSet
ps' Type
beta [Pattern a]
ts'
where t :: Pattern PredType
t = SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
FunctionPattern SpanInfo
spi (Type -> PredType
predType Type
ty) QualIdent
f ([Pattern PredType] -> [Pattern PredType]
ts [])
ptcPatternArg :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type
-> Pattern a -> PTCM (PredSet, Pattern PredType)
ptcPatternArg :: p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Pattern PredType)
ptcPatternArg p :: p
p what :: String
what doc :: Doc
doc ps :: PredSet
ps ty :: Type
ty t :: Pattern a
t =
p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> Pattern a
-> StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
tcPatternHelper p
p Pattern a
t StateT (Set Ident) TCM (PredSet, Type, Pattern PredType)
-> (PredSet -> Type -> StateT (Set Ident) TCM PredSet)
-> StateT (Set Ident) TCM (PredSet, Pattern PredType)
forall (m :: * -> *) a b c.
Monad m =>
m (a, b, c) -> (a -> b -> m a) -> m (a, c)
>>-
(\ps' :: PredSet
ps' ty' :: Type
ty' -> TCM PredSet -> StateT (Set Ident) TCM PredSet
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM PredSet -> StateT (Set Ident) TCM PredSet)
-> TCM PredSet -> StateT (Set Ident) TCM PredSet
forall a b. (a -> b) -> a -> b
$
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unify p
p String
what (Doc
doc Doc -> Doc -> Doc
$-$ String -> Doc
text "Term:" Doc -> Doc -> Doc
<+> Int -> Pattern a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Pattern a
t) PredSet
ps Type
ty PredSet
ps' Type
ty')
tcPatternArg :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type
-> Pattern a -> TCM (PredSet, Pattern PredType)
tcPatternArg :: p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> TCM (PredSet, Pattern PredType)
tcPatternArg p :: p
p what :: String
what doc :: Doc
doc ps :: PredSet
ps ty :: Type
ty t :: Pattern a
t =
p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern p
p Pattern a
t TCM (PredSet, Type, Pattern PredType)
-> (PredSet -> Type -> TCM PredSet)
-> TCM (PredSet, Pattern PredType)
forall (m :: * -> *) a b c.
Monad m =>
m (a, b, c) -> (a -> b -> m a) -> m (a, c)
>>-
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unify p
p String
what (Doc
doc Doc -> Doc -> Doc
$-$ String -> Doc
text "Term:" Doc -> Doc -> Doc
<+> Int -> Pattern a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Pattern a
t) PredSet
ps Type
ty
tcRhs :: Rhs a -> TCM (PredSet, Type, Rhs PredType)
tcRhs :: Rhs a -> TCM (PredSet, Type, Rhs PredType)
tcRhs (SimpleRhs p :: SpanInfo
p li :: LayoutInfo
li e :: Expression a
e ds :: [Decl a]
ds) = do
(ps :: PredSet
ps, ds' :: [Decl PredType]
ds', ps' :: PredSet
ps', ty :: Type
ty, e' :: Expression PredType
e') <- TCM (PredSet, [Decl PredType], PredSet, Type, Expression PredType)
-> TCM
(PredSet, [Decl PredType], PredSet, Type, Expression PredType)
forall a. TCM a -> TCM a
withLocalValueEnv (TCM (PredSet, [Decl PredType], PredSet, Type, Expression PredType)
-> TCM
(PredSet, [Decl PredType], PredSet, Type, Expression PredType))
-> TCM
(PredSet, [Decl PredType], PredSet, Type, Expression PredType)
-> TCM
(PredSet, [Decl PredType], PredSet, Type, Expression PredType)
forall a b. (a -> b) -> a -> b
$ do
(ps :: PredSet
ps, ds' :: [Decl PredType]
ds') <- [Decl a] -> TCM (PredSet, [Decl PredType])
forall a. [Decl a] -> TCM (PredSet, [Decl PredType])
tcDecls [Decl a]
ds
(ps' :: PredSet
ps', ty :: Type
ty, e' :: Expression PredType
e') <- Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr Expression a
e
(PredSet, [Decl PredType], PredSet, Type, Expression PredType)
-> TCM
(PredSet, [Decl PredType], PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, [Decl PredType]
ds', PredSet
ps', Type
ty, Expression PredType
e')
PredSet
ps'' <- SpanInfo -> String -> Doc -> PredSet -> TCM PredSet
forall p.
HasSpanInfo p =>
p -> String -> Doc -> PredSet -> TCM PredSet
reducePredSet SpanInfo
p "expression" (Int -> Expression PredType -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression PredType
e') (PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps')
(PredSet, Type, Rhs PredType) -> TCM (PredSet, Type, Rhs PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps'', Type
ty, SpanInfo
-> LayoutInfo
-> Expression PredType
-> [Decl PredType]
-> Rhs PredType
forall a.
SpanInfo -> LayoutInfo -> Expression a -> [Decl a] -> Rhs a
SimpleRhs SpanInfo
p LayoutInfo
li Expression PredType
e' [Decl PredType]
ds')
tcRhs (GuardedRhs spi :: SpanInfo
spi li :: LayoutInfo
li es :: [CondExpr a]
es ds :: [Decl a]
ds) = TCM (PredSet, Type, Rhs PredType)
-> TCM (PredSet, Type, Rhs PredType)
forall a. TCM a -> TCM a
withLocalValueEnv (TCM (PredSet, Type, Rhs PredType)
-> TCM (PredSet, Type, Rhs PredType))
-> TCM (PredSet, Type, Rhs PredType)
-> TCM (PredSet, Type, Rhs PredType)
forall a b. (a -> b) -> a -> b
$ do
(ps :: PredSet
ps, ds' :: [Decl PredType]
ds') <- [Decl a] -> TCM (PredSet, [Decl PredType])
forall a. [Decl a] -> TCM (PredSet, [Decl PredType])
tcDecls [Decl a]
ds
Type
ty <- StateT TcState Identity Type
freshTypeVar
(ps' :: PredSet
ps', es' :: [CondExpr PredType]
es') <- (PredSet
-> CondExpr a
-> StateT TcState Identity (PredSet, CondExpr PredType))
-> PredSet
-> [CondExpr a]
-> StateT TcState Identity (PredSet, [CondExpr PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM (Type
-> PredSet
-> CondExpr a
-> StateT TcState Identity (PredSet, CondExpr PredType)
forall a.
Type
-> PredSet
-> CondExpr a
-> StateT TcState Identity (PredSet, CondExpr PredType)
tcCondExpr Type
ty) PredSet
ps [CondExpr a]
es
(PredSet, Type, Rhs PredType) -> TCM (PredSet, Type, Rhs PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps', Type
ty, SpanInfo
-> LayoutInfo
-> [CondExpr PredType]
-> [Decl PredType]
-> Rhs PredType
forall a.
SpanInfo -> LayoutInfo -> [CondExpr a] -> [Decl a] -> Rhs a
GuardedRhs SpanInfo
spi LayoutInfo
li [CondExpr PredType]
es' [Decl PredType]
ds')
tcCondExpr :: Type -> PredSet -> CondExpr a -> TCM (PredSet, CondExpr PredType)
tcCondExpr :: Type
-> PredSet
-> CondExpr a
-> StateT TcState Identity (PredSet, CondExpr PredType)
tcCondExpr ty :: Type
ty ps :: PredSet
ps (CondExpr p :: SpanInfo
p g :: Expression a
g e :: Expression a
e) = do
(ps' :: PredSet
ps', g' :: Expression PredType
g') <- Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr Expression a
g TCM (PredSet, Type, Expression PredType)
-> (PredSet -> Type -> TCM PredSet)
-> StateT TcState Identity (PredSet, Expression PredType)
forall (m :: * -> *) a b c.
Monad m =>
m (a, b, c) -> (a -> b -> m a) -> m (a, c)
>>- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unify SpanInfo
p "guard" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
g) PredSet
ps Type
boolType
(ps'' :: PredSet
ps'', e' :: Expression PredType
e') <- Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr Expression a
e TCM (PredSet, Type, Expression PredType)
-> (PredSet -> Type -> TCM PredSet)
-> StateT TcState Identity (PredSet, Expression PredType)
forall (m :: * -> *) a b c.
Monad m =>
m (a, b, c) -> (a -> b -> m a) -> m (a, c)
>>- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unify SpanInfo
p "guarded expression" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps' Type
ty
(PredSet, CondExpr PredType)
-> StateT TcState Identity (PredSet, CondExpr PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps'', SpanInfo
-> Expression PredType -> Expression PredType -> CondExpr PredType
forall a. SpanInfo -> Expression a -> Expression a -> CondExpr a
CondExpr SpanInfo
p Expression PredType
g' Expression PredType
e')
tcExpr :: Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr :: Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr (Literal spi :: SpanInfo
spi _ l :: Literal
l) = do
(ps :: PredSet
ps, ty :: Type
ty) <- Bool -> Literal -> StateT TcState Identity (PredSet, Type)
tcLiteral Bool
True Literal
l
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, Type
ty, SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
spi (Type -> PredType
predType Type
ty) Literal
l)
tcExpr (Variable spi :: SpanInfo
spi _ v :: QualIdent
v) = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
(ps :: PredSet
ps, ty :: Type
ty) <- if Ident -> Bool
isAnonId (QualIdent -> Ident
unqualify QualIdent
v) then [QualIdent] -> StateT TcState Identity (PredSet, Type)
freshPredType [QualIdent
qDataId]
else TypeScheme -> StateT TcState Identity (PredSet, Type)
inst (ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
funType ModuleIdent
m QualIdent
v ValueEnv
vEnv)
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, Type
ty, SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
spi (Type -> PredType
predType Type
ty) QualIdent
v)
tcExpr (Constructor spi :: SpanInfo
spi _ c :: QualIdent
c) = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
(ps :: PredSet
ps, ty :: Type
ty) <- TypeScheme -> StateT TcState Identity (PredSet, Type)
inst (ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
constrType ModuleIdent
m QualIdent
c ValueEnv
vEnv)
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, Type
ty, SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
spi (Type -> PredType
predType Type
ty) QualIdent
c)
tcExpr (Paren spi :: SpanInfo
spi e :: Expression a
e) = do
(ps :: PredSet
ps, ty :: Type
ty, e' :: Expression PredType
e') <- Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr Expression a
e
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, Type
ty, SpanInfo -> Expression PredType -> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a
Paren SpanInfo
spi Expression PredType
e')
tcExpr (Typed spi :: SpanInfo
spi e :: Expression a
e qty :: QualTypeExpr
qty) = do
PredType
pty <- QualTypeExpr -> StateT TcState Identity PredType
expandPoly QualTypeExpr
qty
(ps :: PredSet
ps, ty :: Type
ty) <- TypeScheme -> StateT TcState Identity (PredSet, Type)
inst (PredType -> TypeScheme
typeScheme PredType
pty)
(ps' :: PredSet
ps', e' :: Expression PredType
e') <- Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr Expression a
e TCM (PredSet, Type, Expression PredType)
-> (PredSet -> Type -> TCM PredSet)
-> StateT TcState Identity (PredSet, Expression PredType)
forall (m :: * -> *) a b c.
Monad m =>
m (a, b, c) -> (a -> b -> m a) -> m (a, c)
>>-
SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unifyDecl SpanInfo
spi "explicitly typed expression" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
emptyPredSet Type
ty
Set Int
fvs <- TCM (Set Int)
computeFvEnv
TypeSubst
theta <- TCM TypeSubst
getTypeSubst
let (gps :: PredSet
gps, lps :: PredSet
lps) = Set Int -> PredSet -> (PredSet, PredSet)
splitPredSet Set Int
fvs PredSet
ps'
tySc :: TypeScheme
tySc = Set Int -> PredSet -> Type -> TypeScheme
gen Set Int
fvs PredSet
lps (TypeSubst -> Type -> Type
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta Type
ty)
StateT TcState Identity Bool -> TCM () -> TCM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PredType -> TypeScheme -> StateT TcState Identity Bool
checkTypeSig PredType
pty TypeScheme
tySc) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
Message -> TCM ()
report (Message -> TCM ()) -> Message -> TCM ()
forall a b. (a -> b) -> a -> b
$
ModuleIdent -> Doc -> QualTypeExpr -> TypeScheme -> Message
errTypeSigTooGeneral ModuleIdent
m (String -> Doc
text "Expression:" Doc -> Doc -> Doc
<+> Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) QualTypeExpr
qty TypeScheme
tySc
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
gps, Type
ty, SpanInfo
-> Expression PredType -> QualTypeExpr -> Expression PredType
forall a. SpanInfo -> Expression a -> QualTypeExpr -> Expression a
Typed SpanInfo
spi Expression PredType
e' QualTypeExpr
qty)
tcExpr e :: Expression a
e@(Record spi :: SpanInfo
spi _ c :: QualIdent
c fs :: [Field (Expression a)]
fs) = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
(ps :: PredSet
ps, ty :: Type
ty) <- (Type -> Type) -> (PredSet, Type) -> (PredSet, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
arrowBase ((PredSet, Type) -> (PredSet, Type))
-> StateT TcState Identity (PredSet, Type)
-> StateT TcState Identity (PredSet, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeScheme -> StateT TcState Identity (PredSet, Type)
inst (ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
constrType ModuleIdent
m QualIdent
c ValueEnv
vEnv)
(ps' :: PredSet
ps', fs' :: [Field (Expression PredType)]
fs') <- (PredSet
-> Field (Expression a)
-> StateT TcState Identity (PredSet, Field (Expression PredType)))
-> PredSet
-> [Field (Expression a)]
-> StateT TcState Identity (PredSet, [Field (Expression PredType)])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM ((SpanInfo
-> Expression a -> TCM (PredSet, Type, Expression PredType))
-> String
-> (Expression a -> Doc)
-> Type
-> PredSet
-> Field (Expression a)
-> StateT TcState Identity (PredSet, Field (Expression PredType))
forall (a :: * -> *) b.
(SpanInfo -> a b -> TCM (PredSet, Type, a PredType))
-> String
-> (a b -> Doc)
-> Type
-> PredSet
-> Field (a b)
-> TCM (PredSet, Field (a PredType))
tcField ((Expression a -> TCM (PredSet, Type, Expression PredType))
-> SpanInfo
-> Expression a
-> TCM (PredSet, Type, Expression PredType)
forall a b. a -> b -> a
const Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr) "construction"
(\e' :: Expression a
e' -> Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e Doc -> Doc -> Doc
$-$ String -> Doc
text "Term:" Doc -> Doc -> Doc
<+> Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e') Type
ty) PredSet
ps [Field (Expression a)]
fs
let missing :: [QualIdent]
missing = (Ident -> QualIdent) -> [Ident] -> [QualIdent]
forall a b. (a -> b) -> [a] -> [b]
map (QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
c) (ModuleIdent -> QualIdent -> ValueEnv -> [Ident]
constrLabels ModuleIdent
m QualIdent
c ValueEnv
vEnv)
[QualIdent] -> [QualIdent] -> [QualIdent]
forall a. Eq a => [a] -> [a] -> [a]
\\ (Field (Expression PredType) -> QualIdent)
-> [Field (Expression PredType)] -> [QualIdent]
forall a b. (a -> b) -> [a] -> [b]
map (\(Field _ qid :: QualIdent
qid _) -> QualIdent
qid) [Field (Expression PredType)]
fs'
[PredSet]
pss <- (QualIdent -> TCM PredSet)
-> [QualIdent] -> StateT TcState Identity [PredSet]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Type -> QualIdent -> TCM PredSet
forall p. HasSpanInfo p => p -> Type -> QualIdent -> TCM PredSet
tcMissingField SpanInfo
spi Type
ty) [QualIdent]
missing
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([PredSet] -> PredSet
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (PredSet
ps'PredSet -> [PredSet] -> [PredSet]
forall a. a -> [a] -> [a]
:[PredSet]
pss), Type
ty, SpanInfo
-> PredType
-> QualIdent
-> [Field (Expression PredType)]
-> Expression PredType
forall a.
SpanInfo
-> a -> QualIdent -> [Field (Expression a)] -> Expression a
Record SpanInfo
spi (Type -> PredType
predType Type
ty) QualIdent
c [Field (Expression PredType)]
fs')
tcExpr e :: Expression a
e@(RecordUpdate spi :: SpanInfo
spi e1 :: Expression a
e1 fs :: [Field (Expression a)]
fs) = do
(ps :: PredSet
ps, ty :: Type
ty, e1' :: Expression PredType
e1') <- Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr Expression a
e1
(ps' :: PredSet
ps', fs' :: [Field (Expression PredType)]
fs') <- (PredSet
-> Field (Expression a)
-> StateT TcState Identity (PredSet, Field (Expression PredType)))
-> PredSet
-> [Field (Expression a)]
-> StateT TcState Identity (PredSet, [Field (Expression PredType)])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM ((SpanInfo
-> Expression a -> TCM (PredSet, Type, Expression PredType))
-> String
-> (Expression a -> Doc)
-> Type
-> PredSet
-> Field (Expression a)
-> StateT TcState Identity (PredSet, Field (Expression PredType))
forall (a :: * -> *) b.
(SpanInfo -> a b -> TCM (PredSet, Type, a PredType))
-> String
-> (a b -> Doc)
-> Type
-> PredSet
-> Field (a b)
-> TCM (PredSet, Field (a PredType))
tcField ((Expression a -> TCM (PredSet, Type, Expression PredType))
-> SpanInfo
-> Expression a
-> TCM (PredSet, Type, Expression PredType)
forall a b. a -> b -> a
const Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr) "update"
(\e' :: Expression a
e' -> Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e Doc -> Doc -> Doc
$-$ String -> Doc
text "Term:" Doc -> Doc -> Doc
<+> Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e') Type
ty) PredSet
ps [Field (Expression a)]
fs
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps', Type
ty, SpanInfo
-> Expression PredType
-> [Field (Expression PredType)]
-> Expression PredType
forall a.
SpanInfo -> Expression a -> [Field (Expression a)] -> Expression a
RecordUpdate SpanInfo
spi Expression PredType
e1' [Field (Expression PredType)]
fs')
tcExpr (Tuple spi :: SpanInfo
spi es :: [Expression a]
es) = do
(pss :: [PredSet]
pss, tys :: [Type]
tys, es' :: [Expression PredType]
es') <- ([(PredSet, Type, Expression PredType)]
-> ([PredSet], [Type], [Expression PredType]))
-> StateT TcState Identity [(PredSet, Type, Expression PredType)]
-> StateT
TcState Identity ([PredSet], [Type], [Expression PredType])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(PredSet, Type, Expression PredType)]
-> ([PredSet], [Type], [Expression PredType])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 (StateT TcState Identity [(PredSet, Type, Expression PredType)]
-> StateT
TcState Identity ([PredSet], [Type], [Expression PredType]))
-> StateT TcState Identity [(PredSet, Type, Expression PredType)]
-> StateT
TcState Identity ([PredSet], [Type], [Expression PredType])
forall a b. (a -> b) -> a -> b
$ (Expression a -> TCM (PredSet, Type, Expression PredType))
-> [Expression a]
-> StateT TcState Identity [(PredSet, Type, Expression PredType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr) [Expression a]
es
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([PredSet] -> PredSet
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [PredSet]
pss, [Type] -> Type
tupleType [Type]
tys, SpanInfo -> [Expression PredType] -> Expression PredType
forall a. SpanInfo -> [Expression a] -> Expression a
Tuple SpanInfo
spi [Expression PredType]
es')
tcExpr e :: Expression a
e@(List spi :: SpanInfo
spi _ es :: [Expression a]
es) = do
Type
ty <- StateT TcState Identity Type
freshTypeVar
(ps :: PredSet
ps, es' :: [Expression PredType]
es') <-
(PredSet
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType))
-> PredSet
-> [Expression a]
-> StateT TcState Identity (PredSet, [Expression PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM ((PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType))
-> Type
-> PredSet
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg SpanInfo
spi "expression" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e)) Type
ty) PredSet
emptyPredSet [Expression a]
es
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, Type -> Type
listType Type
ty, SpanInfo
-> PredType -> [Expression PredType] -> Expression PredType
forall a. SpanInfo -> a -> [Expression a] -> Expression a
List SpanInfo
spi (Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
listType Type
ty) [Expression PredType]
es')
tcExpr (ListCompr spi :: SpanInfo
spi e :: Expression a
e qs :: [Statement a]
qs) = do
(ps :: PredSet
ps, qs' :: [Statement PredType]
qs', ps' :: PredSet
ps', ty :: Type
ty, e' :: Expression PredType
e') <- TCM
(PredSet, [Statement PredType], PredSet, Type, Expression PredType)
-> TCM
(PredSet, [Statement PredType], PredSet, Type, Expression PredType)
forall a. TCM a -> TCM a
withLocalValueEnv (TCM
(PredSet, [Statement PredType], PredSet, Type, Expression PredType)
-> TCM
(PredSet, [Statement PredType], PredSet, Type,
Expression PredType))
-> TCM
(PredSet, [Statement PredType], PredSet, Type, Expression PredType)
-> TCM
(PredSet, [Statement PredType], PredSet, Type, Expression PredType)
forall a b. (a -> b) -> a -> b
$ do
(ps :: PredSet
ps, qs' :: [Statement PredType]
qs') <- (PredSet
-> Statement a
-> StateT TcState Identity (PredSet, Statement PredType))
-> PredSet
-> [Statement a]
-> StateT TcState Identity (PredSet, [Statement PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM (SpanInfo
-> PredSet
-> Statement a
-> StateT TcState Identity (PredSet, Statement PredType)
forall p a.
HasSpanInfo p =>
p
-> PredSet
-> Statement a
-> StateT TcState Identity (PredSet, Statement PredType)
tcQual SpanInfo
spi) PredSet
emptyPredSet [Statement a]
qs
(ps' :: PredSet
ps', ty :: Type
ty, e' :: Expression PredType
e') <- Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr Expression a
e
(PredSet, [Statement PredType], PredSet, Type, Expression PredType)
-> TCM
(PredSet, [Statement PredType], PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, [Statement PredType]
qs', PredSet
ps', Type
ty, Expression PredType
e')
PredSet
ps'' <- SpanInfo -> String -> Doc -> PredSet -> TCM PredSet
forall p.
HasSpanInfo p =>
p -> String -> Doc -> PredSet -> TCM PredSet
reducePredSet SpanInfo
spi "expression" (Int -> Expression PredType -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression PredType
e') (PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps')
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps'', Type -> Type
listType Type
ty, SpanInfo
-> Expression PredType
-> [Statement PredType]
-> Expression PredType
forall a. SpanInfo -> Expression a -> [Statement a] -> Expression a
ListCompr SpanInfo
spi Expression PredType
e' [Statement PredType]
qs')
tcExpr e :: Expression a
e@(EnumFrom spi :: SpanInfo
spi e1 :: Expression a
e1) = do
(ps :: PredSet
ps, ty :: Type
ty) <- StateT TcState Identity (PredSet, Type)
freshEnumType
(ps' :: PredSet
ps', e1' :: Expression PredType
e1') <- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg SpanInfo
spi "arithmetic sequence" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps Type
ty Expression a
e1
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps', Type -> Type
listType Type
ty, SpanInfo -> Expression PredType -> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a
EnumFrom SpanInfo
spi Expression PredType
e1')
tcExpr e :: Expression a
e@(EnumFromThen spi :: SpanInfo
spi e1 :: Expression a
e1 e2 :: Expression a
e2) = do
(ps :: PredSet
ps, ty :: Type
ty) <- StateT TcState Identity (PredSet, Type)
freshEnumType
(ps' :: PredSet
ps', e1' :: Expression PredType
e1') <- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg SpanInfo
spi "arithmetic sequence" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps Type
ty Expression a
e1
(ps'' :: PredSet
ps'', e2' :: Expression PredType
e2') <- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg SpanInfo
spi "arithmetic sequence" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps' Type
ty Expression a
e2
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps'', Type -> Type
listType Type
ty, SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
EnumFromThen SpanInfo
spi Expression PredType
e1' Expression PredType
e2')
tcExpr e :: Expression a
e@(EnumFromTo spi :: SpanInfo
spi e1 :: Expression a
e1 e2 :: Expression a
e2) = do
(ps :: PredSet
ps, ty :: Type
ty) <- StateT TcState Identity (PredSet, Type)
freshEnumType
(ps' :: PredSet
ps', e1' :: Expression PredType
e1') <- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg SpanInfo
spi "arithmetic sequence" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps Type
ty Expression a
e1
(ps'' :: PredSet
ps'', e2' :: Expression PredType
e2') <- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg SpanInfo
spi "arithmetic sequence" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps' Type
ty Expression a
e2
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps'', Type -> Type
listType Type
ty, SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
EnumFromTo SpanInfo
spi Expression PredType
e1' Expression PredType
e2')
tcExpr e :: Expression a
e@(EnumFromThenTo spi :: SpanInfo
spi e1 :: Expression a
e1 e2 :: Expression a
e2 e3 :: Expression a
e3) = do
(ps :: PredSet
ps, ty :: Type
ty) <- StateT TcState Identity (PredSet, Type)
freshEnumType
(ps' :: PredSet
ps', e1' :: Expression PredType
e1') <- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg SpanInfo
spi "arithmetic sequence" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps Type
ty Expression a
e1
(ps'' :: PredSet
ps'', e2' :: Expression PredType
e2') <- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg SpanInfo
spi "arithmetic sequence" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps' Type
ty Expression a
e2
(ps''' :: PredSet
ps''', e3' :: Expression PredType
e3') <- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg SpanInfo
spi "arithmetic sequence" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps'' Type
ty Expression a
e3
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps''', Type -> Type
listType Type
ty, SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a.
SpanInfo
-> Expression a -> Expression a -> Expression a -> Expression a
EnumFromThenTo SpanInfo
spi Expression PredType
e1' Expression PredType
e2' Expression PredType
e3')
tcExpr e :: Expression a
e@(UnaryMinus spi :: SpanInfo
spi e1 :: Expression a
e1) = do
(ps :: PredSet
ps, ty :: Type
ty) <- StateT TcState Identity (PredSet, Type)
freshNumType
(ps' :: PredSet
ps', e1' :: Expression PredType
e1') <- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg SpanInfo
spi "unary negation" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps Type
ty Expression a
e1
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps', Type
ty, SpanInfo -> Expression PredType -> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a
UnaryMinus SpanInfo
spi Expression PredType
e1')
tcExpr e :: Expression a
e@(Apply spi :: SpanInfo
spi e1 :: Expression a
e1 e2 :: Expression a
e2) = do
(ps :: PredSet
ps, (alpha :: Type
alpha, beta :: Type
beta), e1' :: Expression PredType
e1') <- Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr Expression a
e1 TCM (PredSet, Type, Expression PredType)
-> (Type -> StateT TcState Identity (Type, Type))
-> TCM (PredSet, (Type, Type), Expression PredType)
forall a b d c. TCM (a, b, d) -> (b -> TCM c) -> TCM (a, c, d)
>>=-
SpanInfo
-> String -> Doc -> Type -> StateT TcState Identity (Type, Type)
forall p.
HasSpanInfo p =>
p -> String -> Doc -> Type -> StateT TcState Identity (Type, Type)
tcArrow SpanInfo
spi "application" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e Doc -> Doc -> Doc
$-$ String -> Doc
text "Term:" Doc -> Doc -> Doc
<+> Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e1)
(ps' :: PredSet
ps', e2' :: Expression PredType
e2') <- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg SpanInfo
spi "application" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps Type
alpha Expression a
e2
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps', Type
beta, SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
spi Expression PredType
e1' Expression PredType
e2')
tcExpr e :: Expression a
e@(InfixApply spi :: SpanInfo
spi e1 :: Expression a
e1 op :: InfixOp a
op e2 :: Expression a
e2) = do
(ps :: PredSet
ps, (alpha :: Type
alpha, beta :: Type
beta, gamma :: Type
gamma), op' :: InfixOp PredType
op') <- InfixOp a -> TCM (PredSet, Type, InfixOp PredType)
forall a. InfixOp a -> TCM (PredSet, Type, InfixOp PredType)
tcInfixOp InfixOp a
op TCM (PredSet, Type, InfixOp PredType)
-> (Type -> TCM (Type, Type, Type))
-> TCM (PredSet, (Type, Type, Type), InfixOp PredType)
forall a b d c. TCM (a, b, d) -> (b -> TCM c) -> TCM (a, c, d)
>>=-
SpanInfo -> String -> Doc -> Type -> TCM (Type, Type, Type)
forall p.
HasSpanInfo p =>
p -> String -> Doc -> Type -> TCM (Type, Type, Type)
tcBinary SpanInfo
spi "infix application" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e Doc -> Doc -> Doc
$-$ String -> Doc
text "Operator:" Doc -> Doc -> Doc
<+> InfixOp a -> Doc
forall a. Pretty a => a -> Doc
pPrint InfixOp a
op)
(ps' :: PredSet
ps', e1' :: Expression PredType
e1') <- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg SpanInfo
spi "infix application" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps Type
alpha Expression a
e1
(ps'' :: PredSet
ps'', e2' :: Expression PredType
e2') <- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg SpanInfo
spi "infix application" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps' Type
beta Expression a
e2
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps'', Type
gamma, SpanInfo
-> Expression PredType
-> InfixOp PredType
-> Expression PredType
-> Expression PredType
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply SpanInfo
spi Expression PredType
e1' InfixOp PredType
op' Expression PredType
e2')
tcExpr e :: Expression a
e@(LeftSection spi :: SpanInfo
spi e1 :: Expression a
e1 op :: InfixOp a
op) = do
(ps :: PredSet
ps, (alpha :: Type
alpha, beta :: Type
beta), op' :: InfixOp PredType
op') <- InfixOp a -> TCM (PredSet, Type, InfixOp PredType)
forall a. InfixOp a -> TCM (PredSet, Type, InfixOp PredType)
tcInfixOp InfixOp a
op TCM (PredSet, Type, InfixOp PredType)
-> (Type -> StateT TcState Identity (Type, Type))
-> TCM (PredSet, (Type, Type), InfixOp PredType)
forall a b d c. TCM (a, b, d) -> (b -> TCM c) -> TCM (a, c, d)
>>=-
SpanInfo
-> String -> Doc -> Type -> StateT TcState Identity (Type, Type)
forall p.
HasSpanInfo p =>
p -> String -> Doc -> Type -> StateT TcState Identity (Type, Type)
tcArrow SpanInfo
spi "left section" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e Doc -> Doc -> Doc
$-$ String -> Doc
text "Operator:" Doc -> Doc -> Doc
<+> InfixOp a -> Doc
forall a. Pretty a => a -> Doc
pPrint InfixOp a
op)
(ps' :: PredSet
ps', e1' :: Expression PredType
e1') <- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg SpanInfo
spi "left section" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps Type
alpha Expression a
e1
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps', Type
beta, SpanInfo
-> Expression PredType -> InfixOp PredType -> Expression PredType
forall a. SpanInfo -> Expression a -> InfixOp a -> Expression a
LeftSection SpanInfo
spi Expression PredType
e1' InfixOp PredType
op')
tcExpr e :: Expression a
e@(RightSection spi :: SpanInfo
spi op :: InfixOp a
op e1 :: Expression a
e1) = do
(ps :: PredSet
ps, (alpha :: Type
alpha, beta :: Type
beta, gamma :: Type
gamma), op' :: InfixOp PredType
op') <- InfixOp a -> TCM (PredSet, Type, InfixOp PredType)
forall a. InfixOp a -> TCM (PredSet, Type, InfixOp PredType)
tcInfixOp InfixOp a
op TCM (PredSet, Type, InfixOp PredType)
-> (Type -> TCM (Type, Type, Type))
-> TCM (PredSet, (Type, Type, Type), InfixOp PredType)
forall a b d c. TCM (a, b, d) -> (b -> TCM c) -> TCM (a, c, d)
>>=-
SpanInfo -> String -> Doc -> Type -> TCM (Type, Type, Type)
forall p.
HasSpanInfo p =>
p -> String -> Doc -> Type -> TCM (Type, Type, Type)
tcBinary SpanInfo
spi "right section" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e Doc -> Doc -> Doc
$-$ String -> Doc
text "Operator:" Doc -> Doc -> Doc
<+> InfixOp a -> Doc
forall a. Pretty a => a -> Doc
pPrint InfixOp a
op)
(ps' :: PredSet
ps', e1' :: Expression PredType
e1') <- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg SpanInfo
spi "right section" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps Type
beta Expression a
e1
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps', Type -> Type -> Type
TypeArrow Type
alpha Type
gamma, SpanInfo
-> InfixOp PredType -> Expression PredType -> Expression PredType
forall a. SpanInfo -> InfixOp a -> Expression a -> Expression a
RightSection SpanInfo
spi InfixOp PredType
op' Expression PredType
e1')
tcExpr (Lambda spi :: SpanInfo
spi ts :: [Pattern a]
ts e :: Expression a
e) = do
(pss :: [PredSet]
pss, tys :: [Type]
tys, ts' :: [Pattern PredType]
ts', ps :: PredSet
ps, ty :: Type
ty, e' :: Expression PredType
e')<- TCM
([PredSet], [Type], [Pattern PredType], PredSet, Type,
Expression PredType)
-> TCM
([PredSet], [Type], [Pattern PredType], PredSet, Type,
Expression PredType)
forall a. TCM a -> TCM a
withLocalValueEnv (TCM
([PredSet], [Type], [Pattern PredType], PredSet, Type,
Expression PredType)
-> TCM
([PredSet], [Type], [Pattern PredType], PredSet, Type,
Expression PredType))
-> TCM
([PredSet], [Type], [Pattern PredType], PredSet, Type,
Expression PredType)
-> TCM
([PredSet], [Type], [Pattern PredType], PredSet, Type,
Expression PredType)
forall a b. (a -> b) -> a -> b
$ do
[Pattern a] -> TCM ()
forall t. QuantExpr t => t -> TCM ()
bindLambdaVars [Pattern a]
ts
(pss :: [PredSet]
pss, tys :: [Type]
tys, ts' :: [Pattern PredType]
ts') <- ([(PredSet, Type, Pattern PredType)]
-> ([PredSet], [Type], [Pattern PredType]))
-> StateT TcState Identity [(PredSet, Type, Pattern PredType)]
-> StateT TcState Identity ([PredSet], [Type], [Pattern PredType])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(PredSet, Type, Pattern PredType)]
-> ([PredSet], [Type], [Pattern PredType])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 (StateT TcState Identity [(PredSet, Type, Pattern PredType)]
-> StateT TcState Identity ([PredSet], [Type], [Pattern PredType]))
-> StateT TcState Identity [(PredSet, Type, Pattern PredType)]
-> StateT TcState Identity ([PredSet], [Type], [Pattern PredType])
forall a b. (a -> b) -> a -> b
$ (Pattern a -> TCM (PredSet, Type, Pattern PredType))
-> [Pattern a]
-> StateT TcState Identity [(PredSet, Type, Pattern PredType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasSpanInfo p =>
p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern SpanInfo
spi) [Pattern a]
ts
(ps :: PredSet
ps, ty :: Type
ty, e' :: Expression PredType
e') <- Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr Expression a
e
([PredSet], [Type], [Pattern PredType], PredSet, Type,
Expression PredType)
-> TCM
([PredSet], [Type], [Pattern PredType], PredSet, Type,
Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([PredSet]
pss, [Type]
tys, [Pattern PredType]
ts', PredSet
ps, Type
ty, Expression PredType
e')
PredSet
ps' <- SpanInfo -> String -> Doc -> PredSet -> TCM PredSet
forall p.
HasSpanInfo p =>
p -> String -> Doc -> PredSet -> TCM PredSet
reducePredSet SpanInfo
spi "expression" (Int -> Expression PredType -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression PredType
e') ([PredSet] -> PredSet
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([PredSet] -> PredSet) -> [PredSet] -> PredSet
forall a b. (a -> b) -> a -> b
$ PredSet
ps PredSet -> [PredSet] -> [PredSet]
forall a. a -> [a] -> [a]
: [PredSet]
pss)
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps', (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
TypeArrow Type
ty [Type]
tys, SpanInfo
-> [Pattern PredType] -> Expression PredType -> Expression PredType
forall a. SpanInfo -> [Pattern a] -> Expression a -> Expression a
Lambda SpanInfo
spi [Pattern PredType]
ts' Expression PredType
e')
tcExpr (Let spi :: SpanInfo
spi li :: LayoutInfo
li ds :: [Decl a]
ds e :: Expression a
e) = do
(ps :: PredSet
ps, ds' :: [Decl PredType]
ds', ps' :: PredSet
ps', ty :: Type
ty, e' :: Expression PredType
e') <- TCM (PredSet, [Decl PredType], PredSet, Type, Expression PredType)
-> TCM
(PredSet, [Decl PredType], PredSet, Type, Expression PredType)
forall a. TCM a -> TCM a
withLocalValueEnv (TCM (PredSet, [Decl PredType], PredSet, Type, Expression PredType)
-> TCM
(PredSet, [Decl PredType], PredSet, Type, Expression PredType))
-> TCM
(PredSet, [Decl PredType], PredSet, Type, Expression PredType)
-> TCM
(PredSet, [Decl PredType], PredSet, Type, Expression PredType)
forall a b. (a -> b) -> a -> b
$ do
(ps :: PredSet
ps, ds' :: [Decl PredType]
ds') <- [Decl a] -> TCM (PredSet, [Decl PredType])
forall a. [Decl a] -> TCM (PredSet, [Decl PredType])
tcDecls [Decl a]
ds
(ps' :: PredSet
ps', ty :: Type
ty, e' :: Expression PredType
e') <- Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr Expression a
e
(PredSet, [Decl PredType], PredSet, Type, Expression PredType)
-> TCM
(PredSet, [Decl PredType], PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, [Decl PredType]
ds', PredSet
ps', Type
ty, Expression PredType
e')
PredSet
ps'' <- SpanInfo -> String -> Doc -> PredSet -> TCM PredSet
forall p.
HasSpanInfo p =>
p -> String -> Doc -> PredSet -> TCM PredSet
reducePredSet SpanInfo
spi "expression" (Int -> Expression PredType -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression PredType
e') (PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps')
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps'', Type
ty, SpanInfo
-> LayoutInfo
-> [Decl PredType]
-> Expression PredType
-> Expression PredType
forall a.
SpanInfo -> LayoutInfo -> [Decl a] -> Expression a -> Expression a
Let SpanInfo
spi LayoutInfo
li [Decl PredType]
ds' Expression PredType
e')
tcExpr (Do spi :: SpanInfo
spi li :: LayoutInfo
li sts :: [Statement a]
sts e :: Expression a
e) = do
(sts' :: [Statement PredType]
sts', ty :: Type
ty, ps' :: PredSet
ps', e' :: Expression PredType
e') <- TCM ([Statement PredType], Type, PredSet, Expression PredType)
-> TCM ([Statement PredType], Type, PredSet, Expression PredType)
forall a. TCM a -> TCM a
withLocalValueEnv (TCM ([Statement PredType], Type, PredSet, Expression PredType)
-> TCM ([Statement PredType], Type, PredSet, Expression PredType))
-> TCM ([Statement PredType], Type, PredSet, Expression PredType)
-> TCM ([Statement PredType], Type, PredSet, Expression PredType)
forall a b. (a -> b) -> a -> b
$ do
((ps :: PredSet
ps, mTy :: Maybe Type
mTy), sts' :: [Statement PredType]
sts') <-
((PredSet, Maybe Type)
-> Statement a
-> StateT
TcState Identity ((PredSet, Maybe Type), Statement PredType))
-> (PredSet, Maybe Type)
-> [Statement a]
-> StateT
TcState Identity ((PredSet, Maybe Type), [Statement PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM ((PredSet
-> Maybe Type
-> Statement a
-> StateT
TcState Identity ((PredSet, Maybe Type), Statement PredType))
-> (PredSet, Maybe Type)
-> Statement a
-> StateT
TcState Identity ((PredSet, Maybe Type), Statement PredType)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo
-> PredSet
-> Maybe Type
-> Statement a
-> StateT
TcState Identity ((PredSet, Maybe Type), Statement PredType)
forall p a.
HasSpanInfo p =>
p
-> PredSet
-> Maybe Type
-> Statement a
-> StateT
TcState Identity ((PredSet, Maybe Type), Statement PredType)
tcStmt SpanInfo
spi)) (PredSet
emptyPredSet, Maybe Type
forall a. Maybe a
Nothing) [Statement a]
sts
Type
ty <- (Type -> Type)
-> StateT TcState Identity Type -> StateT TcState Identity Type
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Type -> Type)
-> (Type -> Type -> Type) -> Maybe Type -> Type -> Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Type -> Type
forall a. a -> a
id Type -> Type -> Type
TypeApply Maybe Type
mTy) StateT TcState Identity Type
freshTypeVar
(ps' :: PredSet
ps', e' :: Expression PredType
e') <- Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr Expression a
e TCM (PredSet, Type, Expression PredType)
-> (PredSet -> Type -> TCM PredSet)
-> StateT TcState Identity (PredSet, Expression PredType)
forall (m :: * -> *) a b c.
Monad m =>
m (a, b, c) -> (a -> b -> m a) -> m (a, c)
>>- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unify SpanInfo
spi "statement" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps Type
ty
([Statement PredType], Type, PredSet, Expression PredType)
-> TCM ([Statement PredType], Type, PredSet, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Statement PredType]
sts', Type
ty, PredSet
ps', Expression PredType
e')
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps', Type
ty, SpanInfo
-> LayoutInfo
-> [Statement PredType]
-> Expression PredType
-> Expression PredType
forall a.
SpanInfo
-> LayoutInfo -> [Statement a] -> Expression a -> Expression a
Do SpanInfo
spi LayoutInfo
li [Statement PredType]
sts' Expression PredType
e')
tcExpr e :: Expression a
e@(IfThenElse spi :: SpanInfo
spi e1 :: Expression a
e1 e2 :: Expression a
e2 e3 :: Expression a
e3) = do
(ps :: PredSet
ps, e1' :: Expression PredType
e1') <- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg SpanInfo
spi "expression" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
emptyPredSet Type
boolType Expression a
e1
(ps' :: PredSet
ps', ty :: Type
ty, e2' :: Expression PredType
e2') <- Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr Expression a
e2
(ps'' :: PredSet
ps'', e3' :: Expression PredType
e3') <- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg SpanInfo
spi "expression" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) (PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps') Type
ty Expression a
e3
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps'', Type
ty, SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a.
SpanInfo
-> Expression a -> Expression a -> Expression a -> Expression a
IfThenElse SpanInfo
spi Expression PredType
e1' Expression PredType
e2' Expression PredType
e3')
tcExpr (Case spi :: SpanInfo
spi li :: LayoutInfo
li ct :: CaseType
ct e :: Expression a
e as :: [Alt a]
as) = do
(ps :: PredSet
ps, tyLhs :: Type
tyLhs, e' :: Expression PredType
e') <- Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr Expression a
e
Type
tyRhs <- StateT TcState Identity Type
freshTypeVar
(ps' :: PredSet
ps', as' :: [Alt PredType]
as') <- (PredSet
-> Alt a -> StateT TcState Identity (PredSet, Alt PredType))
-> PredSet
-> [Alt a]
-> StateT TcState Identity (PredSet, [Alt PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM (Type
-> Type
-> PredSet
-> Alt a
-> StateT TcState Identity (PredSet, Alt PredType)
forall a.
Type
-> Type
-> PredSet
-> Alt a
-> StateT TcState Identity (PredSet, Alt PredType)
tcAlt Type
tyLhs Type
tyRhs) PredSet
ps [Alt a]
as
(PredSet, Type, Expression PredType)
-> TCM (PredSet, Type, Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps', Type
tyRhs, SpanInfo
-> LayoutInfo
-> CaseType
-> Expression PredType
-> [Alt PredType]
-> Expression PredType
forall a.
SpanInfo
-> LayoutInfo
-> CaseType
-> Expression a
-> [Alt a]
-> Expression a
Case SpanInfo
spi LayoutInfo
li CaseType
ct Expression PredType
e' [Alt PredType]
as')
tcArg :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type -> Expression a
-> TCM (PredSet, Expression PredType)
tcArg :: p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg p :: p
p what :: String
what doc :: Doc
doc ps :: PredSet
ps ty :: Type
ty e :: Expression a
e =
Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr Expression a
e TCM (PredSet, Type, Expression PredType)
-> (PredSet -> Type -> TCM PredSet)
-> StateT TcState Identity (PredSet, Expression PredType)
forall (m :: * -> *) a b c.
Monad m =>
m (a, b, c) -> (a -> b -> m a) -> m (a, c)
>>- p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unify p
p String
what (Doc
doc Doc -> Doc -> Doc
$-$ String -> Doc
text "Term:" Doc -> Doc -> Doc
<+> Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps Type
ty
tcAlt :: Type -> Type -> PredSet -> Alt a
-> TCM (PredSet, Alt PredType)
tcAlt :: Type
-> Type
-> PredSet
-> Alt a
-> StateT TcState Identity (PredSet, Alt PredType)
tcAlt tyLhs :: Type
tyLhs tyRhs :: Type
tyRhs ps :: PredSet
ps a :: Alt a
a@(Alt p :: SpanInfo
p t :: Pattern a
t rhs :: Rhs a
rhs) =
Type
-> SpanInfo
-> Pattern a
-> Rhs a
-> TCM (PredSet, Type, Alt PredType)
forall a.
Type
-> SpanInfo
-> Pattern a
-> Rhs a
-> TCM (PredSet, Type, Alt PredType)
tcAltern Type
tyLhs SpanInfo
p Pattern a
t Rhs a
rhs TCM (PredSet, Type, Alt PredType)
-> (PredSet -> Type -> TCM PredSet)
-> StateT TcState Identity (PredSet, Alt PredType)
forall (m :: * -> *) a b c.
Monad m =>
m (a, b, c) -> (a -> b -> m a) -> m (a, c)
>>-
SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unify SpanInfo
p "case alternative" (Alt a -> Doc
forall a. Pretty a => a -> Doc
pPrint Alt a
a) PredSet
ps Type
tyRhs
tcAltern :: Type -> SpanInfo -> Pattern a
-> Rhs a -> TCM (PredSet, Type, Alt PredType)
tcAltern :: Type
-> SpanInfo
-> Pattern a
-> Rhs a
-> TCM (PredSet, Type, Alt PredType)
tcAltern tyLhs :: Type
tyLhs p :: SpanInfo
p t :: Pattern a
t rhs :: Rhs a
rhs = do
(ps :: PredSet
ps, t' :: Pattern PredType
t', ps' :: PredSet
ps', ty' :: Type
ty', rhs' :: Rhs PredType
rhs') <- TCM (PredSet, Pattern PredType, PredSet, Type, Rhs PredType)
-> TCM (PredSet, Pattern PredType, PredSet, Type, Rhs PredType)
forall a. TCM a -> TCM a
withLocalValueEnv (TCM (PredSet, Pattern PredType, PredSet, Type, Rhs PredType)
-> TCM (PredSet, Pattern PredType, PredSet, Type, Rhs PredType))
-> TCM (PredSet, Pattern PredType, PredSet, Type, Rhs PredType)
-> TCM (PredSet, Pattern PredType, PredSet, Type, Rhs PredType)
forall a b. (a -> b) -> a -> b
$ do
Pattern a -> TCM ()
forall t. QuantExpr t => t -> TCM ()
bindLambdaVars Pattern a
t
(ps :: PredSet
ps, t' :: Pattern PredType
t') <-
SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> TCM (PredSet, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> TCM (PredSet, Pattern PredType)
tcPatternArg SpanInfo
p "case pattern" (Alt a -> Doc
forall a. Pretty a => a -> Doc
pPrint (SpanInfo -> Pattern a -> Rhs a -> Alt a
forall a. SpanInfo -> Pattern a -> Rhs a -> Alt a
Alt SpanInfo
p Pattern a
t Rhs a
rhs)) PredSet
emptyPredSet Type
tyLhs Pattern a
t
(ps' :: PredSet
ps', ty' :: Type
ty', rhs' :: Rhs PredType
rhs') <- Rhs a -> TCM (PredSet, Type, Rhs PredType)
forall a. Rhs a -> TCM (PredSet, Type, Rhs PredType)
tcRhs Rhs a
rhs
(PredSet, Pattern PredType, PredSet, Type, Rhs PredType)
-> TCM (PredSet, Pattern PredType, PredSet, Type, Rhs PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, Pattern PredType
t', PredSet
ps', Type
ty', Rhs PredType
rhs')
PredSet
ps'' <- SpanInfo -> String -> Doc -> PredSet -> TCM PredSet
forall p.
HasSpanInfo p =>
p -> String -> Doc -> PredSet -> TCM PredSet
reducePredSet SpanInfo
p "alternative" (Alt PredType -> Doc
forall a. Pretty a => a -> Doc
pPrint (SpanInfo -> Pattern PredType -> Rhs PredType -> Alt PredType
forall a. SpanInfo -> Pattern a -> Rhs a -> Alt a
Alt SpanInfo
p Pattern PredType
t' Rhs PredType
rhs'))
(PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps')
(PredSet, Type, Alt PredType) -> TCM (PredSet, Type, Alt PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps'', Type
ty', SpanInfo -> Pattern PredType -> Rhs PredType -> Alt PredType
forall a. SpanInfo -> Pattern a -> Rhs a -> Alt a
Alt SpanInfo
p Pattern PredType
t' Rhs PredType
rhs')
tcQual :: HasSpanInfo p => p -> PredSet -> Statement a
-> TCM (PredSet, Statement PredType)
tcQual :: p
-> PredSet
-> Statement a
-> StateT TcState Identity (PredSet, Statement PredType)
tcQual p :: p
p ps :: PredSet
ps (StmtExpr spi :: SpanInfo
spi e :: Expression a
e) = do
(ps' :: PredSet
ps', e' :: Expression PredType
e') <- Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr Expression a
e TCM (PredSet, Type, Expression PredType)
-> (PredSet -> Type -> TCM PredSet)
-> StateT TcState Identity (PredSet, Expression PredType)
forall (m :: * -> *) a b c.
Monad m =>
m (a, b, c) -> (a -> b -> m a) -> m (a, c)
>>- p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unify p
p "guard" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) PredSet
ps Type
boolType
(PredSet, Statement PredType)
-> StateT TcState Identity (PredSet, Statement PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps', SpanInfo -> Expression PredType -> Statement PredType
forall a. SpanInfo -> Expression a -> Statement a
StmtExpr SpanInfo
spi Expression PredType
e')
tcQual _ ps :: PredSet
ps (StmtDecl spi :: SpanInfo
spi li :: LayoutInfo
li ds :: [Decl a]
ds) = do
(ps' :: PredSet
ps', ds' :: [Decl PredType]
ds') <- [Decl a] -> TCM (PredSet, [Decl PredType])
forall a. [Decl a] -> TCM (PredSet, [Decl PredType])
tcDecls [Decl a]
ds
(PredSet, Statement PredType)
-> StateT TcState Identity (PredSet, Statement PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps', SpanInfo -> LayoutInfo -> [Decl PredType] -> Statement PredType
forall a. SpanInfo -> LayoutInfo -> [Decl a] -> Statement a
StmtDecl SpanInfo
spi LayoutInfo
li [Decl PredType]
ds')
tcQual p :: p
p ps :: PredSet
ps q :: Statement a
q@(StmtBind spi :: SpanInfo
spi t :: Pattern a
t e :: Expression a
e) = do
Type
alpha <- StateT TcState Identity Type
freshTypeVar
(ps' :: PredSet
ps', e' :: Expression PredType
e') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg p
p "generator" (Statement a -> Doc
forall a. Pretty a => a -> Doc
pPrint Statement a
q) PredSet
ps (Type -> Type
listType Type
alpha) Expression a
e
Pattern a -> TCM ()
forall t. QuantExpr t => t -> TCM ()
bindLambdaVars Pattern a
t
(ps'' :: PredSet
ps'', t' :: Pattern PredType
t') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> TCM (PredSet, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> TCM (PredSet, Pattern PredType)
tcPatternArg p
p "generator" (Statement a -> Doc
forall a. Pretty a => a -> Doc
pPrint Statement a
q) PredSet
ps' Type
alpha Pattern a
t
(PredSet, Statement PredType)
-> StateT TcState Identity (PredSet, Statement PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps'', SpanInfo
-> Pattern PredType -> Expression PredType -> Statement PredType
forall a. SpanInfo -> Pattern a -> Expression a -> Statement a
StmtBind SpanInfo
spi Pattern PredType
t' Expression PredType
e')
tcStmt :: HasSpanInfo p => p -> PredSet -> Maybe Type -> Statement a
-> TCM ((PredSet, Maybe Type), Statement PredType)
tcStmt :: p
-> PredSet
-> Maybe Type
-> Statement a
-> StateT
TcState Identity ((PredSet, Maybe Type), Statement PredType)
tcStmt p :: p
p ps :: PredSet
ps mTy :: Maybe Type
mTy (StmtExpr spi :: SpanInfo
spi e :: Expression a
e) = do
(ps' :: PredSet
ps', ty :: Type
ty) <- StateT TcState Identity (PredSet, Type)
-> (Type -> StateT TcState Identity (PredSet, Type))
-> Maybe Type
-> StateT TcState Identity (PredSet, Type)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StateT TcState Identity (PredSet, Type)
freshMonadType ((PredSet, Type) -> StateT TcState Identity (PredSet, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ((PredSet, Type) -> StateT TcState Identity (PredSet, Type))
-> (Type -> (PredSet, Type))
-> Type
-> StateT TcState Identity (PredSet, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) PredSet
emptyPredSet) Maybe Type
mTy
Type
alpha <- StateT TcState Identity Type
freshTypeVar
(ps'' :: PredSet
ps'', e' :: Expression PredType
e') <- Expression a -> TCM (PredSet, Type, Expression PredType)
forall a. Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr Expression a
e TCM (PredSet, Type, Expression PredType)
-> (PredSet -> Type -> TCM PredSet)
-> StateT TcState Identity (PredSet, Expression PredType)
forall (m :: * -> *) a b c.
Monad m =>
m (a, b, c) -> (a -> b -> m a) -> m (a, c)
>>-
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unify p
p "statement" (Int -> Expression a -> Doc
forall a. Pretty a => Int -> a -> Doc
pPrintPrec 0 Expression a
e) (PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps') (Type -> [Type] -> Type
applyType Type
ty [Type
alpha])
((PredSet, Maybe Type), Statement PredType)
-> StateT
TcState Identity ((PredSet, Maybe Type), Statement PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ((PredSet
ps'', Type -> Maybe Type
forall a. a -> Maybe a
Just Type
ty), SpanInfo -> Expression PredType -> Statement PredType
forall a. SpanInfo -> Expression a -> Statement a
StmtExpr SpanInfo
spi Expression PredType
e')
tcStmt _ ps :: PredSet
ps mTy :: Maybe Type
mTy (StmtDecl spi :: SpanInfo
spi li :: LayoutInfo
li ds :: [Decl a]
ds) = do
(ps' :: PredSet
ps', ds' :: [Decl PredType]
ds') <- [Decl a] -> TCM (PredSet, [Decl PredType])
forall a. [Decl a] -> TCM (PredSet, [Decl PredType])
tcDecls [Decl a]
ds
((PredSet, Maybe Type), Statement PredType)
-> StateT
TcState Identity ((PredSet, Maybe Type), Statement PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ((PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps', Maybe Type
mTy), SpanInfo -> LayoutInfo -> [Decl PredType] -> Statement PredType
forall a. SpanInfo -> LayoutInfo -> [Decl a] -> Statement a
StmtDecl SpanInfo
spi LayoutInfo
li [Decl PredType]
ds')
tcStmt p :: p
p ps :: PredSet
ps mTy :: Maybe Type
mTy st :: Statement a
st@(StmtBind spi :: SpanInfo
spi t :: Pattern a
t e :: Expression a
e) = do
Bool
failable <- Pattern a -> StateT TcState Identity Bool
forall a. Pattern a -> StateT TcState Identity Bool
checkFailableBind Pattern a
t
let freshMType :: StateT TcState Identity (PredSet, Type)
freshMType = if Bool
failable then StateT TcState Identity (PredSet, Type)
freshMonadFailType else StateT TcState Identity (PredSet, Type)
freshMonadType
(ps' :: PredSet
ps', ty :: Type
ty) <- StateT TcState Identity (PredSet, Type)
-> (Type -> StateT TcState Identity (PredSet, Type))
-> Maybe Type
-> StateT TcState Identity (PredSet, Type)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StateT TcState Identity (PredSet, Type)
freshMType ((PredSet, Type) -> StateT TcState Identity (PredSet, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ((PredSet, Type) -> StateT TcState Identity (PredSet, Type))
-> (Type -> (PredSet, Type))
-> Type
-> StateT TcState Identity (PredSet, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) PredSet
emptyPredSet) Maybe Type
mTy
Type
alpha <- StateT TcState Identity Type
freshTypeVar
(ps'' :: PredSet
ps'', e' :: Expression PredType
e') <-
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> StateT TcState Identity (PredSet, Expression PredType)
tcArg p
p "statement" (Statement a -> Doc
forall a. Pretty a => a -> Doc
pPrint Statement a
st) (PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps') (Type -> [Type] -> Type
applyType Type
ty [Type
alpha]) Expression a
e
Pattern a -> TCM ()
forall t. QuantExpr t => t -> TCM ()
bindLambdaVars Pattern a
t
(ps''' :: PredSet
ps''', t' :: Pattern PredType
t') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> TCM (PredSet, Pattern PredType)
forall p a.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> TCM (PredSet, Pattern PredType)
tcPatternArg p
p "statement" (Statement a -> Doc
forall a. Pretty a => a -> Doc
pPrint Statement a
st) PredSet
ps'' Type
alpha Pattern a
t
((PredSet, Maybe Type), Statement PredType)
-> StateT
TcState Identity ((PredSet, Maybe Type), Statement PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ((PredSet
ps''', Type -> Maybe Type
forall a. a -> Maybe a
Just Type
ty), SpanInfo
-> Pattern PredType -> Expression PredType -> Statement PredType
forall a. SpanInfo -> Pattern a -> Expression a -> Statement a
StmtBind SpanInfo
spi Pattern PredType
t' Expression PredType
e')
checkFailableBind :: Pattern a -> TCM Bool
checkFailableBind :: Pattern a -> StateT TcState Identity Bool
checkFailableBind (ConstructorPattern _ _ idt :: QualIdent
idt ps :: [Pattern a]
ps ) = do
TCEnv
tcEnv <- TCM TCEnv
getTyConsEnv
case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo QualIdent
idt TCEnv
tcEnv of
[RenamingType _ _ _ ] -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool)
-> StateT TcState Identity [Bool] -> StateT TcState Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern a -> StateT TcState Identity Bool)
-> [Pattern a] -> StateT TcState Identity [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern a -> StateT TcState Identity Bool
forall a. Pattern a -> StateT TcState Identity Bool
checkFailableBind [Pattern a]
ps
[DataType _ _ cs :: [DataConstr]
cs]
| [DataConstr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataConstr]
cs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool)
-> StateT TcState Identity [Bool] -> StateT TcState Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern a -> StateT TcState Identity Bool)
-> [Pattern a] -> StateT TcState Identity [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern a -> StateT TcState Identity Bool
forall a. Pattern a -> StateT TcState Identity Bool
checkFailableBind [Pattern a]
ps
| Bool
otherwise -> Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
_ -> Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
checkFailableBind (InfixPattern _ _ p1 :: Pattern a
p1 idt :: QualIdent
idt p2 :: Pattern a
p2) = do
TCEnv
tcEnv <- TCM TCEnv
getTyConsEnv
case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo QualIdent
idt TCEnv
tcEnv of
[RenamingType _ _ _ ] -> Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool)
-> StateT TcState Identity Bool
-> StateT TcState Identity (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a -> StateT TcState Identity Bool
forall a. Pattern a -> StateT TcState Identity Bool
checkFailableBind Pattern a
p1
StateT TcState Identity (Bool -> Bool)
-> StateT TcState Identity Bool -> StateT TcState Identity Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern a -> StateT TcState Identity Bool
forall a. Pattern a -> StateT TcState Identity Bool
checkFailableBind Pattern a
p2
[DataType _ _ cs :: [DataConstr]
cs]
| [DataConstr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataConstr]
cs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 -> Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool)
-> StateT TcState Identity Bool
-> StateT TcState Identity (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a -> StateT TcState Identity Bool
forall a. Pattern a -> StateT TcState Identity Bool
checkFailableBind Pattern a
p1
StateT TcState Identity (Bool -> Bool)
-> StateT TcState Identity Bool -> StateT TcState Identity Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern a -> StateT TcState Identity Bool
forall a. Pattern a -> StateT TcState Identity Bool
checkFailableBind Pattern a
p2
| Bool
otherwise -> Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
_ -> Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
checkFailableBind (RecordPattern _ _ idt :: QualIdent
idt fs :: [Field (Pattern a)]
fs ) = do
TCEnv
tcEnv <- TCM TCEnv
getTyConsEnv
case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo QualIdent
idt TCEnv
tcEnv of
[RenamingType _ _ _ ] -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool)
-> StateT TcState Identity [Bool] -> StateT TcState Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Field (Pattern a) -> StateT TcState Identity Bool)
-> [Field (Pattern a)] -> StateT TcState Identity [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Pattern a -> StateT TcState Identity Bool
forall a. Pattern a -> StateT TcState Identity Bool
checkFailableBind (Pattern a -> StateT TcState Identity Bool)
-> (Field (Pattern a) -> Pattern a)
-> Field (Pattern a)
-> StateT TcState Identity Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field (Pattern a) -> Pattern a
forall a. Field a -> a
fieldContent) [Field (Pattern a)]
fs
[DataType _ _ cs :: [DataConstr]
cs]
| [DataConstr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataConstr]
cs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool)
-> StateT TcState Identity [Bool] -> StateT TcState Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Field (Pattern a) -> StateT TcState Identity Bool)
-> [Field (Pattern a)] -> StateT TcState Identity [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Pattern a -> StateT TcState Identity Bool
forall a. Pattern a -> StateT TcState Identity Bool
checkFailableBind (Pattern a -> StateT TcState Identity Bool)
-> (Field (Pattern a) -> Pattern a)
-> Field (Pattern a)
-> StateT TcState Identity Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field (Pattern a) -> Pattern a
forall a. Field a -> a
fieldContent) [Field (Pattern a)]
fs
| Bool
otherwise -> Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
_ -> Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
where fieldContent :: Field a -> a
fieldContent (Field _ _ c :: a
c) = a
c
checkFailableBind (TuplePattern _ ps :: [Pattern a]
ps ) =
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool)
-> StateT TcState Identity [Bool] -> StateT TcState Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern a -> StateT TcState Identity Bool)
-> [Pattern a] -> StateT TcState Identity [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern a -> StateT TcState Identity Bool
forall a. Pattern a -> StateT TcState Identity Bool
checkFailableBind [Pattern a]
ps
checkFailableBind (AsPattern _ _ p :: Pattern a
p ) = Pattern a -> StateT TcState Identity Bool
forall a. Pattern a -> StateT TcState Identity Bool
checkFailableBind Pattern a
p
checkFailableBind (ParenPattern _ p :: Pattern a
p ) = Pattern a -> StateT TcState Identity Bool
forall a. Pattern a -> StateT TcState Identity Bool
checkFailableBind Pattern a
p
checkFailableBind (LazyPattern _ _ ) = Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
checkFailableBind (VariablePattern _ _ _ ) = Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
checkFailableBind _ = Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
tcInfixOp :: InfixOp a -> TCM (PredSet, Type, InfixOp PredType)
tcInfixOp :: InfixOp a -> TCM (PredSet, Type, InfixOp PredType)
tcInfixOp (InfixOp _ op :: QualIdent
op) = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
(ps :: PredSet
ps, ty :: Type
ty) <- TypeScheme -> StateT TcState Identity (PredSet, Type)
inst (ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
funType ModuleIdent
m QualIdent
op ValueEnv
vEnv)
(PredSet, Type, InfixOp PredType)
-> TCM (PredSet, Type, InfixOp PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, Type
ty, PredType -> QualIdent -> InfixOp PredType
forall a. a -> QualIdent -> InfixOp a
InfixOp (Type -> PredType
predType Type
ty) QualIdent
op)
tcInfixOp (InfixConstr _ op :: QualIdent
op) = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
(ps :: PredSet
ps, ty :: Type
ty) <- TypeScheme -> StateT TcState Identity (PredSet, Type)
inst (ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
constrType ModuleIdent
m QualIdent
op ValueEnv
vEnv)
(PredSet, Type, InfixOp PredType)
-> TCM (PredSet, Type, InfixOp PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps, Type
ty, PredType -> QualIdent -> InfixOp PredType
forall a. a -> QualIdent -> InfixOp a
InfixConstr (Type -> PredType
predType Type
ty) QualIdent
op)
tcField :: (SpanInfo -> a b -> TCM (PredSet, Type, a PredType))
-> String -> (a b -> Doc) -> Type -> PredSet -> Field (a b)
-> TCM (PredSet, Field (a PredType))
tcField :: (SpanInfo -> a b -> TCM (PredSet, Type, a PredType))
-> String
-> (a b -> Doc)
-> Type
-> PredSet
-> Field (a b)
-> TCM (PredSet, Field (a PredType))
tcField check :: SpanInfo -> a b -> TCM (PredSet, Type, a PredType)
check what :: String
what doc :: a b -> Doc
doc ty :: Type
ty ps :: PredSet
ps (Field p :: SpanInfo
p l :: QualIdent
l x :: a b
x) = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
(ps' :: PredSet
ps', ty' :: Type
ty') <- TypeScheme -> StateT TcState Identity (PredSet, Type)
inst (ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
labelType ModuleIdent
m QualIdent
l ValueEnv
vEnv)
let TypeArrow ty1 :: Type
ty1 ty2 :: Type
ty2 = Type
ty'
PredSet
_ <- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unify SpanInfo
p "field label" Doc
empty PredSet
emptyPredSet Type
ty PredSet
emptyPredSet Type
ty1
(ps'' :: PredSet
ps'', x' :: a PredType
x') <- SpanInfo -> a b -> TCM (PredSet, Type, a PredType)
check SpanInfo
p a b
x TCM (PredSet, Type, a PredType)
-> (PredSet -> Type -> TCM PredSet)
-> StateT TcState Identity (PredSet, a PredType)
forall (m :: * -> *) a b c.
Monad m =>
m (a, b, c) -> (a -> b -> m a) -> m (a, c)
>>-
SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unify SpanInfo
p ("record " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
what) (a b -> Doc
doc a b
x) (PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps') Type
ty2
(PredSet, Field (a PredType)) -> TCM (PredSet, Field (a PredType))
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
ps'', SpanInfo -> QualIdent -> a PredType -> Field (a PredType)
forall a. SpanInfo -> QualIdent -> a -> Field a
Field SpanInfo
p QualIdent
l a PredType
x')
tcMissingField :: HasSpanInfo p => p -> Type -> QualIdent -> TCM PredSet
tcMissingField :: p -> Type -> QualIdent -> TCM PredSet
tcMissingField p :: p
p ty :: Type
ty l :: QualIdent
l = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
(ps :: PredSet
ps, ty' :: Type
ty') <- TypeScheme -> StateT TcState Identity (PredSet, Type)
inst (ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
labelType ModuleIdent
m QualIdent
l ValueEnv
vEnv)
let TypeArrow _ ty2 :: Type
ty2 = Type
ty'
let ps' :: PredSet
ps' = Pred -> PredSet
forall a. a -> Set a
Set.singleton (QualIdent -> Type -> Pred
Pred QualIdent
qDataId Type
ty2)
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
forall p.
HasSpanInfo p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unify p
p "field label" Doc
empty PredSet
ps Type
ty' PredSet
ps' (Type -> Type -> Type
TypeArrow Type
ty Type
ty2)
tcArrow :: HasSpanInfo p => p -> String -> Doc -> Type -> TCM (Type, Type)
tcArrow :: p -> String -> Doc -> Type -> StateT TcState Identity (Type, Type)
tcArrow p :: p
p what :: String
what doc :: Doc
doc ty :: Type
ty = do
TypeSubst
theta <- TCM TypeSubst
getTypeSubst
Type -> StateT TcState Identity (Type, Type)
unaryArrow (TypeSubst -> Type -> Type
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta Type
ty)
where
unaryArrow :: Type -> StateT TcState Identity (Type, Type)
unaryArrow (TypeArrow ty1 :: Type
ty1 ty2 :: Type
ty2) = (Type, Type) -> StateT TcState Identity (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty1, Type
ty2)
unaryArrow (TypeVariable tv :: Int
tv) = do
Type
alpha <- StateT TcState Identity Type
freshTypeVar
Type
beta <- StateT TcState Identity Type
freshTypeVar
(TypeSubst -> TypeSubst) -> TCM ()
modifyTypeSubst ((TypeSubst -> TypeSubst) -> TCM ())
-> (TypeSubst -> TypeSubst) -> TCM ()
forall a b. (a -> b) -> a -> b
$ Int -> Type -> TypeSubst -> TypeSubst
bindVar Int
tv (Type -> TypeSubst -> TypeSubst) -> Type -> TypeSubst -> TypeSubst
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
TypeArrow Type
alpha Type
beta
(Type, Type) -> StateT TcState Identity (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
alpha, Type
beta)
unaryArrow ty' :: Type
ty' = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
Message -> TCM ()
report (Message -> TCM ()) -> Message -> TCM ()
forall a b. (a -> b) -> a -> b
$ p -> String -> Doc -> ModuleIdent -> Type -> Message
forall a.
HasSpanInfo a =>
a -> String -> Doc -> ModuleIdent -> Type -> Message
errNonFunctionType p
p String
what Doc
doc ModuleIdent
m Type
ty'
(,) (Type -> Type -> (Type, Type))
-> StateT TcState Identity Type
-> StateT TcState Identity (Type -> (Type, Type))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT TcState Identity Type
freshTypeVar StateT TcState Identity (Type -> (Type, Type))
-> StateT TcState Identity Type
-> StateT TcState Identity (Type, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT TcState Identity Type
freshTypeVar
tcBinary :: HasSpanInfo p => p -> String -> Doc -> Type
-> TCM (Type, Type, Type)
tcBinary :: p -> String -> Doc -> Type -> TCM (Type, Type, Type)
tcBinary p :: p
p what :: String
what doc :: Doc
doc ty :: Type
ty = p -> String -> Doc -> Type -> StateT TcState Identity (Type, Type)
forall p.
HasSpanInfo p =>
p -> String -> Doc -> Type -> StateT TcState Identity (Type, Type)
tcArrow p
p String
what Doc
doc Type
ty StateT TcState Identity (Type, Type)
-> ((Type, Type) -> TCM (Type, Type, Type))
-> TCM (Type, Type, Type)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Type -> Type -> TCM (Type, Type, Type))
-> (Type, Type) -> TCM (Type, Type, Type)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Type -> Type -> TCM (Type, Type, Type)
binaryArrow
where
binaryArrow :: Type -> Type -> TCM (Type, Type, Type)
binaryArrow ty1 :: Type
ty1 (TypeArrow ty2 :: Type
ty2 ty3 :: Type
ty3) = (Type, Type, Type) -> TCM (Type, Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty1, Type
ty2, Type
ty3)
binaryArrow ty1 :: Type
ty1 (TypeVariable tv :: Int
tv) = do
Type
beta <- StateT TcState Identity Type
freshTypeVar
Type
gamma <- StateT TcState Identity Type
freshTypeVar
(TypeSubst -> TypeSubst) -> TCM ()
modifyTypeSubst ((TypeSubst -> TypeSubst) -> TCM ())
-> (TypeSubst -> TypeSubst) -> TCM ()
forall a b. (a -> b) -> a -> b
$ Int -> Type -> TypeSubst -> TypeSubst
bindVar Int
tv (Type -> TypeSubst -> TypeSubst) -> Type -> TypeSubst -> TypeSubst
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
TypeArrow Type
beta Type
gamma
(Type, Type, Type) -> TCM (Type, Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty1, Type
beta, Type
gamma)
binaryArrow ty1 :: Type
ty1 ty2 :: Type
ty2 = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
Message -> TCM ()
report (Message -> TCM ()) -> Message -> TCM ()
forall a b. (a -> b) -> a -> b
$ p -> String -> Doc -> ModuleIdent -> Type -> Message
forall a.
HasSpanInfo a =>
a -> String -> Doc -> ModuleIdent -> Type -> Message
errNonBinaryOp p
p String
what Doc
doc ModuleIdent
m (Type -> Type -> Type
TypeArrow Type
ty1 Type
ty2)
(,,) (Type -> Type -> Type -> (Type, Type, Type))
-> StateT TcState Identity Type
-> StateT TcState Identity (Type -> Type -> (Type, Type, Type))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> StateT TcState Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty1 StateT TcState Identity (Type -> Type -> (Type, Type, Type))
-> StateT TcState Identity Type
-> StateT TcState Identity (Type -> (Type, Type, Type))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT TcState Identity Type
freshTypeVar StateT TcState Identity (Type -> (Type, Type, Type))
-> StateT TcState Identity Type -> TCM (Type, Type, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT TcState Identity Type
freshTypeVar
unify :: HasSpanInfo p => p -> String -> Doc -> PredSet -> Type -> PredSet
-> Type -> TCM PredSet
unify :: p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> TCM PredSet
unify p :: p
p what :: String
what doc :: Doc
doc ps1 :: PredSet
ps1 ty1 :: Type
ty1 ps2 :: PredSet
ps2 ty2 :: Type
ty2 = do
TypeSubst
theta <- TCM TypeSubst
getTypeSubst
let ty1' :: Type
ty1' = TypeSubst -> Type -> Type
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta Type
ty1
ty2' :: Type
ty2' = TypeSubst -> Type -> Type
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta Type
ty2
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
case ModuleIdent -> Type -> Type -> Either Doc TypeSubst
unifyTypes ModuleIdent
m Type
ty1' Type
ty2' of
Left reason :: Doc
reason -> Message -> TCM ()
report (Message -> TCM ()) -> Message -> TCM ()
forall a b. (a -> b) -> a -> b
$ p -> String -> Doc -> ModuleIdent -> Type -> Type -> Doc -> Message
forall a.
HasSpanInfo a =>
a -> String -> Doc -> ModuleIdent -> Type -> Type -> Doc -> Message
errTypeMismatch p
p String
what Doc
doc ModuleIdent
m Type
ty1' Type
ty2' Doc
reason
Right sigma :: TypeSubst
sigma -> (TypeSubst -> TypeSubst) -> TCM ()
modifyTypeSubst (TypeSubst -> TypeSubst -> TypeSubst
forall v e. Ord v => Subst v e -> Subst v e -> Subst v e
compose TypeSubst
sigma)
p -> String -> Doc -> PredSet -> TCM PredSet
forall p.
HasSpanInfo p =>
p -> String -> Doc -> PredSet -> TCM PredSet
reducePredSet p
p String
what Doc
doc (PredSet -> TCM PredSet) -> PredSet -> TCM PredSet
forall a b. (a -> b) -> a -> b
$ PredSet
ps1 PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps2
unifyTypes :: ModuleIdent -> Type -> Type -> Either Doc TypeSubst
unifyTypes :: ModuleIdent -> Type -> Type -> Either Doc TypeSubst
unifyTypes _ (TypeVariable tv1 :: Int
tv1) (TypeVariable tv2 :: Int
tv2)
| Int
tv1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tv2 = TypeSubst -> Either Doc TypeSubst
forall a b. b -> Either a b
Right TypeSubst
forall a b. Subst a b
idSubst
| Bool
otherwise = TypeSubst -> Either Doc TypeSubst
forall a b. b -> Either a b
Right (Int -> Type -> TypeSubst
forall v e. Ord v => v -> e -> Subst v e
singleSubst Int
tv1 (Int -> Type
TypeVariable Int
tv2))
unifyTypes m :: ModuleIdent
m (TypeVariable tv :: Int
tv) ty :: Type
ty
| Int
tv Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Type -> [Int]
forall t. IsType t => t -> [Int]
typeVars Type
ty = Doc -> Either Doc TypeSubst
forall a b. a -> Either a b
Left (ModuleIdent -> Int -> Type -> Doc
errRecursiveType ModuleIdent
m Int
tv Type
ty)
| Bool
otherwise = TypeSubst -> Either Doc TypeSubst
forall a b. b -> Either a b
Right (Int -> Type -> TypeSubst
forall v e. Ord v => v -> e -> Subst v e
singleSubst Int
tv Type
ty)
unifyTypes m :: ModuleIdent
m ty :: Type
ty (TypeVariable tv :: Int
tv)
| Int
tv Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Type -> [Int]
forall t. IsType t => t -> [Int]
typeVars Type
ty = Doc -> Either Doc TypeSubst
forall a b. a -> Either a b
Left (ModuleIdent -> Int -> Type -> Doc
errRecursiveType ModuleIdent
m Int
tv Type
ty)
| Bool
otherwise = TypeSubst -> Either Doc TypeSubst
forall a b. b -> Either a b
Right (Int -> Type -> TypeSubst
forall v e. Ord v => v -> e -> Subst v e
singleSubst Int
tv Type
ty)
unifyTypes _ (TypeConstrained tys1 :: [Type]
tys1 tv1 :: Int
tv1) (TypeConstrained tys2 :: [Type]
tys2 tv2 :: Int
tv2)
| Int
tv1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tv2 = TypeSubst -> Either Doc TypeSubst
forall a b. b -> Either a b
Right TypeSubst
forall a b. Subst a b
idSubst
| [Type]
tys1 [Type] -> [Type] -> Bool
forall a. Eq a => a -> a -> Bool
== [Type]
tys2 = TypeSubst -> Either Doc TypeSubst
forall a b. b -> Either a b
Right (Int -> Type -> TypeSubst
forall v e. Ord v => v -> e -> Subst v e
singleSubst Int
tv1 ([Type] -> Int -> Type
TypeConstrained [Type]
tys2 Int
tv2))
unifyTypes m :: ModuleIdent
m (TypeConstrained tys :: [Type]
tys tv :: Int
tv) ty :: Type
ty =
(Type -> Either Doc TypeSubst -> Either Doc TypeSubst)
-> Either Doc TypeSubst -> [Type] -> Either Doc TypeSubst
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Either Doc TypeSubst
-> Either Doc TypeSubst -> Either Doc TypeSubst
forall a a.
Either a TypeSubst -> Either a TypeSubst -> Either a TypeSubst
choose (Either Doc TypeSubst
-> Either Doc TypeSubst -> Either Doc TypeSubst)
-> (Type -> Either Doc TypeSubst)
-> Type
-> Either Doc TypeSubst
-> Either Doc TypeSubst
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent -> Type -> Type -> Either Doc TypeSubst
unifyTypes ModuleIdent
m Type
ty) (Doc -> Either Doc TypeSubst
forall a b. a -> Either a b
Left (ModuleIdent -> Type -> Type -> Doc
errIncompatibleTypes ModuleIdent
m Type
ty ([Type] -> Type
forall a. [a] -> a
head [Type]
tys)))
[Type]
tys
where choose :: Either a TypeSubst -> Either a TypeSubst -> Either a TypeSubst
choose (Left _) theta' :: Either a TypeSubst
theta' = Either a TypeSubst
theta'
choose (Right theta :: TypeSubst
theta) _ = TypeSubst -> Either a TypeSubst
forall a b. b -> Either a b
Right (Int -> Type -> TypeSubst -> TypeSubst
forall v e. Ord v => v -> e -> Subst v e -> Subst v e
bindSubst Int
tv Type
ty TypeSubst
theta)
unifyTypes m :: ModuleIdent
m ty :: Type
ty (TypeConstrained tys :: [Type]
tys tv :: Int
tv) =
(Type -> Either Doc TypeSubst -> Either Doc TypeSubst)
-> Either Doc TypeSubst -> [Type] -> Either Doc TypeSubst
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Either Doc TypeSubst
-> Either Doc TypeSubst -> Either Doc TypeSubst
forall a a.
Either a TypeSubst -> Either a TypeSubst -> Either a TypeSubst
choose (Either Doc TypeSubst
-> Either Doc TypeSubst -> Either Doc TypeSubst)
-> (Type -> Either Doc TypeSubst)
-> Type
-> Either Doc TypeSubst
-> Either Doc TypeSubst
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent -> Type -> Type -> Either Doc TypeSubst
unifyTypes ModuleIdent
m Type
ty) (Doc -> Either Doc TypeSubst
forall a b. a -> Either a b
Left (ModuleIdent -> Type -> Type -> Doc
errIncompatibleTypes ModuleIdent
m Type
ty ([Type] -> Type
forall a. [a] -> a
head [Type]
tys)))
[Type]
tys
where choose :: Either a TypeSubst -> Either a TypeSubst -> Either a TypeSubst
choose (Left _) theta' :: Either a TypeSubst
theta' = Either a TypeSubst
theta'
choose (Right theta :: TypeSubst
theta) _ = TypeSubst -> Either a TypeSubst
forall a b. b -> Either a b
Right (Int -> Type -> TypeSubst -> TypeSubst
forall v e. Ord v => v -> e -> Subst v e -> Subst v e
bindSubst Int
tv Type
ty TypeSubst
theta)
unifyTypes _ (TypeConstructor tc1 :: QualIdent
tc1) (TypeConstructor tc2 :: QualIdent
tc2)
| QualIdent
tc1 QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
tc2 = TypeSubst -> Either Doc TypeSubst
forall a b. b -> Either a b
Right TypeSubst
forall a b. Subst a b
idSubst
unifyTypes m :: ModuleIdent
m (TypeApply ty11 :: Type
ty11 ty12 :: Type
ty12) (TypeApply ty21 :: Type
ty21 ty22 :: Type
ty22) =
ModuleIdent -> [Type] -> [Type] -> Either Doc TypeSubst
unifyTypeLists ModuleIdent
m [Type
ty11, Type
ty12] [Type
ty21, Type
ty22]
unifyTypes m :: ModuleIdent
m ty1 :: Type
ty1@(TypeApply _ _) (TypeArrow ty21 :: Type
ty21 ty22 :: Type
ty22) =
ModuleIdent -> Type -> Type -> Either Doc TypeSubst
unifyTypes ModuleIdent
m Type
ty1 (Type -> Type -> Type
TypeApply (Type -> Type -> Type
TypeApply (QualIdent -> Type
TypeConstructor QualIdent
qArrowId) Type
ty21) Type
ty22)
unifyTypes m :: ModuleIdent
m (TypeArrow ty11 :: Type
ty11 ty12 :: Type
ty12) ty2 :: Type
ty2@(TypeApply _ _) =
ModuleIdent -> Type -> Type -> Either Doc TypeSubst
unifyTypes ModuleIdent
m (Type -> Type -> Type
TypeApply (Type -> Type -> Type
TypeApply (QualIdent -> Type
TypeConstructor QualIdent
qArrowId) Type
ty11) Type
ty12) Type
ty2
unifyTypes m :: ModuleIdent
m (TypeArrow ty11 :: Type
ty11 ty12 :: Type
ty12) (TypeArrow ty21 :: Type
ty21 ty22 :: Type
ty22) =
ModuleIdent -> [Type] -> [Type] -> Either Doc TypeSubst
unifyTypeLists ModuleIdent
m [Type
ty11, Type
ty12] [Type
ty21, Type
ty22]
unifyTypes m :: ModuleIdent
m ty1 :: Type
ty1 ty2 :: Type
ty2 = Doc -> Either Doc TypeSubst
forall a b. a -> Either a b
Left (ModuleIdent -> Type -> Type -> Doc
errIncompatibleTypes ModuleIdent
m Type
ty1 Type
ty2)
unifyTypeLists :: ModuleIdent -> [Type] -> [Type] -> Either Doc TypeSubst
unifyTypeLists :: ModuleIdent -> [Type] -> [Type] -> Either Doc TypeSubst
unifyTypeLists _ [] _ = TypeSubst -> Either Doc TypeSubst
forall a b. b -> Either a b
Right TypeSubst
forall a b. Subst a b
idSubst
unifyTypeLists _ _ [] = TypeSubst -> Either Doc TypeSubst
forall a b. b -> Either a b
Right TypeSubst
forall a b. Subst a b
idSubst
unifyTypeLists m :: ModuleIdent
m (ty1 :: Type
ty1 : tys1 :: [Type]
tys1) (ty2 :: Type
ty2 : tys2 :: [Type]
tys2) =
(Doc -> Either Doc TypeSubst)
-> (TypeSubst -> Either Doc TypeSubst)
-> Either Doc TypeSubst
-> Either Doc TypeSubst
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Doc -> Either Doc TypeSubst
forall a b. a -> Either a b
Left TypeSubst -> Either Doc TypeSubst
unifyTypesTheta (ModuleIdent -> [Type] -> [Type] -> Either Doc TypeSubst
unifyTypeLists ModuleIdent
m [Type]
tys1 [Type]
tys2)
where
unifyTypesTheta :: TypeSubst -> Either Doc TypeSubst
unifyTypesTheta theta :: TypeSubst
theta =
(Doc -> Either Doc TypeSubst)
-> (TypeSubst -> Either Doc TypeSubst)
-> Either Doc TypeSubst
-> Either Doc TypeSubst
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Doc -> Either Doc TypeSubst
forall a b. a -> Either a b
Left (TypeSubst -> Either Doc TypeSubst
forall a b. b -> Either a b
Right (TypeSubst -> Either Doc TypeSubst)
-> (TypeSubst -> TypeSubst) -> TypeSubst -> Either Doc TypeSubst
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeSubst -> TypeSubst -> TypeSubst)
-> TypeSubst -> TypeSubst -> TypeSubst
forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeSubst -> TypeSubst -> TypeSubst
forall v e. Ord v => Subst v e -> Subst v e -> Subst v e
compose TypeSubst
theta)
(ModuleIdent -> Type -> Type -> Either Doc TypeSubst
unifyTypes ModuleIdent
m (TypeSubst -> Type -> Type
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta Type
ty1) (TypeSubst -> Type -> Type
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta Type
ty2))
reducePredSet :: HasSpanInfo p => p -> String -> Doc -> PredSet -> TCM PredSet
reducePredSet :: p -> String -> Doc -> PredSet -> TCM PredSet
reducePredSet p :: p
p what :: String
what doc :: Doc
doc ps :: PredSet
ps = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
ClassEnv
clsEnv <- TCM ClassEnv
getClassEnv
TypeSubst
theta <- TCM TypeSubst
getTypeSubst
InstEnv'
inEnv <- (Map QualIdent [Type] -> Map QualIdent [Type])
-> InstEnv' -> InstEnv'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Type] -> [Type]) -> Map QualIdent [Type] -> Map QualIdent [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TypeSubst -> [Type] -> [Type]
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta)) (InstEnv' -> InstEnv') -> TCM InstEnv' -> TCM InstEnv'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCM InstEnv'
getInstEnv
let ps' :: PredSet
ps' = TypeSubst -> PredSet -> PredSet
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta PredSet
ps
(ps1 :: PredSet
ps1, ps2 :: PredSet
ps2) = PredSet -> (PredSet, PredSet)
partitionPredSet (PredSet -> (PredSet, PredSet)) -> PredSet -> (PredSet, PredSet)
forall a b. (a -> b) -> a -> b
$ ClassEnv -> PredSet -> PredSet
minPredSet ClassEnv
clsEnv (PredSet -> PredSet) -> PredSet -> PredSet
forall a b. (a -> b) -> a -> b
$ InstEnv' -> PredSet -> PredSet
reducePreds InstEnv'
inEnv PredSet
ps'
TypeSubst
theta' <-
(TypeSubst -> Pred -> TCM TypeSubst)
-> TypeSubst -> [Pred] -> TCM TypeSubst
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (ModuleIdent
-> p
-> String
-> Doc
-> InstEnv'
-> TypeSubst
-> Pred
-> TCM TypeSubst
forall p.
HasSpanInfo p =>
ModuleIdent
-> p
-> String
-> Doc
-> InstEnv'
-> TypeSubst
-> Pred
-> TCM TypeSubst
reportMissingInstance ModuleIdent
m p
p String
what Doc
doc InstEnv'
inEnv) TypeSubst
forall a b. Subst a b
idSubst ([Pred] -> TCM TypeSubst) -> [Pred] -> TCM TypeSubst
forall a b. (a -> b) -> a -> b
$ PredSet -> [Pred]
forall a. Set a -> [a]
Set.toList PredSet
ps2
(TypeSubst -> TypeSubst) -> TCM ()
modifyTypeSubst ((TypeSubst -> TypeSubst) -> TCM ())
-> (TypeSubst -> TypeSubst) -> TCM ()
forall a b. (a -> b) -> a -> b
$ TypeSubst -> TypeSubst -> TypeSubst
forall v e. Ord v => Subst v e -> Subst v e -> Subst v e
compose TypeSubst
theta'
PredSet -> TCM PredSet
forall (m :: * -> *) a. Monad m => a -> m a
return PredSet
ps1
where
reducePreds :: InstEnv' -> PredSet -> PredSet
reducePreds inEnv :: InstEnv'
inEnv = (Pred -> PredSet) -> PredSet -> PredSet
forall a b. (Ord a, Ord b) => (a -> Set b) -> Set a -> Set b
Set.concatMap ((Pred -> PredSet) -> PredSet -> PredSet)
-> (Pred -> PredSet) -> PredSet -> PredSet
forall a b. (a -> b) -> a -> b
$ InstEnv' -> Pred -> PredSet
reducePred InstEnv'
inEnv
reducePred :: InstEnv' -> Pred -> PredSet
reducePred inEnv :: InstEnv'
inEnv pr :: Pred
pr@(Pred qcls :: QualIdent
qcls ty :: Type
ty) =
PredSet -> (PredSet -> PredSet) -> Maybe PredSet -> PredSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Pred -> PredSet
forall a. a -> Set a
Set.singleton Pred
pr) (InstEnv' -> PredSet -> PredSet
reducePreds InstEnv'
inEnv) (InstEnv' -> QualIdent -> Type -> Maybe PredSet
instPredSet InstEnv'
inEnv QualIdent
qcls Type
ty)
instPredSet :: InstEnv' -> QualIdent -> Type -> Maybe PredSet
instPredSet :: InstEnv' -> QualIdent -> Type -> Maybe PredSet
instPredSet inEnv :: InstEnv'
inEnv qcls :: QualIdent
qcls ty :: Type
ty = case QualIdent -> Map QualIdent [Type] -> Maybe [Type]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QualIdent
qcls (Map QualIdent [Type] -> Maybe [Type])
-> Map QualIdent [Type] -> Maybe [Type]
forall a b. (a -> b) -> a -> b
$ InstEnv' -> Map QualIdent [Type]
forall a b. (a, b) -> b
snd InstEnv'
inEnv of
Just tys :: [Type]
tys | Type
ty Type -> [Type] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Type]
tys -> PredSet -> Maybe PredSet
forall a. a -> Maybe a
Just PredSet
emptyPredSet
_ -> case Bool -> Type -> (Type, [Type])
unapplyType Bool
False Type
ty of
(TypeConstructor tc :: QualIdent
tc, tys :: [Type]
tys) ->
((ModuleIdent, PredSet, [(Ident, Int)]) -> PredSet)
-> Maybe (ModuleIdent, PredSet, [(Ident, Int)]) -> Maybe PredSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Type] -> PredSet -> PredSet
forall a. ExpandAliasType a => [Type] -> a -> a
expandAliasType [Type]
tys (PredSet -> PredSet)
-> ((ModuleIdent, PredSet, [(Ident, Int)]) -> PredSet)
-> (ModuleIdent, PredSet, [(Ident, Int)])
-> PredSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleIdent, PredSet, [(Ident, Int)]) -> PredSet
forall a b c. (a, b, c) -> b
snd3) (InstIdent
-> InstEnv -> Maybe (ModuleIdent, PredSet, [(Ident, Int)])
lookupInstInfo (QualIdent
qcls, QualIdent
tc) (InstEnv -> Maybe (ModuleIdent, PredSet, [(Ident, Int)]))
-> InstEnv -> Maybe (ModuleIdent, PredSet, [(Ident, Int)])
forall a b. (a -> b) -> a -> b
$ InstEnv' -> InstEnv
forall a b. (a, b) -> a
fst InstEnv'
inEnv)
_ -> Maybe PredSet
forall a. Maybe a
Nothing
reportMissingInstance :: HasSpanInfo p => ModuleIdent -> p -> String -> Doc
-> InstEnv' -> TypeSubst -> Pred -> TCM TypeSubst
reportMissingInstance :: ModuleIdent
-> p
-> String
-> Doc
-> InstEnv'
-> TypeSubst
-> Pred
-> TCM TypeSubst
reportMissingInstance m :: ModuleIdent
m p :: p
p what :: String
what doc :: Doc
doc inEnv :: InstEnv'
inEnv theta :: TypeSubst
theta (Pred qcls :: QualIdent
qcls ty :: Type
ty) =
case TypeSubst -> Type -> Type
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta Type
ty of
ty' :: Type
ty'@(TypeConstrained tys :: [Type]
tys tv :: Int
tv) ->
case (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter (InstEnv' -> QualIdent -> Type -> Bool
hasInstance InstEnv'
inEnv QualIdent
qcls) [Type]
tys of
[] -> do
Message -> TCM ()
report (Message -> TCM ()) -> Message -> TCM ()
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> p -> String -> Doc -> Pred -> Message
forall a.
HasSpanInfo a =>
ModuleIdent -> a -> String -> Doc -> Pred -> Message
errMissingInstance ModuleIdent
m p
p String
what Doc
doc (QualIdent -> Type -> Pred
Pred QualIdent
qcls Type
ty')
TypeSubst -> TCM TypeSubst
forall (m :: * -> *) a. Monad m => a -> m a
return TypeSubst
theta
[ty'' :: Type
ty''] -> TypeSubst -> TCM TypeSubst
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Type -> TypeSubst -> TypeSubst
forall v e. Ord v => v -> e -> Subst v e -> Subst v e
bindSubst Int
tv Type
ty'' TypeSubst
theta)
tys' :: [Type]
tys'
| [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys' -> TypeSubst -> TCM TypeSubst
forall (m :: * -> *) a. Monad m => a -> m a
return TypeSubst
theta
| Bool
otherwise ->
(Type -> TypeSubst)
-> StateT TcState Identity Type -> TCM TypeSubst
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Type -> TypeSubst -> TypeSubst) -> TypeSubst -> Type -> TypeSubst
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> Type -> TypeSubst -> TypeSubst
forall v e. Ord v => v -> e -> Subst v e -> Subst v e
bindSubst Int
tv) TypeSubst
theta) ([Type] -> StateT TcState Identity Type
freshConstrained [Type]
tys')
ty' :: Type
ty'
| InstEnv' -> QualIdent -> Type -> Bool
hasInstance InstEnv'
inEnv QualIdent
qcls Type
ty' -> TypeSubst -> TCM TypeSubst
forall (m :: * -> *) a. Monad m => a -> m a
return TypeSubst
theta
| Bool
otherwise -> do
Message -> TCM ()
report (Message -> TCM ()) -> Message -> TCM ()
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> p -> String -> Doc -> Pred -> Message
forall a.
HasSpanInfo a =>
ModuleIdent -> a -> String -> Doc -> Pred -> Message
errMissingInstance ModuleIdent
m p
p String
what Doc
doc (QualIdent -> Type -> Pred
Pred QualIdent
qcls Type
ty')
TypeSubst -> TCM TypeSubst
forall (m :: * -> *) a. Monad m => a -> m a
return TypeSubst
theta
hasInstance :: InstEnv' -> QualIdent -> Type -> Bool
hasInstance :: InstEnv' -> QualIdent -> Type -> Bool
hasInstance inEnv :: InstEnv'
inEnv qcls :: QualIdent
qcls = Maybe PredSet -> Bool
forall a. Maybe a -> Bool
isJust (Maybe PredSet -> Bool) -> (Type -> Maybe PredSet) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstEnv' -> QualIdent -> Type -> Maybe PredSet
instPredSet InstEnv'
inEnv QualIdent
qcls
applyDefaults :: HasSpanInfo p => p -> String -> Doc -> Set.Set Int -> PredSet
-> Type -> TCM PredSet
applyDefaults :: p -> String -> Doc -> Set Int -> PredSet -> Type -> TCM PredSet
applyDefaults p :: p
p what :: String
what doc :: Doc
doc fvs :: Set Int
fvs ps :: PredSet
ps ty :: Type
ty = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
ClassEnv
clsEnv <- TCM ClassEnv
getClassEnv
InstEnv'
inEnv <- TCM InstEnv'
getInstEnv
[Type]
defs <- TCM [Type]
getDefaultTypes
let theta :: TypeSubst
theta = (Int -> TypeSubst -> TypeSubst) -> TypeSubst -> [Int] -> TypeSubst
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Type] -> InstEnv' -> PredSet -> Int -> TypeSubst -> TypeSubst
bindDefault [Type]
defs InstEnv'
inEnv PredSet
ps) TypeSubst
forall a b. Subst a b
idSubst ([Int] -> TypeSubst) -> [Int] -> TypeSubst
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub
[ Int
tv | Pred qcls :: QualIdent
qcls (TypeVariable tv :: Int
tv) <- PredSet -> [Pred]
forall a. Set a -> [a]
Set.toList PredSet
ps
, Int
tv Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Int
fvs, ClassEnv -> QualIdent -> Bool
isNumClass ClassEnv
clsEnv QualIdent
qcls ]
ps' :: PredSet
ps' = (PredSet, PredSet) -> PredSet
forall a b. (a, b) -> a
fst (PredSet -> (PredSet, PredSet)
partitionPredSet (TypeSubst -> PredSet -> PredSet
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta PredSet
ps))
ty' :: Type
ty' = TypeSubst -> Type -> Type
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta Type
ty
tvs' :: [Int]
tvs' = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Int
fvs) (PredSet -> [Int]
forall t. IsType t => t -> [Int]
typeVars PredSet
ps')
(Int -> TCM ()) -> [Int] -> TCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Message -> TCM ()
report (Message -> TCM ()) -> (Int -> Message) -> Int -> TCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent
-> p -> String -> Doc -> PredSet -> Type -> Int -> Message
forall a.
HasSpanInfo a =>
ModuleIdent
-> a -> String -> Doc -> PredSet -> Type -> Int -> Message
errAmbiguousTypeVariable ModuleIdent
m p
p String
what Doc
doc PredSet
ps' Type
ty') [Int]
tvs'
(TypeSubst -> TypeSubst) -> TCM ()
modifyTypeSubst ((TypeSubst -> TypeSubst) -> TCM ())
-> (TypeSubst -> TypeSubst) -> TCM ()
forall a b. (a -> b) -> a -> b
$ TypeSubst -> TypeSubst -> TypeSubst
forall v e. Ord v => Subst v e -> Subst v e -> Subst v e
compose TypeSubst
theta
PredSet -> TCM PredSet
forall (m :: * -> *) a. Monad m => a -> m a
return PredSet
ps'
bindDefault :: [Type] -> InstEnv' -> PredSet -> Int -> TypeSubst -> TypeSubst
bindDefault :: [Type] -> InstEnv' -> PredSet -> Int -> TypeSubst -> TypeSubst
bindDefault defs :: [Type]
defs inEnv :: InstEnv'
inEnv ps :: PredSet
ps tv :: Int
tv =
case (Pred -> [Type] -> [Type]) -> [Type] -> [Pred] -> [Type]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (InstEnv' -> Int -> Pred -> [Type] -> [Type]
defaultType InstEnv'
inEnv Int
tv) [Type]
defs (PredSet -> [Pred]
forall a. Set a -> [a]
Set.toList PredSet
ps) of
[] -> TypeSubst -> TypeSubst
forall a. a -> a
id
ty :: Type
ty:_ -> Int -> Type -> TypeSubst -> TypeSubst
forall v e. Ord v => v -> e -> Subst v e -> Subst v e
bindSubst Int
tv Type
ty
defaultType :: InstEnv' -> Int -> Pred -> [Type] -> [Type]
defaultType :: InstEnv' -> Int -> Pred -> [Type] -> [Type]
defaultType inEnv :: InstEnv'
inEnv tv :: Int
tv (Pred qcls :: QualIdent
qcls (TypeVariable tv' :: Int
tv'))
| Int
tv Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tv' = (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter (InstEnv' -> QualIdent -> Type -> Bool
hasInstance InstEnv'
inEnv QualIdent
qcls)
| Bool
otherwise = [Type] -> [Type]
forall a. a -> a
id
defaultType _ _ _ = [Type] -> [Type]
forall a. a -> a
id
isNumClass :: ClassEnv -> QualIdent -> Bool
isNumClass :: ClassEnv -> QualIdent -> Bool
isNumClass = (QualIdent -> [QualIdent] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem QualIdent
qNumId ([QualIdent] -> Bool)
-> (QualIdent -> [QualIdent]) -> QualIdent -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((QualIdent -> [QualIdent]) -> QualIdent -> Bool)
-> (ClassEnv -> QualIdent -> [QualIdent])
-> ClassEnv
-> QualIdent
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QualIdent -> ClassEnv -> [QualIdent])
-> ClassEnv -> QualIdent -> [QualIdent]
forall a b c. (a -> b -> c) -> b -> a -> c
flip QualIdent -> ClassEnv -> [QualIdent]
allSuperClasses
fresh :: (Int -> a) -> TCM a
fresh :: (Int -> a) -> TCM a
fresh f :: Int -> a
f = Int -> a
f (Int -> a) -> TCM Int -> TCM a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCM Int
getNextId
freshVar :: (Int -> a) -> TCM a
freshVar :: (Int -> a) -> TCM a
freshVar f :: Int -> a
f = (Int -> a) -> TCM a
forall a. (Int -> a) -> TCM a
fresh ((Int -> a) -> TCM a) -> (Int -> a) -> TCM a
forall a b. (a -> b) -> a -> b
$ \n :: Int
n -> Int -> a
f (- Int
n)
freshTypeVar :: TCM Type
freshTypeVar :: StateT TcState Identity Type
freshTypeVar = (Int -> Type) -> StateT TcState Identity Type
forall a. (Int -> a) -> TCM a
freshVar Int -> Type
TypeVariable
freshPredType :: [QualIdent] -> TCM (PredSet, Type)
freshPredType :: [QualIdent] -> StateT TcState Identity (PredSet, Type)
freshPredType qclss :: [QualIdent]
qclss = do
Type
ty <- StateT TcState Identity Type
freshTypeVar
(PredSet, Type) -> StateT TcState Identity (PredSet, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ((QualIdent -> PredSet -> PredSet)
-> PredSet -> [QualIdent] -> PredSet
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\qcls :: QualIdent
qcls -> Pred -> PredSet -> PredSet
forall a. Ord a => a -> Set a -> Set a
Set.insert (Pred -> PredSet -> PredSet) -> Pred -> PredSet -> PredSet
forall a b. (a -> b) -> a -> b
$ QualIdent -> Type -> Pred
Pred QualIdent
qcls Type
ty) PredSet
emptyPredSet [QualIdent]
qclss, Type
ty)
freshEnumType :: TCM (PredSet, Type)
freshEnumType :: StateT TcState Identity (PredSet, Type)
freshEnumType = [QualIdent] -> StateT TcState Identity (PredSet, Type)
freshPredType [QualIdent
qEnumId]
freshNumType :: TCM (PredSet, Type)
freshNumType :: StateT TcState Identity (PredSet, Type)
freshNumType = [QualIdent] -> StateT TcState Identity (PredSet, Type)
freshPredType [QualIdent
qNumId]
freshFractionalType :: TCM (PredSet, Type)
freshFractionalType :: StateT TcState Identity (PredSet, Type)
freshFractionalType = [QualIdent] -> StateT TcState Identity (PredSet, Type)
freshPredType [QualIdent
qFractionalId]
freshMonadType :: TCM (PredSet, Type)
freshMonadType :: StateT TcState Identity (PredSet, Type)
freshMonadType = [QualIdent] -> StateT TcState Identity (PredSet, Type)
freshPredType [QualIdent
qMonadId]
freshMonadFailType :: TCM (PredSet, Type)
freshMonadFailType :: StateT TcState Identity (PredSet, Type)
freshMonadFailType = [QualIdent] -> StateT TcState Identity (PredSet, Type)
freshPredType [QualIdent
qMonadFailId]
freshDataType :: TCM (PredSet, Type)
freshDataType :: StateT TcState Identity (PredSet, Type)
freshDataType = [QualIdent] -> StateT TcState Identity (PredSet, Type)
freshPredType [QualIdent
qDataId]
freshConstrained :: [Type] -> TCM Type
freshConstrained :: [Type] -> StateT TcState Identity Type
freshConstrained = (Int -> Type) -> StateT TcState Identity Type
forall a. (Int -> a) -> TCM a
freshVar ((Int -> Type) -> StateT TcState Identity Type)
-> ([Type] -> Int -> Type)
-> [Type]
-> StateT TcState Identity Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> Int -> Type
TypeConstrained
inst :: TypeScheme -> TCM (PredSet, Type)
inst :: TypeScheme -> StateT TcState Identity (PredSet, Type)
inst (ForAll n :: Int
n (PredType ps :: PredSet
ps ty :: Type
ty)) = do
[Type]
tys <- Int -> StateT TcState Identity Type -> TCM [Type]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n StateT TcState Identity Type
freshTypeVar
(PredSet, Type) -> StateT TcState Identity (PredSet, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> PredSet -> PredSet
forall a. ExpandAliasType a => [Type] -> a -> a
expandAliasType [Type]
tys PredSet
ps, [Type] -> Type -> Type
forall a. ExpandAliasType a => [Type] -> a -> a
expandAliasType [Type]
tys Type
ty)
skol :: TypeScheme -> TCM (PredSet, Type)
skol :: TypeScheme -> StateT TcState Identity (PredSet, Type)
skol (ForAll n :: Int
n (PredType ps :: PredSet
ps ty :: Type
ty)) = do
[Type]
tys <- Int -> StateT TcState Identity Type -> TCM [Type]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n StateT TcState Identity Type
freshTypeVar
ClassEnv
clsEnv <- TCM ClassEnv
getClassEnv
(InstEnv' -> InstEnv') -> TCM ()
modifyInstEnv ((InstEnv' -> InstEnv') -> TCM ())
-> (InstEnv' -> InstEnv') -> TCM ()
forall a b. (a -> b) -> a -> b
$
(Map QualIdent [Type] -> Map QualIdent [Type])
-> InstEnv' -> InstEnv'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Map QualIdent [Type] -> Map QualIdent [Type])
-> InstEnv' -> InstEnv')
-> (Map QualIdent [Type] -> Map QualIdent [Type])
-> InstEnv'
-> InstEnv'
forall a b. (a -> b) -> a -> b
$ PredSet -> Map QualIdent [Type] -> Map QualIdent [Type]
bindSkolemInsts (PredSet -> Map QualIdent [Type] -> Map QualIdent [Type])
-> PredSet -> Map QualIdent [Type] -> Map QualIdent [Type]
forall a b. (a -> b) -> a -> b
$ [Type] -> PredSet -> PredSet
forall a. ExpandAliasType a => [Type] -> a -> a
expandAliasType [Type]
tys (PredSet -> PredSet) -> PredSet -> PredSet
forall a b. (a -> b) -> a -> b
$ ClassEnv -> PredSet -> PredSet
maxPredSet ClassEnv
clsEnv PredSet
ps
(PredSet, Type) -> StateT TcState Identity (PredSet, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
emptyPredSet, [Type] -> Type -> Type
forall a. ExpandAliasType a => [Type] -> a -> a
expandAliasType [Type]
tys Type
ty)
where bindSkolemInsts :: PredSet -> Map QualIdent [Type] -> Map QualIdent [Type]
bindSkolemInsts = (Map QualIdent [Type] -> [Pred] -> Map QualIdent [Type])
-> [Pred] -> Map QualIdent [Type] -> Map QualIdent [Type]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Pred -> Map QualIdent [Type] -> Map QualIdent [Type])
-> Map QualIdent [Type] -> [Pred] -> Map QualIdent [Type]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Pred -> Map QualIdent [Type] -> Map QualIdent [Type]
bindSkolemInst) ([Pred] -> Map QualIdent [Type] -> Map QualIdent [Type])
-> (PredSet -> [Pred])
-> PredSet
-> Map QualIdent [Type]
-> Map QualIdent [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredSet -> [Pred]
forall a. Set a -> [a]
Set.toList
bindSkolemInst :: Pred -> Map QualIdent [Type] -> Map QualIdent [Type]
bindSkolemInst (Pred qcls :: QualIdent
qcls ty' :: Type
ty') dInEnv :: Map QualIdent [Type]
dInEnv =
QualIdent -> [Type] -> Map QualIdent [Type] -> Map QualIdent [Type]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert QualIdent
qcls (Type
ty' Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type] -> Maybe [Type] -> [Type]
forall a. a -> Maybe a -> a
fromMaybe [] (QualIdent -> Map QualIdent [Type] -> Maybe [Type]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QualIdent
qcls Map QualIdent [Type]
dInEnv)) Map QualIdent [Type]
dInEnv
gen :: Set.Set Int -> PredSet -> Type -> TypeScheme
gen :: Set Int -> PredSet -> Type -> TypeScheme
gen gvs :: Set Int
gvs ps :: PredSet
ps ty :: Type
ty = Int -> PredType -> TypeScheme
ForAll ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
tvs) (TypeSubst -> PredType -> PredType
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta (PredSet -> Type -> PredType
PredType PredSet
ps Type
ty))
where tvs :: [Int]
tvs = [Int
tv | Int
tv <- [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub (Type -> [Int]
forall t. IsType t => t -> [Int]
typeVars Type
ty), Int
tv Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Int
gvs]
tvs' :: [Type]
tvs' = (Int -> Type) -> [Int] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Type
TypeVariable [0 ..]
theta :: TypeSubst
theta = (Int -> Type -> TypeSubst -> TypeSubst)
-> TypeSubst -> [Int] -> [Type] -> TypeSubst
forall a b c. (a -> b -> c -> c) -> c -> [a] -> [b] -> c
foldr2 Int -> Type -> TypeSubst -> TypeSubst
forall v e. Ord v => v -> e -> Subst v e -> Subst v e
bindSubst TypeSubst
forall a b. Subst a b
idSubst [Int]
tvs [Type]
tvs'
constrType :: ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
constrType :: ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
constrType m :: ModuleIdent
m c :: QualIdent
c vEnv :: ValueEnv
vEnv = case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
c ValueEnv
vEnv of
[DataConstructor _ _ _ tySc :: TypeScheme
tySc] -> TypeScheme
tySc
[NewtypeConstructor _ _ tySc :: TypeScheme
tySc] -> TypeScheme
tySc
_ -> case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
c) ValueEnv
vEnv of
[DataConstructor _ _ _ tySc :: TypeScheme
tySc] -> TypeScheme
tySc
[NewtypeConstructor _ _ tySc :: TypeScheme
tySc] -> TypeScheme
tySc
_ -> String -> TypeScheme
forall a. String -> a
internalError (String -> TypeScheme) -> String -> TypeScheme
forall a b. (a -> b) -> a -> b
$ "TypeCheck.constrType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
c
constrLabels :: ModuleIdent -> QualIdent -> ValueEnv -> [Ident]
constrLabels :: ModuleIdent -> QualIdent -> ValueEnv -> [Ident]
constrLabels m :: ModuleIdent
m c :: QualIdent
c vEnv :: ValueEnv
vEnv = case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
c ValueEnv
vEnv of
[DataConstructor _ _ ls :: [Ident]
ls _] -> [Ident]
ls
[NewtypeConstructor _ l :: Ident
l _] -> [Ident
l]
_ -> case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
c) ValueEnv
vEnv of
[DataConstructor _ _ ls :: [Ident]
ls _] -> [Ident]
ls
[NewtypeConstructor _ l :: Ident
l _] -> [Ident
l]
_ -> String -> [Ident]
forall a. String -> a
internalError (String -> [Ident]) -> String -> [Ident]
forall a b. (a -> b) -> a -> b
$ "TypeCheck.constrLabels: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
c
varType :: Ident -> ValueEnv -> TypeScheme
varType :: Ident -> ValueEnv -> TypeScheme
varType v :: Ident
v vEnv :: ValueEnv
vEnv = case Ident -> ValueEnv -> [ValueInfo]
lookupValue Ident
v ValueEnv
vEnv of
Value _ _ _ tySc :: TypeScheme
tySc : _ -> TypeScheme
tySc
_ -> String -> TypeScheme
forall a. String -> a
internalError (String -> TypeScheme) -> String -> TypeScheme
forall a b. (a -> b) -> a -> b
$ "TypeCheck.varType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
forall a. Show a => a -> String
show Ident
v
varArity :: QualIdent -> ValueEnv -> Int
varArity :: QualIdent -> ValueEnv -> Int
varArity v :: QualIdent
v vEnv :: ValueEnv
vEnv = case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
v ValueEnv
vEnv of
Value _ _ n :: Int
n _ : _ -> Int
n
Label _ _ _ : _ -> 1
_ -> String -> Int
forall a. String -> a
internalError (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ "TypeCheck.varArity: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
v
funType :: ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
funType :: ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
funType m :: ModuleIdent
m f :: QualIdent
f vEnv :: ValueEnv
vEnv = case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
f ValueEnv
vEnv of
[Value _ _ _ tySc :: TypeScheme
tySc] -> TypeScheme
tySc
[Label _ _ tySc :: TypeScheme
tySc] -> TypeScheme
tySc
_ -> case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
f) ValueEnv
vEnv of
[Value _ _ _ tySc :: TypeScheme
tySc] -> TypeScheme
tySc
[Label _ _ tySc :: TypeScheme
tySc] -> TypeScheme
tySc
_ -> String -> TypeScheme
forall a. String -> a
internalError (String -> TypeScheme) -> String -> TypeScheme
forall a b. (a -> b) -> a -> b
$ "TypeCheck.funType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
f
labelType :: ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
labelType :: ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
labelType m :: ModuleIdent
m l :: QualIdent
l vEnv :: ValueEnv
vEnv = case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
l ValueEnv
vEnv of
[Label _ _ tySc :: TypeScheme
tySc] -> TypeScheme
tySc
_ -> case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
l) ValueEnv
vEnv of
[Label _ _ tySc :: TypeScheme
tySc] -> TypeScheme
tySc
_ -> String -> TypeScheme
forall a. String -> a
internalError (String -> TypeScheme) -> String -> TypeScheme
forall a b. (a -> b) -> a -> b
$ "TypeCheck.labelType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
l
expandPoly :: QualTypeExpr -> TCM PredType
expandPoly :: QualTypeExpr -> StateT TcState Identity PredType
expandPoly qty :: QualTypeExpr
qty = do
ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
TCEnv
tcEnv <- TCM TCEnv
getTyConsEnv
ClassEnv
clsEnv <- TCM ClassEnv
getClassEnv
PredType -> StateT TcState Identity PredType
forall (m :: * -> *) a. Monad m => a -> m a
return (PredType -> StateT TcState Identity PredType)
-> PredType -> StateT TcState Identity PredType
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> TCEnv -> ClassEnv -> QualTypeExpr -> PredType
expandPolyType ModuleIdent
m TCEnv
tcEnv ClassEnv
clsEnv QualTypeExpr
qty
splitPredSet :: Set.Set Int -> PredSet -> (PredSet, PredSet)
splitPredSet :: Set Int -> PredSet -> (PredSet, PredSet)
splitPredSet fvs :: Set Int
fvs = (Pred -> Bool) -> PredSet -> (PredSet, PredSet)
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
Set.partition ((Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
fvs) ([Int] -> Bool) -> (Pred -> [Int]) -> Pred -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pred -> [Int]
forall t. IsType t => t -> [Int]
typeVars)
fvEnv :: ValueEnv -> Set.Set Int
fvEnv :: ValueEnv -> Set Int
fvEnv vEnv :: ValueEnv
vEnv =
[Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [Int
tv | TypeScheme
tySc <- ValueEnv -> [TypeScheme]
localTypes ValueEnv
vEnv, Int
tv <- TypeScheme -> [Int]
forall t. IsType t => t -> [Int]
typeVars TypeScheme
tySc, Int
tv Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0]
computeFvEnv :: TCM (Set.Set Int)
computeFvEnv :: TCM (Set Int)
computeFvEnv = do
TypeSubst
theta <- TCM TypeSubst
getTypeSubst
ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
Set Int -> TCM (Set Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Int -> TCM (Set Int)) -> Set Int -> TCM (Set Int)
forall a b. (a -> b) -> a -> b
$ ValueEnv -> Set Int
fvEnv (TypeSubst -> ValueEnv -> ValueEnv
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta ValueEnv
vEnv)
localTypes :: ValueEnv -> [TypeScheme]
localTypes :: ValueEnv -> [TypeScheme]
localTypes vEnv :: ValueEnv
vEnv = [TypeScheme
tySc | (_, Value _ _ _ tySc :: TypeScheme
tySc) <- ValueEnv -> [(Ident, ValueInfo)]
forall a. TopEnv a -> [(Ident, a)]
localBindings ValueEnv
vEnv]
errPolymorphicVar :: Ident -> Message
errPolymorphicVar :: Ident -> Message
errPolymorphicVar v :: Ident
v = Ident -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage Ident
v (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
["Variable", Ident -> String
idName Ident
v, "has a polymorphic type"]
errTypeSigTooGeneral :: ModuleIdent -> Doc -> QualTypeExpr
-> TypeScheme -> Message
errTypeSigTooGeneral :: ModuleIdent -> Doc -> QualTypeExpr -> TypeScheme -> Message
errTypeSigTooGeneral m :: ModuleIdent
m what :: Doc
what qty :: QualTypeExpr
qty tySc :: TypeScheme
tySc = QualTypeExpr -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage QualTypeExpr
qty (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
[ String -> Doc
text "Type signature too general", Doc
what
, String -> Doc
text "Inferred type:" Doc -> Doc -> Doc
<+> ModuleIdent -> TypeScheme -> Doc
ppTypeScheme ModuleIdent
m TypeScheme
tySc
, String -> Doc
text "Type signature:" Doc -> Doc -> Doc
<+> QualTypeExpr -> Doc
forall a. Pretty a => a -> Doc
pPrint QualTypeExpr
qty
]
errMethodTypeTooSpecific :: HasSpanInfo a => a -> ModuleIdent -> Doc -> PredType
-> TypeScheme -> Message
errMethodTypeTooSpecific :: a -> ModuleIdent -> Doc -> PredType -> TypeScheme -> Message
errMethodTypeTooSpecific p :: a
p m :: ModuleIdent
m what :: Doc
what pty :: PredType
pty tySc :: TypeScheme
tySc = a -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage a
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
[ String -> Doc
text "Method type too specific", Doc
what
, String -> Doc
text "Inferred type:" Doc -> Doc -> Doc
<+> ModuleIdent -> TypeScheme -> Doc
ppTypeScheme ModuleIdent
m TypeScheme
tySc
, String -> Doc
text "Expected type:" Doc -> Doc -> Doc
<+> ModuleIdent -> PredType -> Doc
ppPredType ModuleIdent
m PredType
pty
]
errNonFunctionType :: HasSpanInfo a => a -> String -> Doc -> ModuleIdent -> Type
-> Message
errNonFunctionType :: a -> String -> Doc -> ModuleIdent -> Type -> Message
errNonFunctionType p :: a
p what :: String
what doc :: Doc
doc m :: ModuleIdent
m ty :: Type
ty = a -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage a
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
[ String -> Doc
text "Type error in" Doc -> Doc -> Doc
<+> String -> Doc
text String
what, Doc
doc
, String -> Doc
text "Type:" Doc -> Doc -> Doc
<+> ModuleIdent -> Type -> Doc
ppType ModuleIdent
m Type
ty
, String -> Doc
text "Cannot be applied"
]
errNonBinaryOp :: HasSpanInfo a => a -> String -> Doc -> ModuleIdent -> Type
-> Message
errNonBinaryOp :: a -> String -> Doc -> ModuleIdent -> Type -> Message
errNonBinaryOp p :: a
p what :: String
what doc :: Doc
doc m :: ModuleIdent
m ty :: Type
ty = a -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage a
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
[ String -> Doc
text "Type error in" Doc -> Doc -> Doc
<+> String -> Doc
text String
what, Doc
doc
, String -> Doc
text "Type:" Doc -> Doc -> Doc
<+> ModuleIdent -> Type -> Doc
ppType ModuleIdent
m Type
ty
, String -> Doc
text "Cannot be used as binary operator"
]
errTypeMismatch :: HasSpanInfo a => a -> String -> Doc -> ModuleIdent -> Type
-> Type -> Doc -> Message
errTypeMismatch :: a -> String -> Doc -> ModuleIdent -> Type -> Type -> Doc -> Message
errTypeMismatch p :: a
p what :: String
what doc :: Doc
doc m :: ModuleIdent
m ty1 :: Type
ty1 ty2 :: Type
ty2 reason :: Doc
reason = a -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage a
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
[ String -> Doc
text "Type error in" Doc -> Doc -> Doc
<+> String -> Doc
text String
what, Doc
doc
, String -> Doc
text "Inferred type:" Doc -> Doc -> Doc
<+> ModuleIdent -> Type -> Doc
ppType ModuleIdent
m Type
ty2
, String -> Doc
text "Expected type:" Doc -> Doc -> Doc
<+> ModuleIdent -> Type -> Doc
ppType ModuleIdent
m Type
ty1
, Doc
reason
]
errSkolemFieldLabel :: HasSpanInfo a => a -> Ident -> Message
errSkolemFieldLabel :: a -> Ident -> Message
errSkolemFieldLabel p :: a
p l :: Ident
l = a -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage a
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
["Existential type escapes with type of record selector", Ident -> String
escName Ident
l]
errRecursiveType :: ModuleIdent -> Int -> Type -> Doc
errRecursiveType :: ModuleIdent -> Int -> Type -> Doc
errRecursiveType m :: ModuleIdent
m tv :: Int
tv ty :: Type
ty = ModuleIdent -> Type -> Type -> Doc
errIncompatibleTypes ModuleIdent
m (Int -> Type
TypeVariable Int
tv) Type
ty
errIncompatibleTypes :: ModuleIdent -> Type -> Type -> Doc
errIncompatibleTypes :: ModuleIdent -> Type -> Type -> Doc
errIncompatibleTypes m :: ModuleIdent
m ty1 :: Type
ty1 ty2 :: Type
ty2 = [Doc] -> Doc
sep
[ String -> Doc
text "Types" Doc -> Doc -> Doc
<+> ModuleIdent -> Type -> Doc
ppType ModuleIdent
m Type
ty1
, Int -> Doc -> Doc
nest 2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "and" Doc -> Doc -> Doc
<+> ModuleIdent -> Type -> Doc
ppType ModuleIdent
m Type
ty2
, String -> Doc
text "are incompatible"
]
errIncompatibleLabelTypes :: HasSpanInfo a => a -> ModuleIdent -> Ident -> Type
-> Type -> Message
errIncompatibleLabelTypes :: a -> ModuleIdent -> Ident -> Type -> Type -> Message
errIncompatibleLabelTypes p :: a
p m :: ModuleIdent
m l :: Ident
l ty1 :: Type
ty1 ty2 :: Type
ty2 = a -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage a
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep
[ String -> Doc
text "Labeled types" Doc -> Doc -> Doc
<+> Ident -> Doc
ppIdent Ident
l Doc -> Doc -> Doc
<+> String -> Doc
text "::" Doc -> Doc -> Doc
<+> ModuleIdent -> Type -> Doc
ppType ModuleIdent
m Type
ty1
, Int -> Doc -> Doc
nest 10 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "and" Doc -> Doc -> Doc
<+> Ident -> Doc
ppIdent Ident
l Doc -> Doc -> Doc
<+> String -> Doc
text "::" Doc -> Doc -> Doc
<+> ModuleIdent -> Type -> Doc
ppType ModuleIdent
m Type
ty2
, String -> Doc
text "are incompatible"
]
errMissingInstance :: HasSpanInfo a => ModuleIdent -> a -> String -> Doc -> Pred
-> Message
errMissingInstance :: ModuleIdent -> a -> String -> Doc -> Pred -> Message
errMissingInstance m :: ModuleIdent
m p :: a
p what :: String
what doc :: Doc
doc pr :: Pred
pr = a -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage a
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
[ String -> Doc
text "Missing instance for" Doc -> Doc -> Doc
<+> ModuleIdent -> Pred -> Doc
ppPred ModuleIdent
m Pred
pr
, String -> Doc
text "in" Doc -> Doc -> Doc
<+> String -> Doc
text String
what
, Doc
doc
]
errAmbiguousTypeVariable :: HasSpanInfo a => ModuleIdent -> a -> String -> Doc
-> PredSet -> Type -> Int -> Message
errAmbiguousTypeVariable :: ModuleIdent
-> a -> String -> Doc -> PredSet -> Type -> Int -> Message
errAmbiguousTypeVariable m :: ModuleIdent
m p :: a
p what :: String
what doc :: Doc
doc ps :: PredSet
ps ty :: Type
ty tv :: Int
tv = a -> Doc -> Message
forall s. HasSpanInfo s => s -> Doc -> Message
spanInfoMessage a
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
[ String -> Doc
text "Ambiguous type variable" Doc -> Doc -> Doc
<+> ModuleIdent -> Type -> Doc
ppType ModuleIdent
m (Int -> Type
TypeVariable Int
tv)
, String -> Doc
text "in type" Doc -> Doc -> Doc
<+> ModuleIdent -> PredType -> Doc
ppPredType ModuleIdent
m (PredSet -> Type -> PredType
PredType PredSet
ps Type
ty)
, String -> Doc
text "inferred for" Doc -> Doc -> Doc
<+> String -> Doc
text String
what
, Doc
doc
]