module Checker (TypeValue, checker) where

import Data.Map as Map
import Parser
  ( SExpr (..),
  )

data TypeValue
  = TInt
  | TString
  | TBool
  | TFunction TypeValue TypeValue
  | TGeneric String (TypeValue -> Either String TypeValue)
  | TTypeHole
  | TType TypeValue
  | TUnion TypeValue TypeValue
  | TIntersection TypeValue TypeValue

instance Show TypeValue where
  show :: TypeValue -> String
show (TIntersection TypeValue
a TypeValue
b) = String
"TIntersection<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" + " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
  show (TFunction TypeValue
a TypeValue
b) = String
"TFunction<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"><" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
  show (TUnion TypeValue
a TypeValue
b) = String
"TUnion<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" + " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
  show (TGeneric String
a TypeValue -> Either String TypeValue
_) =String
"TGeneric<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
  show (TType TypeValue
a) = String
"TType<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
a String -> ShowS
forall a. [a] -> [a] -> [a]
++  String
">"
  show TypeValue
TInt = String
"TInt"
  show TypeValue
TString = String
"TString"
  show TypeValue
TBool = String
"TBool"
  show TypeValue
TTypeHole = String
"TTypeHole"

instance Eq TypeValue where
  TypeValue
received == :: TypeValue -> TypeValue -> Bool
== TypeValue
expected = case (TypeValue
received, TypeValue
expected) of
    (TIntersection TypeValue
left TypeValue
right, TypeValue
_) -> TypeValue
left TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
expected Bool -> Bool -> Bool
|| TypeValue
right TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
expected
    (TUnion TypeValue
left TypeValue
right, TypeValue
_) -> TypeValue
left TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
expected Bool -> Bool -> Bool
&& TypeValue
right TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
expected
    (TypeValue
_, TIntersection TypeValue
left TypeValue
right) -> TypeValue
received TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
left Bool -> Bool -> Bool
&& TypeValue
received TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
right
    (TypeValue
_, TUnion TypeValue
left TypeValue
right) -> TypeValue
received TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
left Bool -> Bool -> Bool
|| TypeValue
received TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
right
    (TFunction TypeValue
param TypeValue
ret, TFunction TypeValue
param' TypeValue
ret') -> TypeValue
param TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
param' Bool -> Bool -> Bool
&& TypeValue
ret TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
ret'
    (TType TypeValue
received', TType TypeValue
expected') -> TypeValue
received' TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
expected'
    (TypeValue
TString, TypeValue
TString) -> Bool
True
    (TypeValue
TBool, TypeValue
TBool) -> Bool
True
    (TypeValue
TInt, TypeValue
TInt) -> Bool
True
    (TType TypeValue
_, TypeValue
TTypeHole) -> Bool
True
    (TypeValue
TTypeHole, TType TypeValue
_) -> Bool
True
    (TypeValue, TypeValue)
_ -> Bool
False

type Context = Map String TypeValue

checker :: SExpr -> Either String TypeValue
checker :: SExpr -> Either String TypeValue
checker = Context -> SExpr -> Either String TypeValue
typeCheck Context
baseCtx
  where
    baseCtx :: Context
baseCtx = [(String, TypeValue)] -> Context
forall k a. Ord k => [(k, a)] -> Map k a
fromList [
      (String
"print", TypeValue -> TypeValue -> TypeValue
TFunction TypeValue
TString TypeValue
TString)
      ]

typeCheck :: Context -> SExpr -> Either String TypeValue
typeCheck :: Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx (SLetInfer String
name SExpr
value SExpr
next) = do
  TypeValue
value' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
value
  let ctx' :: Context
ctx' = String -> TypeValue -> Context -> Context
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
name TypeValue
value' Context
ctx
  Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx' SExpr
next
typeCheck Context
ctx (SLet String
name SExpr
expectedT SExpr
value SExpr
next) = do
  TypeValue
expectedT' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
expectedT
  TypeValue
receivedT <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
value
  let ctx' :: Context
ctx' = String -> TypeValue -> Context -> Context
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
name TypeValue
receivedT Context
ctx
  if TypeValue
receivedT TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
expectedT'
    then Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx' SExpr
next
    else String -> Either String TypeValue
forall a b. a -> Either a b
Left (String -> Either String TypeValue)
-> String -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ String
"Var<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"> of type <" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
expectedT' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"> trying to be assigned with <" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
receivedT String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
typeCheck Context
ctx (STypeAlias String
name SExpr
t SExpr
next) = do
  TypeValue
t' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
t
  let ctx' :: Context
ctx' = String -> TypeValue -> Context -> Context
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
name (TypeValue -> TypeValue
TType TypeValue
t') Context
ctx
  Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx' SExpr
next
typeCheck Context
ctx (SDefInfer String
param (SType String
"Type") SExpr
body) = do
  let body' :: TypeValue -> Either String TypeValue
body' TypeValue
arg = Context -> SExpr -> Either String TypeValue
typeCheck (String -> TypeValue -> Context -> Context
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
param TypeValue
arg Context
ctx) SExpr
body
  TypeValue -> Either String TypeValue
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeValue -> Either String TypeValue)
-> TypeValue -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ String -> (TypeValue -> Either String TypeValue) -> TypeValue
TGeneric String
param TypeValue -> Either String TypeValue
body'
typeCheck Context
ctx (SDefInfer String
param SExpr
paramT SExpr
body) = do
  TypeValue
paramT' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
paramT
  let ctx' :: Context
ctx' = String -> TypeValue -> Context -> Context
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
param TypeValue
paramT' Context
ctx
  TypeValue
receivedT <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx' SExpr
body
  TypeValue -> Either String TypeValue
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeValue -> Either String TypeValue)
-> TypeValue -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ TypeValue -> TypeValue -> TypeValue
TFunction TypeValue
paramT' TypeValue
receivedT
typeCheck Context
ctx (SDef String
param SExpr
paramT SExpr
retT SExpr
body) = do
  TypeValue
paramT' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
paramT
  TypeValue
retT' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
retT
  let ctx' :: Context
ctx' = String -> TypeValue -> Context -> Context
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
param TypeValue
paramT' Context
ctx
  TypeValue
receivedT <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx' SExpr
body
  if TypeValue
receivedT TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
retT'
    then TypeValue -> Either String TypeValue
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeValue -> Either String TypeValue)
-> TypeValue -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ TypeValue -> TypeValue -> TypeValue
TFunction TypeValue
paramT' TypeValue
retT'
    else String -> Either String TypeValue
