97 lines
2.1 KiB
Haskell
97 lines
2.1 KiB
Haskell
{-# LANGUAGE GeneralizedNewtypeDeriving, LambdaCase #-}
|
|
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
|
|
module Type
|
|
( module Type
|
|
, Id(..)
|
|
) where
|
|
|
|
import Control.Monad.Reader
|
|
import Control.Monad.State
|
|
import Control.Monad.Except
|
|
|
|
import Data.Map (Map)
|
|
import Data.Set (Set)
|
|
import Data.Text (Text)
|
|
|
|
import Hm.Abs (Id(..))
|
|
|
|
import qualified Hm.Abs as H (TypeSig'(..), TypeSig(..))
|
|
|
|
data PolyT
|
|
= Forall (Set Id) MonoT -- ^ ∀ σ₁ σ₂ … σₙ. τ
|
|
| Mono MonoT -- ^ τ
|
|
deriving Show
|
|
|
|
infixr `TArr`
|
|
data MonoT
|
|
= TArr MonoT MonoT -- ^ function
|
|
| TVar Id -- ^ variable
|
|
| TCon Id -- ^ constant
|
|
deriving Show
|
|
|
|
type Pos = Maybe (Int, Int)
|
|
|
|
type TL = TL' Pos
|
|
data TL' a
|
|
= TypeDef a Id [Id] TypeEnv -- ^ name, parameters, constructors and recursor
|
|
| VarDef a Id PolyT Exp -- ^ name, declared type, expression
|
|
deriving Show
|
|
|
|
type Exp = Exp' Pos
|
|
data Exp' a
|
|
= Let a [(Id,Exp)] Exp
|
|
| Abs a [Id] Exp
|
|
| App a Exp Exp
|
|
| Var a Id
|
|
deriving Show
|
|
|
|
class Positioned p where
|
|
pos :: p -> Pos
|
|
|
|
instance Positioned TL where
|
|
pos = \case
|
|
TypeDef p _ _ _ -> p
|
|
VarDef p _ _ _ -> p
|
|
|
|
instance Positioned Exp where
|
|
pos = \case
|
|
Let p _ _ -> p
|
|
Abs p _ _ -> p
|
|
App p _ _ -> p
|
|
Var p _ -> p
|
|
|
|
instance Positioned Pos where
|
|
pos = id
|
|
|
|
instance Positioned H.TypeSig where
|
|
pos = \case
|
|
H.TypeFun p _ _ -> p
|
|
H.TypeApp p _ _ -> p
|
|
H.TypeVar p _ -> p
|
|
|
|
data TypeError
|
|
= Oop -- ^ compiler error (oops)
|
|
| UnificationFailure MonoT MonoT
|
|
| InfiniteType Id MonoT
|
|
| UnboundVariable Id
|
|
| Unimplemented Text
|
|
| InvalidTypeDecl
|
|
| InvalidConstructor
|
|
| ArityMismatch
|
|
deriving Show
|
|
|
|
type TypeEnv = Map Id PolyT
|
|
|
|
type Subst = Map Id MonoT
|
|
|
|
data CheckState = CS { variables :: [Id]
|
|
, lastPos :: Pos
|
|
, typeEnv :: TypeEnv
|
|
} deriving Show
|
|
|
|
newtype Check a = Check { getCheck :: ExceptT TypeError (State CheckState) a }
|
|
deriving (Functor, Applicative, Monad, MonadError TypeError, MonadState CheckState)
|
|
|
|
instance MonadFail Check where
|
|
fail _ = throwError Oop
|