git.iko.soy/elk
on e00a3f3 help sign in
elk/src/Parse/Type.hs
209 lines 4.9 kB history raw
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Parse.Type (expression, unionConstructor) where
5import Data.Text (Text)
7import qualified AST.Type as Type
8import qualified AST.Variable as Var
9import Parse.Helpers
10import qualified Reporting.Annotation as A
11import qualified Reporting.Error.Syntax as E
12import qualified Reporting.Region as R
16-- TYPE TERMS
19term :: Parser Type.Raw
20term =
21 hint E.Type $
22 do start <- getPosition
23 oneOf
24 [ constructor
25 , variable start
26 , tuple start
27 , record start
28 ]
32-- TYPE VARIABLES
35variable :: R.Position -> Parser Type.Raw
36variable start =
37 do var <- lowVar
38 end <- getPosition
39 return (A.at start end (Type.RVar var))
43-- TYPE EXPRESSIONS
46expression :: SParser Type.Raw
47expression =
48 hint E.Type $
49 do start <- getPosition
50 (tipe1, end1, pos1) <-
51 oneOf
52 [ app start
53 , (,,) <$> term <*> getPosition <*> whitespace
54 ]
55 oneOf
56 [ do checkSpace pos1
57 rightArrow
58 spaces
59 (tipe2, end2, pos2) <- expression
60 let tipe = A.at start end2 (Type.RLambda tipe1 tipe2)
61 return ( tipe, end2, pos2 )
62 , return ( tipe1, end1, pos1 )
63 ]
67-- TYPE CONSTRUCTORS
70constructor :: Parser Type.Raw
71constructor =
72 addLocation $
73 fmap (Type.RType . Var.Raw) qualifiedCapVar
76app :: R.Position -> SParser Type.Raw
77app start =
78 do ctor <- constructor
79 ctorEnd <- getPosition
80 ctorPos <- whitespace
81 (args, end, pos) <- eatArgs [] ctorEnd ctorPos
82 case args of
83 [] ->
84 return ( ctor, end, pos )
86 _ ->
87 let
88 tipe =
89 A.at start end (Type.RApp ctor args)
90 in
91 return ( tipe, end, pos )
94unionConstructor :: SParser (Text, [Type.Raw])
95unionConstructor =
96 do ctor <- capVar
97 ctorEnd <- getPosition
98 ctorSpace <- whitespace
99 (args, end, space) <- eatArgs [] ctorEnd ctorSpace
100 return ( (ctor, args), end, space )
103eatArgs :: [Type.Raw] -> R.Position -> SPos -> SParser [Type.Raw]
104eatArgs args end pos =
105 oneOf
106 [ do checkSpace pos
107 arg <- term
108 newEnd <- getPosition
109 newSpace <- whitespace
110 eatArgs (arg:args) newEnd newSpace
111 , return ( reverse args, end, pos )
112 ]
116-- TUPLES
119tuple :: R.Position -> Parser Type.Raw
120tuple start =
121 do leftParen
122 inContext start E.TypeTuple $
123 oneOf
124 [ do rightParen
125 end <- getPosition
126 return (Type.tuple (R.Region start end) [])
127 , do spaces
128 (tipe, _, pos) <- expression
129 checkSpace pos
130 tupleEnding start [tipe]
131 ]
134tupleEnding :: R.Position -> [Type.Raw] -> Parser Type.Raw
135tupleEnding start tipes =
136 oneOf
137 [ do comma
138 spaces
139 (tipe, _, pos) <- expression
140 checkSpace pos
141 tupleEnding start (tipe : tipes)
142 , do rightParen
143 end <- getPosition
144 case reverse tipes of
145 [tipe] ->
146 return tipe
148 tupleTypes ->
149 return (Type.tuple (R.Region start end) tupleTypes)
150 ]
154-- RECORD
157record :: R.Position -> Parser Type.Raw
158record start =
159 do leftCurly
160 inContext start E.TypeRecord $
161 do spaces
162 oneOf
163 [ do rightCurly
164 end <- getPosition
165 return (A.at start end (Type.RRecord [] Nothing))
166 , do var <- addLocation lowVar
167 spaces
168 oneOf
169 [ do pipe
170 spaces
171 firstField <- field
172 fields <- chompFields [firstField]
173 end <- getPosition
174 return (A.at start end (Type.RRecord fields (Just (A.map Type.RVar var))))
175 , do hasType
176 spaces
177 (tipe, _, nextPos) <- expression
178 checkSpace nextPos
179 fields <- chompFields [(var, tipe)]
180 end <- getPosition
181 return (A.at start end (Type.RRecord fields Nothing))
182 ]
183 ]
186type Field = ( A.Located Text, Type.Raw )
189chompFields :: [Field] -> Parser [Field]
190chompFields fields =
191 oneOf
192 [ do comma
193 spaces
194 f <- field
195 chompFields (f : fields)
196 , do rightCurly
197 return (reverse fields)
198 ]
201field :: Parser Field
202field =
203 do name <- addLocation lowVar
204 spaces
205 hasType
206 spaces
207 (tipe, _, endPos) <- expression
208 checkSpace endPos
209 return (name, tipe)