git.iko.soy/elk
on cbfbd0a help sign in
elk/elm/src/Types/Types.hs
114 lines 3.2 kB history raw
2module Types.Types where
4import Context
5import Data.Char (isDigit)
6import Data.List (intercalate,isPrefixOf)
7import qualified Data.Set as Set
8import qualified Data.Map as Map
10type X = Int
12data Type = LambdaT Type Type
13 | VarT X
14 | ADT String [Type]
15 | EmptyRecord
16 | RecordT (Map.Map String [Type]) Type
17 | Super (Set.Set Type)
18 deriving (Eq, Ord)
20data Scheme = Forall [X] [Context Constraint] Type deriving (Eq, Ord)
22data Constraint = Type :=: Type
23 | Type :<: Type
24 | X :<<: Scheme
25 deriving (Eq, Ord, Show)
27tipe t = ADT t []
30int = tipe "Int"
31float = tipe "Float"
32number = Super (Set.fromList [ int, float ])
34char = tipe "Char"
35bool = tipe "Bool"
37string = listOf char -- tipe "String"
38text = tipe "Text"
40time = float --tipe "Time"
41date = tipe "Date"
42month = tipe "Month"
43day = tipe "Day"
45element = tipe "Element"
46direction = tipe "Direction"
47form = tipe "Form"
48line = tipe "Line"
49shape = tipe "Shape"
50color = tipe "Color"
51position = tipe "Position"
52location = tipe "Location"
54listOf t = ADT "List" [t]
55signalOf t = ADT "Signal" [t]
56tupleOf ts = ADT ("Tuple" ++ show (length ts)) ts
57maybeOf t = ADT "Maybe" [t]
58pairOf t = tupleOf [t,t]
59point = pairOf int
60appendable t = Super (Set.fromList [ string, text, listOf t ])
61comparable = Super (Set.fromList [ int, float, char, string, time, date ])
63jsBool = tipe "JSBool"
64jsNumber = tipe "JSNumber"
65jsString = tipe "JSString"
66jsElement = tipe "JSElement"
67jsArray t = ADT "JSArray" [t]
68jsTuple ts = ADT ("JSTuple" ++ show (length ts)) ts
69jsonValue = tipe "JsonValue"
70jsonObject = tipe "JsonObject"
72infixr ==>
73t1 ==> t2 = LambdaT t1 t2
75infix 8 -:
76name -: tipe = (,) name $ Forall [] [] tipe
78hasType t = map (-: t)
80parens = ("("++) . (++")")
82instance Show Type where
83 show t =
84 case t of
85 { LambdaT t1@(LambdaT _ _) t2 -> parens (show t1) ++ " -> " ++ show t2
86 ; LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2
87 ; VarT x -> 't' : show x
88 ; ADT "List" [ADT "Char" []] -> "String"
89 ; ADT "List" [tipe] -> "[" ++ show tipe ++ "]"
90 ; ADT name cs ->
91 if isTupleString name
92 then parens . intercalate "," $ map show cs
93 else case cs of
94 [] -> name
95 _ -> parens $ name ++ " " ++ unwords (map show cs)
96 ; Super ts -> "{" ++ (intercalate "," . map show $ Set.toList ts) ++ "}"
97 ; EmptyRecord -> "{}"
98 ; RecordT fs t ->
99 start ++ intercalate ", " (concatMap fields $ Map.toList fs) ++ " }"
100 where field n s = n ++ " :: " ++ show s
101 fields (n,ss) = map (field n) ss
102 start = case t of
103 EmptyRecord -> "{ "
104 _ -> "{ " ++ show t ++ " | "
105 }
107instance Show Scheme where
108 show (Forall [] [] t) = show t
109 show (Forall xs cs t) =
110 concat [ "Forall ", show xs
111 , concatMap (("\n "++) . show) cs
112 , "\n ", parens (show t) ]
114isTupleString str = "Tuple" `isPrefixOf` str && all isDigit (drop 5 str)