{-# 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