{- |
    Module      :  $Header$
    Description :  Type checking Curry programs
    Copyright   :  (c) 1999 - 2004 Wolfgang Lux
                                   Martin Engelke
                       2011 - 2015 Björn Peemöller
                       2014 - 2015 Jan Tikovsky
                       2016 - 2017 Finn Teegen
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

   This module implements the type checker of the Curry compiler. The
   type checker is invoked after the syntactic correctness of the program
   has been verified and kind checking has been applied to all type
   expressions. Local variables have been renamed already. Thus the
   compiler can maintain a flat type environment. The type checker now
   checks the correct typing of all expressions and also verifies that
   the type signatures given by the user match the inferred types. The
   type checker uses the algorithm by Damas and Milner (1982) for inferring
   the types of unannotated declarations, but allows for polymorphic
   recursion when a type annotation is present.

   The result of type checking is a (flat) top-level environment
   containing the types of all constructors, variables, and functions
   defined at the top level of a module. In addition, a type annotated
   source module is returned. Note that type annotations on the
   left hand side of a declaration hold the function or variable's
   generalized type with the type scheme's universal quantifier left
   implicit. Type annotations on the right hand side of a declaration
   hold the particular instance at which a polymorphic function or
   variable is used.
-}
{-# 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.Extra        ( (&&^), allM, filterM, foldM
                                            , liftM, notM, replicateM, unless
                                            , unlessM )
import qualified Control.Monad.State as S   (State, runState, gets, modify)
import           Data.List                  (nub, nubBy, partition, sortBy)
import           Data.Function              (on)
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.Position
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, posMessage, 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

-- Type checking proceeds as follows. First, the types of all data
-- constructors, field labels and class methods are entered into the
-- value environment and then a type inference for all function and
-- value definitions is performed.

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

-- The type checker makes use of a state monad in order to maintain the value
-- environment, the current substitution, and a counter which is used for
-- generating fresh type variables.

-- Additionally, an extended instance environment is used in order to handle
-- the introduction of local instances when matching a data constructor with a
-- non-empty context. This extended instance environment is composed of the
-- static top-level environment and a dynamic environment that maps each class
-- on the instances which are in scope for it. The rationale behind using this
-- representation is that it makes it easy to apply the current substitution to
-- the dynamic part of the environment.

type TCM = S.State TcState

type InstEnv' = (InstEnv, Map.Map QualIdent [Type])

data TcState = TcState
  { TcState -> ModuleIdent
moduleIdent  :: ModuleIdent -- read only
  , TcState -> TCEnv
tyConsEnv    :: TCEnv
  , TcState -> ValueEnv
valueEnv     :: ValueEnv
  , TcState -> ClassEnv
classEnv     :: ClassEnv
  , TcState -> InstEnv'
instEnv      :: InstEnv'    -- instances (static and dynamic)
  , TcState -> [Type]
defaultTypes :: [Type]
  , TcState -> TypeSubst
typeSubst    :: TypeSubst
  , TcState -> SigEnv
sigEnv       :: SigEnv
  , TcState -> Int
nextId       :: Int         -- automatic counter
  , 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
  if [Message] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
errs then TCM ()
suf else () -> TCM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

(>>-) :: TCM (a, b, c) -> (a -> b -> TCM a) -> TCM (a, c)
m :: TCM (a, b, c)
m >>- :: TCM (a, b, c) -> (a -> b -> TCM a) -> TCM (a, c)
>>- f :: a -> b -> TCM a
f = do
  (u :: a
u, v :: b
v, w :: c
w) <- TCM (a, b, c)
m
  a
u' <- a -> b -> TCM a
f a
u b
v
  (a, c) -> TCM (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 s :: TcState
s = 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
s
               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 ()

-- Because the type check may mess up the order of the declarations, we
-- associate each declaration with a number. At the end of the type check,
-- we can use these numbers to restore the original declaration order.

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)

-- During the type check we also have to convert the type of declarations
-- without annotations which is done by the function 'untyped' below.

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"

-- Defining Data Constructors:
-- In the next step, the types of all data constructors are entered into
-- the value environment using the information entered into the type constructor
-- environment before.

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]

-- When a field label occurs in more than one constructor declaration of
-- a data type, the compiler ensures that the label is defined
-- consistently, i.e. both occurrences have the same type. In addition,
-- the compiler ensures that no existentially quantified type variable occurs
-- in the type of a field label because such type variables necessarily escape
-- their scope with the type of the record selection function associated with
-- the field label.

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.
HasPosition 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. HasPosition 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.
HasPosition p =>
[Ident] -> (Ident, p, TypeExpr) -> TCM (Ident, p, Type)
tcFieldLabel [Ident]
tvs (Ident
l, SpanInfo
p, TypeExpr
ty)
  TCM ()
ok
checkFieldLabel _ = TCM ()
ok

tcFieldLabel :: HasPosition 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. HasPosition 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 :: HasPosition 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.
HasPosition 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)

-- Defining Field Labels:
-- Next the types of all field labels are added to the value environment.

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 = (Ident -> QualIdent) -> [Ident] -> [QualIdent]
forall a b. (a -> b) -> [a] -> [b]
map (QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
tc) ([Ident] -> [QualIdent]) -> [Ident] -> [QualIdent]
forall a b. (a -> b) -> a -> b
$
          [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)))

-- Defining class methods:
-- Last, the types of all class methods are added to the value environment.

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 _ _ 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 -> ClassMethod -> ValueEnv -> ValueEnv
bindClassMethod ModuleIdent
m) ValueEnv
vEnv' [ClassMethod]
ms
    bindMethods _ vEnv' :: ValueEnv
vEnv' = ValueEnv
vEnv'

-- Since the implementations of class methods can differ in their arity,
-- we assume an arity of 0 when we enter one into the value environment.

bindClassMethod :: ModuleIdent -> ClassMethod -> ValueEnv -> ValueEnv
bindClassMethod :: ModuleIdent -> ClassMethod -> ValueEnv -> ValueEnv
bindClassMethod m :: ModuleIdent
m (ClassMethod f :: Ident
f _ pty :: PredType
pty) =
  (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 -> Bool -> Int -> TypeScheme -> ValueInfo
Value QualIdent
qc Bool
True 0 TypeScheme
tySc) ModuleIdent
m Ident
f (PredType -> TypeScheme
typeScheme PredType
pty)

-- Default Types:
-- The list of default types is given either by a default declaration in
-- the source code or defaults to the predefined list of numeric data types.

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 Signatures:
-- The type checker collects type signatures in a flat environment.
-- The types are not expanded so that the signature is available for
-- use in the error message that is printed when the inferred type is
-- less general than the signature.

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 qty :: QualTypeExpr
qty) 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)
-> QualTypeExpr -> Ident -> SigEnv -> SigEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ident -> QualTypeExpr -> SigEnv -> SigEnv
bindTypeSig QualTypeExpr
qty) 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

