Carp/src/SumtypeCase.hs at v0.5.2_Windows · carp-lang/Carp · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
module SumtypeCase where

import Obj
import TypeError
import Types
import Validate

data SumtypeCase = SumtypeCase
  { caseName :: String,
    caseTys :: [Ty]
  }
  deriving (Show, Eq)

toCases :: TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> [XObj] -> Either TypeError [SumtypeCase]
toCases typeEnv globalEnv restriction typeVars = mapM (toCase typeEnv globalEnv restriction typeVars)

toCase :: TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> XObj -> Either TypeError SumtypeCase
toCase typeEnv globalEnv restriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) =
  let tys = map xobjToTy tyXObjs
   in case sequence tys of
        Nothing ->
          Left (InvalidSumtypeCase x)
        Just okTys ->
          let validated = map (\t -> canBeUsedAsMemberType restriction typeEnv globalEnv typeVars t x) okTys
           in case sequence validated of
                Left e ->
                  Left e
                Right _ ->
                  Right $
                    SumtypeCase
                      { caseName = name,
                        caseTys = okTys
                      }
toCase _ _ _ _ (XObj (Sym (SymPath [] name) Symbol) _ _) =
  Right $
    SumtypeCase
      { caseName = name,
        caseTys = []
      }
toCase _ _ _ _ x =
  Left (InvalidSumtypeCase x)