forall a b. a -> Either a b
Left (String -> Either String TypeValue)
-> String -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ String
"Function returning <" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
retT' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"> but body with type <" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
receivedT String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
typeCheck Context
ctx (SConditional SExpr
_ SExpr
cthen SExpr
celse) = do
  TypeValue
cthenT <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
cthen
  TypeValue
celseT <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
celse
  TypeValue -> Either String TypeValue
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeValue -> Either String TypeValue)
-> TypeValue -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ TypeValue -> TypeValue -> TypeValue
TUnion TypeValue
cthenT TypeValue
celseT
typeCheck Context
ctx (SApp SExpr
func SExpr
received) = do
  TypeValue
funcT <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
func
  case TypeValue
funcT of
    TGeneric String
_ TypeValue -> Either String TypeValue
body -> do
      TypeValue
receivedT <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
received
      TypeValue -> Either String TypeValue
body (TypeValue -> Either String TypeValue)
-> TypeValue -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ TypeValue -> TypeValue
TType TypeValue
receivedT
    TFunction TypeValue
expectedT TypeValue
retT -> do
      TypeValue
receivedT <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
received
      if TypeValue
receivedT TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
expectedT
        then TypeValue -> Either String TypeValue
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeValue
retT
        else String -> Either String TypeValue
forall a b. a -> Either a b
Left (String -> Either String TypeValue)
-> String -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ String
"Trying to call Function<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SExpr -> String
forall a. Show a => a -> String
show SExpr
func String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"><" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
expectedT String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"> with Param<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
receivedT String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
    TypeValue
t -> String -> Either String TypeValue
forall a b. a -> Either a b
Left (String -> Either String TypeValue)
-> String -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ String
"Applying invalid variable <" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SExpr -> String
forall a. Show a => a -> String
show SExpr
func String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"> of type <" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
typeCheck Context
ctx (SPlus SExpr
x SExpr
y) = do
  TypeValue
x' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
x
  TypeValue
y' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
y
  if TypeValue
x' TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
TInt Bool -> Bool -> Bool
&& TypeValue
y' TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
TInt 
    then TypeValue -> Either String TypeValue
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeValue
TInt
    else String -> Either String TypeValue
forall a b. a -> Either a b
Left (String -> Either String TypeValue)
-> String -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ String
"Calling sum with invalid params: [ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
x' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SExpr -> String
forall a. Show a => a -> String
show SExpr
y String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ]"
typeCheck Context
ctx (SMinus SExpr
x SExpr
y) = do
  TypeValue
x' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
x
  TypeValue
y' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
y
  if TypeValue
x' TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
TInt Bool -> Bool -> Bool
&& TypeValue
y' TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
TInt 
    then TypeValue -> Either String TypeValue
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeValue
TInt
    else String -> Either String TypeValue
forall a b. a -> Either a b
Left (String -> Either String TypeValue)
-> String -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ String
"Calling subtraction with invalid params: [ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
x' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
y' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ]"
typeCheck Context
ctx (SDiv SExpr
x SExpr
y) = do
  TypeValue
x' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
x
  TypeValue
y' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
y
  if TypeValue
x' TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
TInt Bool -> Bool -> Bool
&& TypeValue
y' TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
TInt 
    then TypeValue -> Either String TypeValue
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeValue
TInt
    else String -> Either String TypeValue
forall a b. a -> Either a b
Left (String -> Either String TypeValue)
-> String -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ String
"Calling division with invalid params: [ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
x' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SExpr -> String
forall a. Show a => a -> String
show SExpr
y String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ]"
typeCheck Context
ctx (STimes SExpr
x SExpr
y) = do
  TypeValue
x' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
x
  TypeValue
y' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
y
  if TypeValue
x' TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
TInt Bool -> Bool -> Bool
&& TypeValue
y' TypeValue -> TypeValue -> Bool
forall a. Eq a => a -> a -> Bool
== TypeValue
TInt 
    then TypeValue -> Either String TypeValue
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeValue
TInt
    else String -> Either String TypeValue
forall a b. a -> Either a b
Left (String -> Either String TypeValue)
-> String -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ String
"Calling multiplication with invalid params: [ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
x' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
y' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ]"
typeCheck Context
ctx (SAnd SExpr
x SExpr
y) = do
  TypeValue
x' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
x
  TypeValue
y' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
y
  TypeValue -> Either String TypeValue
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeValue -> Either String TypeValue)
-> TypeValue -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ TypeValue -> TypeValue -> TypeValue
TUnion TypeValue
x' TypeValue
y'
typeCheck Context
ctx (SOr SExpr
x SExpr
y) = do
  TypeValue
x' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
x
  TypeValue
y' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
y
  TypeValue -> Either String TypeValue
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeValue -> Either String TypeValue)
-> TypeValue -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ TypeValue -> TypeValue -> TypeValue
TUnion TypeValue
x' TypeValue
y'
typeCheck Context
ctx (SBrack SExpr
expr) = Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
expr
typeCheck Context
ctx (SName String
name) = case String -> Context -> Maybe TypeValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name Context
ctx of
  Just TypeValue
t -> TypeValue -> Either String TypeValue
forall a b. b -> Either a b
Right TypeValue
t
  Maybe TypeValue
Nothing -> String -> Either String TypeValue
forall a b. a -> Either a b
Left (String -> Either String TypeValue)
-> String -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ String
"Variable not initialized: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name
typeCheck Context
_ (SInt Integer
_) = TypeValue -> Either String TypeValue
forall a b. b -> Either a b
Right TypeValue
TInt
typeCheck Context
_ (SBool Bool
_) = TypeValue -> Either String TypeValue
forall a b. b -> Either a b
Right TypeValue
TBool
typeCheck Context
_ (SString String
_) = TypeValue -> Either String TypeValue
forall a b. b -> Either a b
Right TypeValue
TString
typeCheck Context
ctx (STypeIntersection SExpr
l SExpr
r) = do
  TypeValue
l' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
l
  TypeValue
r' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
r
  TypeValue -> Either String TypeValue
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeValue -> Either String TypeValue)
-> TypeValue -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ TypeValue -> TypeValue -> TypeValue
TIntersection TypeValue
l' TypeValue
r'
typeCheck Context
ctx (STypeUnion SExpr
l SExpr
r) = do
  TypeValue
l' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
l
  TypeValue
r' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
r
  TypeValue -> Either String TypeValue
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeValue -> Either String TypeValue)
-> TypeValue -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ TypeValue -> TypeValue -> TypeValue
TUnion TypeValue
l' TypeValue
r'
typeCheck Context
ctx (STypeof SExpr
expr) = Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
expr
typeCheck Context
_ (SType String
"Int") = TypeValue -> Either String TypeValue
forall a b. b -> Either a b
Right TypeValue
TInt
typeCheck Context
_ (SType String
"String") = TypeValue -> Either String TypeValue
forall a b. b -> Either a b
Right TypeValue
TString
typeCheck Context
_ (SType String
"Bool") = TypeValue -> Either String TypeValue
forall a b. b -> Either a b
Right TypeValue
TBool
typeCheck Context
_ (SType String
"Type") = TypeValue -> Either String TypeValue
forall a b. b -> Either a b
Right TypeValue
TTypeHole
typeCheck Context
ctx (SType String
t) = do
  case String -> Context -> Maybe TypeValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
t Context
ctx of
    Just (TType TypeValue
t') -> TypeValue -> Either String TypeValue
forall a b. b -> Either a b
Right TypeValue
t'
    Just (TypeValue
TTypeHole) -> TypeValue -> Either String TypeValue
forall a b. b -> Either a b
Right TypeValue
TTypeHole
    Just TypeValue
t' -> String -> Either String TypeValue
forall a b. a -> Either a b
Left (String -> Either String TypeValue)
-> String -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ String
"Trying to type with a value <" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"> as: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeValue -> String
forall a. Show a => a -> String
show TypeValue
t'
    Maybe TypeValue
Nothing -> String -> Either String TypeValue
forall a b. a -> Either a b
Left (String -> Either String TypeValue)
-> String -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ String
"Type not implemented: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t
typeCheck Context
ctx (STypeFunc SExpr
t SExpr
r) = do
  TypeValue
t' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
t
  TypeValue
r' <- Context -> SExpr -> Either String TypeValue
typeCheck Context
ctx SExpr
r
  TypeValue -> Either String TypeValue
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeValue -> Either String TypeValue)
-> TypeValue -> Either String TypeValue
forall a b. (a -> b) -> a -> b
$ TypeValue -> TypeValue -> TypeValue
TFunction TypeValue
t' TypeValue
r'