-- Declaration groups:
-- Before type checking a group of declarations, a dependency analysis is
-- performed and the declaration group is eventually transformed into
-- nested declaration groups which are checked separately. Within each
-- declaration group, first the value environment is extended with new
-- bindings for all variables and functions defined in the group. Next,
-- types are inferred for all declarations without an explicit type signature
-- and the inferred types are then generalized. Finally, the types of all
-- explicitly typed declarations are checked.

-- Within a group of mutually recursive declarations, all type variables
-- that appear in the types of the variables defined in the group and
-- whose type cannot be generalized must not be generalized in the other
-- declarations of that group as well.

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 (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (([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
  (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
  (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
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 _ pty :: PredType
pty) -> PredType -> Ident -> Var PredType
forall a. a -> Ident -> Var a
Var PredType
pty Ident
v) [(Ident, Int, TypeScheme)]
vs))])
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])
-> StateT TcState Identity [(Type, PDecl PredType)]
-> StateT TcState Identity [Int]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Type, PDecl PredType) -> [Int])
-> [(Type, PDecl PredType)] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Type, PDecl PredType) -> [Int])
 -> [(Type, PDecl PredType)] -> [Int])
-> ((Type, PDecl PredType) -> [Int])
-> [(Type, PDecl PredType)]
-> [Int]
forall a b. (a -> b) -> a -> b
$ 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) (StateT TcState Identity [(Type, PDecl PredType)]
 -> StateT TcState Identity [Int])
-> StateT TcState Identity [(Type, PDecl PredType)]
-> StateT TcState Identity [Int]
forall a b. (a -> b) -> a -> 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) -> StateT TcState Identity PredSet)
-> PredSet
-> [(Type, PDecl PredType)]
-> StateT TcState Identity PredSet
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Type -> PDecl PredType -> StateT TcState Identity PredSet)
-> (Type, PDecl PredType) -> StateT TcState Identity PredSet
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Type -> PDecl PredType -> StateT TcState Identity PredSet)
 -> (Type, PDecl PredType) -> StateT TcState Identity PredSet)
-> (PredSet
    -> Type -> PDecl PredType -> StateT TcState Identity PredSet)
-> PredSet
-> (Type, PDecl PredType)
-> StateT TcState Identity PredSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Int
-> PredSet
-> Type
-> PDecl PredType
-> StateT TcState Identity PredSet
forall a.
Set Int
-> PredSet -> Type -> PDecl a -> StateT TcState Identity 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 -> Bool -> Int -> TypeScheme -> ValueEnv -> ValueEnv)
-> Bool -> Ident -> Int -> TypeScheme -> ValueEnv -> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleIdent
-> Ident -> Bool -> Int -> TypeScheme -> ValueEnv -> ValueEnv
bindFun ModuleIdent
m) Bool
False

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 -> Bool -> Int -> TypeScheme -> ValueEnv -> ValueEnv)
-> Bool -> Ident -> Int -> TypeScheme -> ValueEnv -> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleIdent
-> Ident -> Bool -> Int -> TypeScheme -> ValueEnv -> ValueEnv
rebindFun ModuleIdent
m) Bool
False

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.
HasPosition 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 -> StateT TcState Identity PredSet)
-> TCM (PredSet, Rhs PredType)
forall a b c. TCM (a, b, c) -> (a -> b -> TCM a) -> TCM (a, c)
>>-
    SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
