git.iko.soy/elk
on c19392f help sign in
elk/src/Parse/Type.hs
210 lines 5.4 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 Parse.Primitives (Parser, SParser, addLocation, checkSpace, getPosition, hint, spaces, oneOf)
9import qualified Parse.Primitives as P
10import qualified Parse.Primitives.Symbol as Symbol
11import qualified Parse.Primitives.Variable as Var
12import Parse.Primitives.Whitespace (SPos, whitespace)
14import qualified Reporting.Annotation as A
15import qualified Reporting.Error.Syntax as E
16import qualified Reporting.Region as R
20-- TYPE TERMS
23term :: Parser Type.Raw
24term =
25 hint E.Type $
26 do start <- getPosition
27 oneOf
28 [ app0
29 , variable start
30 , tuple start
31 , record start
32 ]
36-- TYPE VARIABLES
39variable :: R.Position -> Parser Type.Raw
40variable start =
41 do var <- Var.lower
42 end <- getPosition
43 return (A.at start end (Type.RVar var))
47-- TYPE EXPRESSIONS
50expression :: SParser Type.Raw
51expression =
52 hint E.Type $
53 do start <- getPosition
54 (tipe1, end1, pos1) <-
55 oneOf
56 [ app start
57 , (,,) <$> term <*> getPosition <*> whitespace
58 ]
59 oneOf
60 [ do checkSpace pos1
61 Symbol.rightArrow
62 spaces
63 (tipe2, end2, pos2) <- expression
64 let tipe = A.at start end2 (Type.RLambda tipe1 tipe2)
65 return ( tipe, end2, pos2 )
66 , return ( tipe1, end1, pos1 )
67 ]
71-- TYPE CONSTRUCTORS
74app0 :: Parser Type.Raw
75app0 =
76 do start <- getPosition
77 (maybeQualifier, name) <- Var.foreignUpper
78 end <- getPosition
79 return $ A.at start end $
80 Type.RType (R.Region start end) maybeQualifier name []
83app :: R.Position -> SParser Type.Raw
84app start =
85 do (maybeQualifier, name) <- Var.foreignUpper
86 nameEnd <- getPosition
87 namePos <- whitespace
88 (args, end, pos) <- eatArgs [] nameEnd namePos
89 let tipe = Type.RType (R.Region start nameEnd) maybeQualifier name args
90 return ( A.at start end tipe, end, pos )
93unionConstructor :: SParser (A.Located Text, [Type.Raw])
94unionConstructor =
95 do start <- getPosition
96 name <- Var.upper
97 nameEnd <- getPosition
98 namePos <- whitespace
99 (args, end, pos) <- eatArgs [] nameEnd namePos
100 return ( (A.at start nameEnd name, args), end, pos )
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 Symbol.leftParen
122 P.inContext start E.TypeTuple $
123 oneOf
124 [ do Symbol.rightParen
125 end <- getPosition
126 return (A.at start end Type.RUnit)
127 , do spaces
128 (tipe, _, pos) <- expression
129 checkSpace pos
130 tupleEnding start tipe []
131 ]
134tupleEnding :: R.Position -> Type.Raw -> [Type.Raw] -> Parser Type.Raw
135tupleEnding start firstType revTypes =
136 oneOf
137 [ do Symbol.comma
138 spaces
139 (tipe, _, pos) <- expression
140 checkSpace pos
141 tupleEnding start firstType (tipe : revTypes)
142 , do Symbol.rightParen
143 end <- getPosition
144 case reverse revTypes of
145 [] ->
146 return firstType
148 secondType : otherTypes ->
149 return $ A.at start end $
150 Type.RTuple firstType secondType otherTypes
151 ]
155-- RECORD
158record :: R.Position -> Parser Type.Raw
159record start =
160 do Symbol.leftCurly
161 P.inContext start E.TypeRecord $
162 do spaces
163 oneOf
164 [ do Symbol.rightCurly
165 end <- getPosition
166 return (A.at start end (Type.RRecord [] Nothing))
167 , do var <- addLocation Var.lower
168 spaces
169 oneOf
170 [ do Symbol.pipe
171 spaces
172 firstField <- field
173 fields <- chompFields [firstField]
174 end <- getPosition
175 return (A.at start end (Type.RRecord fields (Just (A.map Type.RVar var))))
176 , do Symbol.hasType
177 spaces
178 (tipe, _, nextPos) <- expression
179 checkSpace nextPos
180 fields <- chompFields [(var, tipe)]
181 end <- getPosition
182 return (A.at start end (Type.RRecord fields Nothing))
183 ]
184 ]
187type Field = ( A.Located Text, Type.Raw )
190chompFields :: [Field] -> Parser [Field]
191chompFields fields =
192 oneOf
193 [ do Symbol.comma
194 spaces
195 f <- field
196 chompFields (f : fields)
197 , do Symbol.rightCurly
198 return (reverse fields)
199 ]
202field :: Parser Field
203field =
204 do name <- addLocation Var.lower
205 spaces
206 Symbol.hasType
207 spaces
208 (tipe, _, endPos) <- expression
209 checkSpace endPos
210 return (name, tipe)