git.iko.soy/elk
on 00a3069 help sign in
elk/src/Parse/Type.hs
225 lines 5.7 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.Source as Src
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 Src.Type
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 Src.Type
40variable start =
41 do var <- Var.lower
42 end <- getPosition
43 return (A.at start end (Src.TVar var))
47-- TYPE EXPRESSIONS
50expression :: SParser Src.Type
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 (Src.TLambda tipe1 tipe2)
65 return ( tipe, end2, pos2 )
66 , return ( tipe1, end1, pos1 )
67 ]
71-- TYPE CONSTRUCTORS
74app0 :: Parser Src.Type
75app0 =
76 do start <- getPosition
77 upper <- Var.foreignUpper
78 end <- getPosition
79 let region = R.Region start end
80 return $ A.At region $
81 case upper of
82 Var.Unqualified name ->
83 Src.TType region name []
85 Var.Qualified home name ->
86 Src.TTypeQual region home name []
89app :: R.Position -> SParser Src.Type
90app start =
91 do upper <- Var.foreignUpper
92 nameEnd <- getPosition
93 namePos <- whitespace
94 (args, end, pos) <- eatArgs [] nameEnd namePos
96 let region = R.Region start nameEnd
97 let tipe =
98 case upper of
99 Var.Unqualified name ->
100 Src.TType region name args
102 Var.Qualified home name ->
103 Src.TTypeQual region home name args
105 return ( A.at start end tipe, end, pos )
108unionConstructor :: SParser (A.Located Text, [Src.Type])
109unionConstructor =
110 do start <- getPosition
111 name <- Var.upper
112 nameEnd <- getPosition
113 namePos <- whitespace
114 (args, end, pos) <- eatArgs [] nameEnd namePos
115 return ( (A.at start nameEnd name, args), end, pos )
118eatArgs :: [Src.Type] -> R.Position -> SPos -> SParser [Src.Type]
119eatArgs args end pos =
120 oneOf
121 [ do checkSpace pos
122 arg <- term
123 newEnd <- getPosition
124 newSpace <- whitespace
125 eatArgs (arg:args) newEnd newSpace
126 , return ( reverse args, end, pos )
127 ]
131-- TUPLES
134tuple :: R.Position -> Parser Src.Type
135tuple start =
136 do Symbol.leftParen
137 P.inContext start E.TypeTuple $
138 oneOf
139 [ do Symbol.rightParen
140 end <- getPosition
141 return (A.at start end Src.TUnit)
142 , do spaces
143 (tipe, _, pos) <- expression
144 checkSpace pos
145 tupleEnding start tipe []
146 ]
149tupleEnding :: R.Position -> Src.Type -> [Src.Type] -> Parser Src.Type
150tupleEnding start firstType revTypes =
151 oneOf
152 [ do Symbol.comma
153 spaces
154 (tipe, _, pos) <- expression
155 checkSpace pos
156 tupleEnding start firstType (tipe : revTypes)
157 , do Symbol.rightParen
158 end <- getPosition
159 case reverse revTypes of
160 [] ->
161 return firstType
163 secondType : otherTypes ->
164 return $ A.at start end $
165 Src.TTuple firstType secondType otherTypes
166 ]
170-- RECORD
173record :: R.Position -> Parser Src.Type
174record start =
175 do Symbol.leftCurly
176 P.inContext start E.TypeRecord $
177 do spaces
178 oneOf
179 [ do Symbol.rightCurly
180 end <- getPosition
181 return (A.at start end (Src.TRecord [] Nothing))
182 , do var <- addLocation Var.lower
183 spaces
184 oneOf
185 [ do Symbol.pipe
186 spaces
187 firstField <- field
188 fields <- chompFields [firstField]
189 end <- getPosition
190 return (A.at start end (Src.TRecord fields (Just (A.map Src.TVar var))))
191 , do Symbol.hasType
192 spaces
193 (tipe, _, nextPos) <- expression
194 checkSpace nextPos
195 fields <- chompFields [(var, tipe)]
196 end <- getPosition
197 return (A.at start end (Src.TRecord fields Nothing))
198 ]
199 ]
202type Field = ( A.Located Text, Src.Type )
205chompFields :: [Field] -> Parser [Field]
206chompFields fields =
207 oneOf
208 [ do Symbol.comma
209 spaces
210 f <- field
211 chompFields (f : fields)
212 , do Symbol.rightCurly
213 return (reverse fields)
214 ]
217field :: Parser Field
218field =
219 do name <- addLocation Var.lower
220 spaces
221 Symbol.hasType
222 spaces
223 (tipe, _, endPos) <- expression
224 checkSpace endPos
225 return (name, tipe)