unifyDecl SpanInfo
p "pattern declaration" (Decl a -> Doc
forall a. Decl a -> Doc
ppDecl 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"

-- The function 'tcFunctionPDecl' ignores the context of a function's type
-- signature. This prevents missing instance errors when the inferred type
-- of a function is less general than the declared type.

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 -> StateT TcState Identity PredSet)
-> StateT TcState Identity (PredSet, Equation PredType)
forall a b c. TCM (a, b, c) -> (a -> b -> TCM a) -> TCM (a, c)
>>- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
unifyDecl SpanInfo
p "equation" (Equation a -> Doc
forall a. Equation a -> Doc
ppEquation 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') <- SpanInfo -> Lhs a -> TCM (PredSet, [Type], Lhs PredType)
forall p a.
HasPosition p =>
p -> Lhs a -> TCM (PredSet, [Type], Lhs PredType)
tcLhs SpanInfo
p Lhs a
lhs
    (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 -> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p -> String -> Doc -> PredSet -> StateT TcState Identity PredSet
reducePredSet SpanInfo
p "equation" (Equation PredType -> Doc
forall a. Equation a -> Doc
ppEquation (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 :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> PredSet
          -> Type
          -> TCM PredSet
unifyDecl :: p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity 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
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity 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
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> Set Int
-> PredSet
-> Type
-> StateT TcState Identity PredSet
applyDefaultsDecl p
p String
what Doc
doc Set Int
fvs PredSet
ps Type
tyLhs

-- After inferring types for a group of mutually recursive declarations
-- and computing the set of its constrained type variables, the compiler
-- has to be prepared for some of the constrained type variables to not
-- appear in some of the inferred types, i.e., there may be ambiguous
-- types that have not been reported by 'unifyDecl' above at the level
-- of individual function equations and pattern declarations.

defaultPDecl :: Set.Set Int -> PredSet -> Type -> PDecl a -> TCM PredSet
defaultPDecl :: Set Int
-> PredSet -> Type -> PDecl a -> StateT TcState Identity 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
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> Set Int
-> PredSet
-> Type
-> StateT TcState Identity 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
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> Set Int
-> PredSet
-> Type
-> StateT TcState Identity 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 -> StateT TcState Identity PredSet
forall (m :: * -> *) a. Monad m => a -> m a
return PredSet
ps
defaultPDecl _ _ _ _ = String -> StateT TcState Identity PredSet
forall a. String -> a
internalError "TypeCheck.defaultPDecl"

applyDefaultsDecl :: HasPosition p => p -> String -> Doc -> Set.Set Int
                  -> PredSet -> Type -> TCM PredSet
applyDefaultsDecl :: p
-> String
-> Doc
-> Set Int
-> PredSet
-> Type
-> StateT TcState Identity 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
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> Set Int
-> PredSet
-> Type
-> StateT TcState Identity PredSet
applyDefaults p
p String
what Doc
doc Set Int
fvs' PredSet
ps Type
ty'

-- After 'tcDeclGroup' has generalized the types of the implicitly
-- typed declarations of a declaration group it must update their left
-- hand side type annotations and the type environment accordingly.
-- Recall that the compiler generalizes only the types of variable and
-- function declarations.

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"

-- The function 'tcCheckPDecl' checks the type of an explicitly typed function
-- or variable declaration. After inferring a type for the declaration, the
-- inferred type is compared with the type signature. Since the inferred type
-- of an explicitly typed function or variable declaration is automatically an
-- instance of its type signature, the type signature is correct only if the
-- inferred type matches the type signature exactly except for the inferred
-- predicate set, which may contain only a subset of the declared context
-- because the context of a function's type signature is ignored in the
-- function 'tcFunctionPDecl' above.

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
$ SpanInfo
-> ModuleIdent -> Doc -> QualTypeExpr -> TypeScheme -> Message
forall a.
HasPosition a =>
a -> ModuleIdent -> Doc -> QualTypeExpr -> TypeScheme -> Message
errTypeSigTooGeneral SpanInfo
p 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
$ SpanInfo
-> ModuleIdent -> Doc -> QualTypeExpr -> TypeScheme -> Message
forall a.
HasPosition a =>
a -> ModuleIdent -> Doc -> QualTypeExpr -> TypeScheme -> Message
errTypeSigTooGeneral SpanInfo
p 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)

-- The function 'equTypes' computes whether two types are equal modulo
-- renaming of type variables.
-- WARNING: This operation is not reflexive and expects the second type to be
-- the type signature provided by the programmer.
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
 -- @is@ is an AssocList of type variable indices
 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)

-- In Curry, a non-expansive expression is either
--
-- * a literal,
-- * a variable,
-- * an application of a constructor with arity n to at most n
--   non-expansive expressions,
-- * an application of a function with arity n to at most n-1
--   non-expansive expressions, or
-- * a let expression whose body is a non-expansive expression and
--   whose local declarations are either function declarations or
--   variable declarations of the form x=e where e is a non-expansive
--   expression, or
-- * an expression whose desugared form is one of the above.
--
-- At first it may seem strange that variables are included in the list
-- above because a variable may be bound to a logical variable. However,
-- this is no problem because type variables that are present among the
-- typing assumptions of the environment enclosing a let expression
-- cannot be generalized.

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
    -- TODO: Uncomment when polymorphic let declarations are fully supported
  {-isNonExpansive (PatternDecl     _ t rhs) = case t of
    VariablePattern _ _ -> isNonExpansive rhs
    _                   -> return 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 (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
  isNonExpansive (GuardedRhs _ _ _) = Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- A record construction is non-expansive only if all field labels are present.

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 (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (([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 (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((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)
-> StateT TcState Identity Bool -> StateT TcState Identity Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((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 -> Bool -> Int -> TypeScheme -> ValueInfo
Value (Ident -> QualIdent
qualify Ident
v) Bool
False Int
n TypeScheme
forall a. HasCallStack => a
undefined)

-- Class and instance declarations:
-- When checking method implementations in class and instance
-- declarations, the compiler must check that the inferred type matches
-- the method's declared type. This is straight forward in class
-- declarations (the only difference with respect to an overloaded
-- function with an explicit type signature is that a class method's type
-- signature is composed of its declared type signature and the context
-- from the class declaration), but a little bit more complicated for
-- instance declarations because the instance type must be substituted
-- for the type variable used in the type class declaration.
--
-- When checking inferred method types against their expected types, we
-- have to be careful because the class' type variable is always assigned
-- index 0 in the method types recorded in the value environment. However,
-- in the inferred type scheme returned from 'tcMethodDecl', type variables
-- are assigned indices in the order of their occurrence. In order to avoid
-- incorrectly reporting errors when the type class variable is not the first
-- variable that appears in a method's type, 'tcInstMethodDecl' normalizes
-- the expected method type before applying 'checkInstMethodType' to it and
-- 'checkClassMethodType' uses 'expandPolyType' instead of 'expandMethodType'
-- in order to convert the method's type signature. Unfortunately, this means
-- that the compiler has to add the class constraint explicitly to the type
-- signature.

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 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
  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
-> Context -> Ident -> Ident -> [Decl PredType] -> Decl PredType
forall a.
SpanInfo -> Context -> Ident -> Ident -> [Decl a] -> Decl a
ClassDecl SpanInfo
p 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')
  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 (i :: Int
i, InstanceDecl p :: SpanInfo
p 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
-> Context
-> QualIdent
-> TypeExpr
-> [Decl PredType]
-> Decl PredType
forall a.
SpanInfo -> Context -> QualIdent -> TypeExpr -> [Decl a] -> Decl a
InstanceDecl SpanInfo
p 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 "Checks.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') <- TypeScheme -> PDecl a -> TCM (TypeScheme, PDecl PredType)
forall a. TypeScheme -> PDecl a -> TCM (TypeScheme, PDecl PredType)
tcMethodPDecl 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') <- TypeScheme -> PDecl a -> TCM (TypeScheme, PDecl PredType)
forall a. TypeScheme -> PDecl a -> TCM (TypeScheme, PDecl PredType)
tcMethodPDecl (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 :: TypeScheme -> PDecl a -> TCM (TypeScheme, PDecl PredType)
tcMethodPDecl :: TypeScheme -> PDecl a -> TCM (TypeScheme, PDecl PredType)
tcMethodPDecl 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 -> Bool -> Int -> TypeScheme -> ValueEnv -> ValueEnv
bindFun ModuleIdent
m Ident
f Bool
True (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 p :: SpanInfo
p _ 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
$ SpanInfo
-> ModuleIdent -> Doc -> QualTypeExpr -> TypeScheme -> Message
forall a.
HasPosition a =>
a -> ModuleIdent -> Doc -> QualTypeExpr -> TypeScheme -> Message
errTypeSigTooGeneral SpanInfo
p 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 p :: SpanInfo
p _ 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
$
      SpanInfo -> ModuleIdent -> Doc -> PredType -> TypeScheme -> Message
forall a.
HasPosition a =>
a -> ModuleIdent -> Doc -> PredType -> TypeScheme -> Message
errMethodTypeTooSpecific SpanInfo
p 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

-- Due to the sorting of the predicate set, we can simply remove the minimum
-- element as this is guaranteed to be the class constraint (see module 'Types'
-- for more information).

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''

-- External functions:

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 -> Bool -> Int -> TypeScheme -> ValueEnv -> ValueEnv
bindFun ModuleIdent
m Ident
f Bool
False (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'

-- Patterns and Expressions:
-- Note that the type attribute associated with a constructor or infix
-- pattern is the type of the whole pattern and not the type of the
-- constructor itself. Overloaded (numeric) literals are not supported in
-- patterns.

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 (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((,) 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 (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((,) 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 :: HasPosition p => p -> Lhs a -> TCM (PredSet, [Type], Lhs PredType)
tcLhs :: p -> Lhs a -> 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]))
-> 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 (p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasPosition p =>
p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern p
p) [Pattern a]
ts
  (PredSet, [Type], Lhs PredType)
-> 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 -> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasPosition p =>
p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern p
p Pattern a
t1
  (ps2 :: PredSet
ps2, ty2 :: Type
ty2, t2' :: Pattern PredType
t2') <- p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasPosition p =>
p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern p
p Pattern a
t2
  (PredSet, [Type], Lhs PredType)
-> 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 -> TCM (PredSet, [Type], Lhs PredType)
forall p a.
HasPosition p =>
p -> Lhs a -> 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]))
-> 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 (p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasPosition p =>
p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern p
p) [Pattern a]
ts
  (PredSet, [Type], Lhs PredType)
-> 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')

-- When computing the type of a variable in a pattern, we ignore the
-- predicate set of the variable's type (which can only be due to a type
-- signature in the same declaration group) for just the same reason as
-- in 'tcFunctionPDecl'. Infix and infix functional patterns are currently
-- checked as constructor and functional patterns, respectively, resulting
-- in slighty misleading error messages if the type check fails.

tcPattern :: HasPosition p => p -> Pattern a
          -> TCM (PredSet, Type, Pattern PredType)
tcPattern :: p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern _ (LiteralPattern spi :: SpanInfo
spi _ l :: Literal
l) = do
  (ps :: PredSet
ps, ty :: Type
ty) <- Bool -> Literal -> StateT TcState Identity (PredSet, Type)
tcLiteral Bool
False Literal
l
  (PredSet, Type, Pattern PredType)
-> 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)
tcPattern _ (NegativePattern spi :: SpanInfo
spi _ l :: Literal
l) = do
  (ps :: PredSet
ps, ty :: Type
ty) <- Bool -> Literal -> StateT TcState Identity (PredSet, Type)
tcLiteral Bool
False Literal
l
  (PredSet, Type, Pattern PredType)
-> 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)
tcPattern _ (VariablePattern spi :: SpanInfo
spi _ v :: Ident
v) = do
  ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
  (_, ty :: Type
ty) <- TypeScheme -> StateT TcState Identity (PredSet, Type)
inst (Ident -> ValueEnv -> TypeScheme
varType Ident
v ValueEnv
vEnv)
  (PredSet, Type, Pattern PredType)
-> TCM (PredSet, Type, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredSet
emptyPredSet, Type
ty, SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
spi (Type -> PredType
predType Type
ty) Ident
v)
tcPattern p :: p
p t :: Pattern a
t@(ConstructorPattern spi :: SpanInfo
spi _ c :: QualIdent
c ts :: [Pattern a]
ts) = do
  ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
  ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
  (ps :: PredSet
ps, (tys :: [Type]
tys, ty' :: Type
ty')) <- ((PredSet, Type) -> (PredSet, ([Type], Type)))
-> StateT TcState Identity (PredSet, Type)
-> StateT TcState Identity (PredSet, ([Type], Type))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((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) (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 TcState Identity (PredSet, Pattern PredType))
-> PredSet
-> [(Type, Pattern a)]
-> StateT TcState Identity (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 TcState Identity (PredSet, Pattern PredType))
-> (Type, Pattern a)
-> StateT TcState Identity (PredSet, Pattern PredType)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Type
  -> Pattern a
  -> StateT TcState Identity (PredSet, Pattern PredType))
 -> (Type, Pattern a)
 -> StateT TcState Identity (PredSet, Pattern PredType))
-> (PredSet
    -> Type
    -> Pattern a
    -> StateT TcState Identity (PredSet, Pattern PredType))
-> PredSet
-> (Type, Pattern a)
-> StateT TcState Identity (PredSet, Pattern PredType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> StateT TcState Identity (PredSet, Pattern PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> StateT TcState Identity (PredSet, Pattern PredType)
tcPatternArg p
p "pattern" (Int -> Pattern a -> Doc
forall a. Int -> Pattern a -> Doc
ppPattern 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)
-> 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')
tcPattern 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 -> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasPosition p =>
p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern 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)
-> 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')
tcPattern 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 -> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasPosition p =>
p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern p
p Pattern a
t
  (PredSet, Type, Pattern PredType)
-> 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')
tcPattern _ t :: Pattern a
t@(RecordPattern spi :: SpanInfo
spi _ c :: QualIdent
c fs :: [Field (Pattern a)]
fs) = do
  ModuleIdent
m <- TCM ModuleIdent
getModuleIdent
  ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
  (ps :: PredSet
ps, ty :: Type
ty) <- ((PredSet, Type) -> (PredSet, Type))
-> StateT TcState Identity (PredSet, Type)
-> StateT TcState Identity (PredSet, Type)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Type -> Type) -> (PredSet, Type) -> (PredSet, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
arrowBase) (TypeScheme -> StateT TcState Identity (PredSet, Type)
skol (ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
constrType ModuleIdent
m QualIdent
c ValueEnv
vEnv))
  (ps' :: PredSet
ps', fs' :: [Field (Pattern PredType)]
fs') <- (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 ((Position -> 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.
(Position -> a b -> TCM (PredSet, Type, a PredType))
-> String
-> (a b -> Doc)
-> Type
-> PredSet
-> Field (a b)
-> TCM (PredSet, Field (a PredType))
tcField Position -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasPosition p =>
p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern "pattern"
    (\t' :: Pattern a
t' -> Int -> Pattern a -> Doc
forall a. Int -> Pattern a -> Doc
ppPattern 0 Pattern a
t Doc -> Doc -> Doc
$-$ String -> Doc
text "Term:" Doc -> Doc -> Doc
<+> Int -> Pattern a -> Doc
forall a. Int -> Pattern a -> Doc
ppPattern 0 Pattern a
t') Type
ty) PredSet
ps [Field (Pattern a)]
fs
  (PredSet, Type, Pattern PredType)
-> 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')
tcPattern 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]))
-> 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 (p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasPosition p =>
p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern p
p) [Pattern a]
ts
  (PredSet, Type, Pattern PredType)
-> 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')
tcPattern p :: p
p t :: Pattern a
t@(ListPattern spi :: SpanInfo
spi _ ts :: [Pattern a]
ts) = do
  Type
ty <- StateT TcState Identity Type
freshTypeVar
  (ps :: PredSet
ps, ts' :: [Pattern PredType]
ts') <- (PredSet
 -> Pattern a
 -> StateT TcState Identity (PredSet, Pattern PredType))
-> PredSet
-> [Pattern a]
-> StateT TcState Identity (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 TcState Identity (PredSet, Pattern PredType))
-> Type
-> PredSet
-> Pattern a
-> StateT TcState Identity (PredSet, Pattern PredType)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> StateT TcState Identity (PredSet, Pattern PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> StateT TcState Identity (PredSet, Pattern PredType)
tcPatternArg p
p "pattern" (Int -> Pattern a -> Doc
forall a. Int -> Pattern a -> Doc
ppPattern 0 Pattern a
t)) Type
ty)
                         PredSet
emptyPredSet [Pattern a]
ts
  (PredSet, Type, Pattern PredType)
-> 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')
tcPattern p :: p
p t :: Pattern a
t@(AsPattern spi :: SpanInfo
spi v :: Ident
v t' :: Pattern a
t') = do
  ValueEnv
vEnv <- TCM ValueEnv
getValueEnv
  (_, ty :: Type
ty) <- TypeScheme -> StateT TcState Identity (PredSet, Type)
inst (Ident -> ValueEnv -> TypeScheme
varType Ident
v ValueEnv
vEnv)
  (ps :: PredSet
ps, t'' :: Pattern PredType
t'') <- p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasPosition p =>
p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern p
p Pattern a
t' TCM (PredSet, Type, Pattern PredType)
-> (PredSet -> Type -> StateT TcState Identity PredSet)
-> StateT TcState Identity (PredSet, Pattern PredType)
forall a b c. TCM (a, b, c) -> (a -> b -> TCM a) -> TCM (a, c)
>>-
    p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
unify p
p "pattern" (Int -> Pattern a -> Doc
forall a. Int -> Pattern a -> Doc
ppPattern 0 Pattern a
t) PredSet
emptyPredSet Type
ty
  (PredSet, Type, Pattern PredType)
-> 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'')
tcPattern 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 -> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasPosition p =>
p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern p
p Pattern a
t
  (PredSet, Type, Pattern PredType)
-> 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')
tcPattern p :: p
p t :: Pattern a
t@(FunctionPattern spi :: SpanInfo
spi _ f :: QualIdent
f ts :: [Pattern a]
ts) = 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
f ValueEnv
vEnv)
  p
-> SpanInfo
-> Doc
-> QualIdent
-> ([Pattern PredType] -> [Pattern PredType])
-> PredSet
-> Type
-> [Pattern a]
-> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasPosition p =>
p
-> SpanInfo
-> Doc
-> QualIdent
-> ([Pattern PredType] -> [Pattern PredType])
-> PredSet
-> Type
-> [Pattern a]
-> TCM (PredSet, Type, Pattern PredType)
tcFuncPattern p
p SpanInfo
spi (Int -> Pattern a -> Doc
forall a. Int -> Pattern a -> Doc
ppPattern 0 Pattern a
t) QualIdent
f [Pattern PredType] -> [Pattern PredType]
forall a. a -> a
id PredSet
ps Type
ty [Pattern a]
ts
tcPattern 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 -> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasPosition p =>
p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern 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)
-> 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 :: HasPosition p => p -> SpanInfo -> Doc -> QualIdent
              -> ([Pattern PredType] -> [Pattern PredType])
              -> PredSet -> Type -> [Pattern a]
              -> TCM (PredSet, Type, Pattern PredType)
tcFuncPattern :: p
-> SpanInfo
-> Doc
-> QualIdent
-> ([Pattern PredType] -> [Pattern PredType])
-> PredSet
-> Type
-> [Pattern a]
-> 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)
-> 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
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) <-
    p -> String -> Doc -> Type -> TCM (Type, Type)
forall p.
HasPosition p =>
p -> String -> Doc -> Type -> TCM (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. Int -> Pattern a -> Doc
ppPattern 0 Pattern PredType
t) Type
ty
  (ps' :: PredSet
ps', t'' :: Pattern PredType
t'') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> StateT TcState Identity (PredSet, Pattern PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> StateT TcState Identity (PredSet, Pattern PredType)
tcPatternArg 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]
-> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasPosition p =>
p
-> SpanInfo
-> Doc
-> QualIdent
-> ([Pattern PredType] -> [Pattern PredType])
-> PredSet
-> Type
-> [Pattern a]
-> 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 [])

tcPatternArg :: HasPosition p => p -> String -> Doc -> PredSet -> Type
             -> Pattern a -> TCM (PredSet, Pattern PredType)
tcPatternArg :: p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> StateT TcState Identity (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.
HasPosition p =>
p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern p
p Pattern a
t TCM (PredSet, Type, Pattern PredType)
-> (PredSet -> Type -> StateT TcState Identity PredSet)
-> StateT TcState Identity (PredSet, Pattern PredType)
forall a b c. TCM (a, b, c) -> (a -> b -> TCM a) -> TCM (a, c)
>>-
    p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
unify p
p String
what (Doc
doc Doc -> Doc -> Doc
$-$ String -> Doc
text "Term:" Doc -> Doc -> Doc
<+> Int -> Pattern a -> Doc
forall a. Int -> Pattern a -> Doc
ppPattern 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 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') <- SpanInfo
-> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr SpanInfo
p 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 -> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p -> String -> Doc -> PredSet -> StateT TcState Identity PredSet
reducePredSet SpanInfo
p "expression" (Int -> Expression PredType -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 -> Expression PredType -> [Decl PredType] -> Rhs PredType
forall a. SpanInfo -> Expression a -> [Decl a] -> Rhs a
SimpleRhs SpanInfo
p Expression PredType
e' [Decl PredType]
ds')
tcRhs (GuardedRhs spi :: SpanInfo
spi 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 -> [CondExpr PredType] -> [Decl PredType] -> Rhs PredType
forall a. SpanInfo -> [CondExpr a] -> [Decl a] -> Rhs a
GuardedRhs SpanInfo
spi [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') <- SpanInfo
-> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr SpanInfo
p Expression a
g TCM (PredSet, Type, Expression PredType)
-> (PredSet -> Type -> StateT TcState Identity PredSet)
-> TCM (PredSet, Expression PredType)
forall a b c. TCM (a, b, c) -> (a -> b -> TCM a) -> TCM (a, c)
>>- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
unify SpanInfo
p "guard" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 0 Expression a
g) PredSet
ps Type
boolType
  (ps'' :: PredSet
ps'', e' :: Expression PredType
e') <- SpanInfo
-> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr SpanInfo
p Expression a
e TCM (PredSet, Type, Expression PredType)
-> (PredSet -> Type -> StateT TcState Identity PredSet)
-> TCM (PredSet, Expression PredType)
forall a b c. TCM (a, b, c) -> (a -> b -> TCM a) -> TCM (a, c)
>>- SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
unify SpanInfo
p "guarded expression" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 :: HasPosition p => p -> Expression a
       -> TCM (PredSet, Type, Expression PredType)
tcExpr :: p -> 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 []
                                        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 p :: p
p (Paren spi :: SpanInfo
spi e :: Expression a
e) = do
  (ps :: PredSet
ps, ty :: Type
ty, e' :: Expression PredType
e') <- p -> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr p
p 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 p :: p
p (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') <- p -> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr p
p Expression a
e TCM (PredSet, Type, Expression PredType)
-> (PredSet -> Type -> StateT TcState Identity PredSet)
-> TCM (PredSet, Expression PredType)
forall a b c. TCM (a, b, c) -> (a -> b -> TCM a) -> TCM (a, c)
>>-
    p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
unifyDecl p
p "explicitly typed expression" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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
$
      p -> ModuleIdent -> Doc -> QualTypeExpr -> TypeScheme -> Message
forall a.
HasPosition a =>
a -> ModuleIdent -> Doc -> QualTypeExpr -> TypeScheme -> Message
errTypeSigTooGeneral p
p ModuleIdent
m (String -> Doc
text "Expression:" Doc -> Doc -> Doc
<+> Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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) <- ((PredSet, Type) -> (PredSet, Type))
-> StateT TcState Identity (PredSet, Type)
-> StateT TcState Identity (PredSet, Type)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Type -> Type) -> (PredSet, Type) -> (PredSet, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
arrowBase) (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 ((Position
 -> 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.
(Position -> a b -> TCM (PredSet, Type, a PredType))
-> String
-> (a b -> Doc)
-> Type
-> PredSet
-> Field (a b)
-> TCM (PredSet, Field (a PredType))
tcField Position
-> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr "construction"
    (\e' :: Expression a
e' -> Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 0 Expression a
e Doc -> Doc -> Doc
$-$ String -> Doc
text "Term:" Doc -> Doc -> Doc
<+> Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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
-> 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 p :: p
p 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') <- p -> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr p
p 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 ((Position
 -> 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.
(Position -> a b -> TCM (PredSet, Type, a PredType))
-> String
-> (a b -> Doc)
-> Type
-> PredSet
-> Field (a b)
-> TCM (PredSet, Field (a PredType))
tcField Position
-> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr "update"
    (\e' :: Expression a
e' -> Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 0 Expression a
e Doc -> Doc -> Doc
$-$ String -> Doc
text "Term:" Doc -> Doc -> Doc
<+> Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 p :: p
p (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 (p -> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr p
p) [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 p :: p
p 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 -> TCM (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 -> TCM (PredSet, Expression PredType))
-> Type
-> PredSet
-> Expression a
-> TCM (PredSet, Expression PredType)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "expression" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 p :: p
p (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 (p
-> PredSet
-> Statement a
-> StateT TcState Identity (PredSet, Statement PredType)
forall p a.
HasPosition p =>
p
-> PredSet
-> Statement a
-> StateT TcState Identity (PredSet, Statement PredType)
tcQual p
p) PredSet
emptyPredSet [Statement a]
qs
    (ps' :: PredSet
ps', ty :: Type
ty, e' :: Expression PredType
e') <- p -> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr p
p 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'' <- p -> String -> Doc -> PredSet -> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p -> String -> Doc -> PredSet -> StateT TcState Identity PredSet
reducePredSet p
p "expression" (Int -> Expression PredType -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 p :: p
p 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') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "arithmetic sequence" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 p :: p
p 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') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "arithmetic sequence" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 0 Expression a
e) PredSet
ps Type
ty Expression a
e1
  (ps'' :: PredSet
ps'', e2' :: Expression PredType
e2') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "arithmetic sequence" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 p :: p
p 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') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "arithmetic sequence" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 0 Expression a
e) PredSet
ps Type
ty Expression a
e1
  (ps'' :: PredSet
ps'', e2' :: Expression PredType
e2') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "arithmetic sequence" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 p :: p
p 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') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "arithmetic sequence" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 0 Expression a
e) PredSet
ps Type
ty Expression a
e1
  (ps'' :: PredSet
ps'', e2' :: Expression PredType
e2') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "arithmetic sequence" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 0 Expression a
e) PredSet
ps' Type
ty Expression a
e2
  (ps''' :: PredSet
ps''', e3' :: Expression PredType
e3') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "arithmetic sequence" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 p :: p
p 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') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "unary negation" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 p :: p
p 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') <- p -> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr p
p Expression a
e1 TCM (PredSet, Type, Expression PredType)
-> (Type -> TCM (Type, Type))
-> TCM (PredSet, (Type, Type), Expression PredType)
forall a b d c. TCM (a, b, d) -> (b -> TCM c) -> TCM (a, c, d)
>>=-
    p -> String -> Doc -> Type -> TCM (Type, Type)
forall p.
HasPosition p =>
p -> String -> Doc -> Type -> TCM (Type, Type)
tcArrow p
p "application" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 0 Expression a
e Doc -> Doc -> Doc
$-$ String -> Doc
text "Term:" Doc -> Doc -> Doc
<+> Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 0 Expression a
e1)
  (ps' :: PredSet
ps', e2' :: Expression PredType
e2') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "application" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 p :: p
p 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)
>>=-
    p -> String -> Doc -> Type -> TCM (Type, Type, Type)
forall p.
HasPosition p =>
p -> String -> Doc -> Type -> TCM (Type, Type, Type)
tcBinary p
p "infix application" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 0 Expression a
e Doc -> Doc -> Doc
$-$ String -> Doc
text "Operator:" Doc -> Doc -> Doc
<+> InfixOp a -> Doc
forall a. InfixOp a -> Doc
ppOp InfixOp a
op)
  (ps' :: PredSet
ps', e1' :: Expression PredType
e1') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "infix application" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 0 Expression a
e) PredSet
ps Type
alpha Expression a
e1
  (ps'' :: PredSet
ps'', e2' :: Expression PredType
e2') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "infix application" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 p :: p
p 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 -> TCM (Type, Type))
-> TCM (PredSet, (Type, Type), InfixOp PredType)
forall a b d c. TCM (a, b, d) -> (b -> TCM c) -> TCM (a, c, d)
>>=-
    p -> String -> Doc -> Type -> TCM (Type, Type)
forall p.
HasPosition p =>
p -> String -> Doc -> Type -> TCM (Type, Type)
tcArrow p
p "left section" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 0 Expression a
e Doc -> Doc -> Doc
$-$ String -> Doc
text "Operator:" Doc -> Doc -> Doc
<+> InfixOp a -> Doc
forall a. InfixOp a -> Doc
ppOp InfixOp a
op)
  (ps' :: PredSet
ps', e1' :: Expression PredType
e1') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "left section" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 p :: p
p 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)
>>=-
    p -> String -> Doc -> Type -> TCM (Type, Type, Type)
forall p.
HasPosition p =>
p -> String -> Doc -> Type -> TCM (Type, Type, Type)
tcBinary p
p "right section" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 0 Expression a
e Doc -> Doc -> Doc
$-$ String -> Doc
text "Operator:" Doc -> Doc -> Doc
<+> InfixOp a -> Doc
forall a. InfixOp a -> Doc
ppOp InfixOp a
op)
  (ps' :: PredSet
ps', e1' :: Expression PredType
e1') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "right section" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 p :: p
p (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 (p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
forall p a.
HasPosition p =>
p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)
tcPattern p
p) [Pattern a]
ts
    (ps :: PredSet
ps, ty :: Type
ty, e' :: Expression PredType
e') <- p -> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr p
p 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' <- p -> String -> Doc -> PredSet -> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p -> String -> Doc -> PredSet -> StateT TcState Identity PredSet
reducePredSet p
p "expression" (Int -> Expression PredType -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 p :: p
p (Let spi :: SpanInfo
spi 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') <- p -> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr p
p 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'' <- p -> String -> Doc -> PredSet -> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p -> String -> Doc -> PredSet -> StateT TcState Identity PredSet
reducePredSet p
p "expression" (Int -> Expression PredType -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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
-> [Decl PredType] -> Expression PredType -> Expression PredType
forall a. SpanInfo -> [Decl a] -> Expression a -> Expression a
Let SpanInfo
spi [Decl PredType]
ds' Expression PredType
e')
tcExpr p :: p
p (Do spi :: SpanInfo
spi 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 (p
-> PredSet
-> Maybe Type
-> Statement a
-> StateT
     TcState Identity ((PredSet, Maybe Type), Statement PredType)
forall p a.
HasPosition p =>
p
-> PredSet
-> Maybe Type
-> Statement a
-> StateT
     TcState Identity ((PredSet, Maybe Type), Statement PredType)
tcStmt p
p)) (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') <- p -> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr p
p Expression a
e TCM (PredSet, Type, Expression PredType)
-> (PredSet -> Type -> StateT TcState Identity PredSet)
-> TCM (PredSet, Expression PredType)
forall a b c. TCM (a, b, c) -> (a -> b -> TCM a) -> TCM (a, c)
>>- p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
unify p
p "statement" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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
-> [Statement PredType]
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> [Statement a] -> Expression a -> Expression a
Do SpanInfo
spi [Statement PredType]
sts' Expression PredType
e')
tcExpr p :: p
p 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') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "expression" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 0 Expression a
e) PredSet
emptyPredSet Type
boolType Expression a
e1
  (ps' :: PredSet
ps', ty :: Type
ty, e2' :: Expression PredType
e2') <- p -> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr p
p Expression a
e2
  (ps'' :: PredSet
ps'', e3' :: Expression PredType
e3') <- p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "expression" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 p :: p
p (Case spi :: SpanInfo
spi ct :: CaseType
ct e :: Expression a
e as :: [Alt a]
as) = do
  (ps :: PredSet
ps, tyLhs :: Type
tyLhs, e' :: Expression PredType
e') <- p -> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr p
p 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
-> CaseType
-> Expression PredType
-> [Alt PredType]
-> Expression PredType
forall a.
SpanInfo -> CaseType -> Expression a -> [Alt a] -> Expression a
Case SpanInfo
spi CaseType
ct Expression PredType
e' [Alt PredType]
as')

tcArg :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> Expression a
      -> TCM (PredSet, Expression PredType)
tcArg :: p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p :: p
p what :: String
what doc :: Doc
doc ps :: PredSet
ps ty :: Type
ty e :: Expression a
e =
  p -> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr p
p Expression a
e TCM (PredSet, Type, Expression PredType)
-> (PredSet -> Type -> StateT TcState Identity PredSet)
-> TCM (PredSet, Expression PredType)
forall a b c. TCM (a, b, c) -> (a -> b -> TCM a) -> TCM (a, c)
>>- p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
unify p
p String
what (Doc
doc Doc -> Doc -> Doc
$-$ String -> Doc
text "Term:" Doc -> Doc -> Doc
<+> Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 -> StateT TcState Identity PredSet)
-> StateT TcState Identity (PredSet, Alt PredType)
forall a b c. TCM (a, b, c) -> (a -> b -> TCM a) -> TCM (a, c)
>>-
    SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
unify SpanInfo
p "case alternative" (Alt a -> Doc
forall a. Alt a -> Doc
ppAlt 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
-> StateT TcState Identity (PredSet, Pattern PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> StateT TcState Identity (PredSet, Pattern PredType)
tcPatternArg SpanInfo
p "case pattern" (Alt a -> Doc
forall a. Alt a -> Doc
ppAlt (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 -> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p -> String -> Doc -> PredSet -> StateT TcState Identity PredSet
reducePredSet SpanInfo
p "alternative" (Alt PredType -> Doc
forall a. Alt a -> Doc
ppAlt (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 :: HasPosition 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') <- p -> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr p
p Expression a
e TCM (PredSet, Type, Expression PredType)
-> (PredSet -> Type -> StateT TcState Identity PredSet)
-> TCM (PredSet, Expression PredType)
forall a b c. TCM (a, b, c) -> (a -> b -> TCM a) -> TCM (a, c)
>>- p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
unify p
p "guard" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 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 -> [Decl PredType] -> Statement PredType
forall a. SpanInfo -> [Decl a] -> Statement a
StmtDecl SpanInfo
spi [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
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "generator" (Statement a -> Doc
forall a. Statement a -> Doc
ppStmt 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
-> StateT TcState Identity (PredSet, Pattern PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> StateT TcState Identity (PredSet, Pattern PredType)
tcPatternArg p
p "generator" (Statement a -> Doc
forall a. Statement a -> Doc
ppStmt 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 :: HasPosition 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') <- p -> Expression a -> TCM (PredSet, Type, Expression PredType)
forall p a.
HasPosition p =>
p -> Expression a -> TCM (PredSet, Type, Expression PredType)
tcExpr p
p Expression a
e TCM (PredSet, Type, Expression PredType)
-> (PredSet -> Type -> StateT TcState Identity PredSet)
-> TCM (PredSet, Expression PredType)
forall a b c. TCM (a, b, c) -> (a -> b -> TCM a) -> TCM (a, c)
>>-
    p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
unify p
p "statement" (Int -> Expression a -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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 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 -> [Decl PredType] -> Statement PredType
forall a. SpanInfo -> [Decl a] -> Statement a
StmtDecl SpanInfo
spi [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
  (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') <-
    p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Expression a
-> TCM (PredSet, Expression PredType)
tcArg p
p "statement" (Statement a -> Doc
forall a. Statement a -> Doc
ppStmt 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
-> StateT TcState Identity (PredSet, Pattern PredType)
forall p a.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> Pattern a
-> StateT TcState Identity (PredSet, Pattern PredType)
tcPatternArg p
p "statement" (Statement a -> Doc
forall a. Statement a -> Doc
ppStmt 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')

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)

-- The first unification in 'tcField' cannot fail; it serves only for
-- instantiating the type variables in the field label's type.

tcField :: (Position -> a b -> TCM (PredSet, Type, a PredType))
        -> String -> (a b -> Doc) -> Type -> PredSet -> Field (a b)
        -> TCM (PredSet, Field (a PredType))
tcField :: (Position -> a b -> TCM (PredSet, Type, a PredType))
-> String
-> (a b -> Doc)
-> Type
-> PredSet
-> Field (a b)
-> TCM (PredSet, Field (a PredType))
tcField check :: Position -> 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
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
unify SpanInfo
p "field label" Doc
empty PredSet
emptyPredSet Type
ty PredSet
emptyPredSet Type
ty1
  (ps'' :: PredSet
ps'', x' :: a PredType
x') <- Position -> a b -> TCM (PredSet, Type, a PredType)
check (SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos SpanInfo
p) a b
x TCM (PredSet, Type, a PredType)
-> (PredSet -> Type -> StateT TcState Identity PredSet)
-> TCM (PredSet, a PredType)
forall a b c. TCM (a, b, c) -> (a -> b -> TCM a) -> TCM (a, c)
>>-
    SpanInfo
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity 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')

-- The function 'tcArrow' checks that its argument can be used as
-- an arrow type a -> b and returns the pair (a,b).

tcArrow :: HasPosition p => p -> String -> Doc -> Type -> TCM (Type, Type)
tcArrow :: p -> String -> Doc -> Type -> TCM (Type, Type)
tcArrow p :: p
p what :: String
what doc :: Doc
doc ty :: Type
ty = do
  TypeSubst
theta <- TCM TypeSubst
getTypeSubst
  Type -> TCM (Type, Type)
unaryArrow (TypeSubst -> Type -> Type
forall a. SubstType a => TypeSubst -> a -> a
subst TypeSubst
theta Type
ty)
  where
  unaryArrow :: Type -> TCM (Type, Type)
unaryArrow (TypeArrow ty1 :: Type
ty1 ty2 :: Type
ty2) = (Type, Type) -> TCM (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) -> TCM (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.
HasPosition 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 -> TCM (Type, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT TcState Identity Type
freshTypeVar

-- The function 'tcBinary' checks that its argument can be used as an arrow type
-- a -> b -> c and returns the triple (a,b,c).

tcBinary :: HasPosition 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 -> TCM (Type, Type)
forall p.
HasPosition p =>
p -> String -> Doc -> Type -> TCM (Type, Type)
tcArrow p
p String
what Doc
doc Type
ty TCM (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.
HasPosition 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

-- Unification: The unification uses Robinson's algorithm.

unify :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> PredSet
      -> Type -> TCM PredSet
unify :: p
-> String
-> Doc
-> PredSet
-> Type
-> PredSet
-> Type
-> StateT TcState Identity 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.
HasPosition 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 -> StateT TcState Identity PredSet
forall p.
HasPosition p =>
p -> String -> Doc -> PredSet -> StateT TcState Identity PredSet
reducePredSet p
p String
what Doc
doc (PredSet -> StateT TcState Identity PredSet)
-> PredSet -> StateT TcState Identity 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))

-- After performing a unification, the resulting substitution is applied
-- to the current predicate set and the resulting predicate set is subject
-- to a reduction. This predicate set reduction retains all predicates whose
-- types are simple variables and which are not implied but other
-- predicates in the predicate set. For all other predicates, the compiler
-- checks whether an instance exists and replaces them by applying the
-- instances' predicate set to the respective types. A minor complication
-- arises due to constrained types, which at present are used to
-- implement overloading of guard expressions and of numeric literals in
-- patterns. The set of admissible types of a constrained type may be
-- restricted by the current predicate set after the reduction and thus
-- may cause a further extension of the current type substitution.

reducePredSet :: HasPosition p => p -> String -> Doc -> PredSet -> TCM PredSet
reducePredSet :: p -> String -> Doc -> PredSet -> StateT TcState Identity 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 ((Map QualIdent [Type] -> Map QualIdent [Type])
 -> InstEnv' -> InstEnv')
-> (Map QualIdent [Type] -> Map QualIdent [Type])
-> InstEnv'
-> InstEnv'
forall a b. (a -> b) -> a -> b
$ ([Type] -> [Type]) -> Map QualIdent [Type] -> Map QualIdent [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Type] -> [Type])
 -> Map QualIdent [Type] -> Map QualIdent [Type])
-> ([Type] -> [Type])
-> Map QualIdent [Type]
-> Map QualIdent [Type]
forall a b. (a -> b) -> a -> b
$ 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.
HasPosition 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 -> StateT TcState Identity 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 :: HasPosition 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.
HasPosition 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.
HasPosition 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

-- When a constrained type variable that is not free in the type environment
-- disappears from the current type, the type becomes ambiguous. For instance,
-- the type of the expression
--
-- let x = read "" in show x
--
-- is ambiguous assuming that 'read' and 'show' have types
--
-- read :: Read a => String -> a
-- show :: Show a => a -> String
--
-- because the compiler cannot determine which 'Read' and 'Show' instances to
-- use.
--
-- In the case of expressions with an ambiguous numeric type, i.e., a type that
-- must be an instance of 'Num' or one of its subclasses, the compiler tries to
-- resolve the ambiguity by choosing the first type from the list of default
-- types that satisfies all constraints for the ambiguous type variable. An
-- error is reported if no such type exists.

applyDefaults :: HasPosition p => p -> String -> Doc -> Set.Set Int -> PredSet
              -> Type -> TCM PredSet
applyDefaults :: p
-> String
-> Doc
-> Set Int
-> PredSet
-> Type
-> StateT TcState Identity 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.
HasPosition 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 -> StateT TcState Identity 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

-- Instantiation and Generalization:
-- We use negative offsets for fresh type variables.

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]

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)

-- The function 'skol' instantiates the type of data and newtype
-- constructors in patterns. All universally quantified type variables
-- are instantiated with fresh type variables and all existentially
-- quantified type variables are instantiated with fresh skolem types.
-- All constraints that appear on the right hand side of the
-- constructor's declaration are added to the dynamic instance
-- environment.

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

-- The function 'gen' generalizes a predicate set ps and a type tau into
-- a type scheme forall alpha . ps -> tau by universally quantifying all
-- type variables that are free in tau and not fixed by the environment.
-- The set of the latter is given by gvs.

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'

-- Auxiliary Functions:
-- The functions 'constrType', 'varType', 'funType' and 'labelType' are used
-- to retrieve the type of constructors, pattern variables, variables and
-- labels in expressions, respectively, from the value environment. Because
-- the syntactical correctness has already been verified by the syntax checker,
-- none of these functions should fail.

-- Note that 'varType' can handle ambiguous identifiers and returns the first
-- available type. This function is used for looking up the type of an
-- identifier on the left hand side of a rule where it unambiguously refers
-- to the local definition.

-- The function 'constrLabels' returns a list of all labels belonging to a
-- data constructor. The function 'varArity' works like 'varType' but returns
-- a variable's arity instead of its type.

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

-- The function 'expandPoly' handles the expansion of type aliases.

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

-- The function 'splitPredSet' splits a predicate set into a pair of predicate
-- set such that all type variables that appear in the types of the predicates
-- in the first predicate set are elements of a given set of type variables.

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)

-- The functions 'fvEnv' and 'fsEnv' compute the set of free type variables
-- and free skolems of a type environment, respectively. We ignore the types
-- of data constructors here because we know that they are closed.

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]

-- ---------------------------------------------------------------------------
-- Error functions
-- ---------------------------------------------------------------------------

errPolymorphicVar :: Ident -> Message
errPolymorphicVar :: Ident -> Message
errPolymorphicVar v :: Ident
v = Ident -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage 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 :: HasPosition a => a -> ModuleIdent -> Doc -> QualTypeExpr
                     -> TypeScheme -> Message
errTypeSigTooGeneral :: a -> ModuleIdent -> Doc -> QualTypeExpr -> TypeScheme -> Message
errTypeSigTooGeneral p :: a
p m :: ModuleIdent
m what :: Doc
what qty :: QualTypeExpr
qty tySc :: TypeScheme
tySc = a -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage a
p (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
ppQualTypeExpr QualTypeExpr
qty
  ]

errMethodTypeTooSpecific :: HasPosition 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 :: HasPosition 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 :: HasPosition 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 :: HasPosition 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 :: HasPosition a => a -> Ident -> Message
errSkolemFieldLabel :: a -> Ident -> Message
errSkolemFieldLabel p :: a
p l :: Ident
l = a -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage 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 :: HasPosition 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 :: HasPosition 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 :: HasPosition 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 p. HasPosition p => p -> Doc -> Message
posMessage 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
  ]