-- | Typing Module
module SSTG.Core.Language.Typing
    ( module SSTG.Core.Language.Typing
    ) where

import SSTG.Core.Language.Syntax

-- | Typeable typeclass.
class Typeable a where
    typeOf :: a -> Type

-- | `Var` instance of `Typeable`.
instance Typeable Var where
    typeOf (Var _ ty) = ty

-- | `Lit` instance of `Typeable`.
instance Typeable Lit where
    typeOf (MachChar _ ty) = ty
    typeOf (MachStr _ ty) = ty
    typeOf (MachInt _ ty) = ty
    typeOf (MachWord _ ty) = ty
    typeOf (MachFloat _ ty) = ty
    typeOf (MachDouble _ ty) = ty
    typeOf (MachLabel _ _ ty) = ty
    typeOf (MachNullAddr ty) = ty
    typeOf (BlankAddr) = Bottom
    typeOf (AddrLit _) = Bottom
    typeOf (LitEval pfun args) = foldl AppTy (typeOf pfun) (map typeOf args)

-- | `Atom` instance of `Typeable`.
instance Typeable Atom where
    typeOf (LitAtom lit) = typeOf lit
    typeOf (VarAtom var) = typeOf var

-- | `PrimFun` instance of `Typeable`.
instance Typeable PrimFun where
    typeOf (PrimFun _ ty) = ty

-- | `DataCon` instance of `Typeable`.
instance Typeable DataCon where
    typeOf (DataCon _ ty tys) = foldr FunTy ty tys

-- | `Alt` instance of `Typeable`.
instance Typeable Alt where
    typeOf (Alt _ expr) = typeOf expr

-- | `Expr` instance of `Typeable`.
instance Typeable Expr where
    typeOf (Atom atom) = typeOf atom
    typeOf (PrimApp pfun args) = foldl AppTy (typeOf pfun) (map typeOf args)
    typeOf (ConApp dcon args) = foldl AppTy (typeOf dcon) (map typeOf args)
    typeOf (FunApp fun args) = foldl AppTy (typeOf fun) (map typeOf args)
    typeOf (Let _ expr) = typeOf expr
    typeOf (Case _ _ (alt:_)) = typeOf alt
    typeOf _ = Bottom