never executed always true always false
1 {-# LANGUAGE DataKinds #-}
2 module Parse.Module (moduleDecl, elmModule, topLevel, import') where
3
4 import qualified Control.Applicative
5 import Data.Map.Strict ( Map, empty, insert, insertWith )
6 import Elm.Utils ((|>))
7 import Text.Parsec ( char, letter, string, choice, eof, option, optionMaybe, (<?>), (<|>), many, try )
8 import Parse.Helpers
9 import qualified Parse.Declaration as Decl
10 import AST.Listing (Listing(..), mergeCommentedMap, mergeListing)
11 import qualified AST.Listing as Listing
12 import AST.Module (DetailedListing, Module, ImportMethod)
13 import qualified AST.Module as Module
14 import AST.Structure
15 import AST.V0_16
16 import qualified Data.Indexed as I
17 import ElmVersion
18 import Parse.IParser
19 import Parse.Whitespace
20 import Reporting.Annotation (Located)
21
22
23 elmModule :: ElmVersion -> IParser (Module [UppercaseIdentifier] (ASTNS Located [UppercaseIdentifier] 'TopLevelNK))
24 elmModule elmVersion =
25 do preModule <- option [] freshLine
26 h <- moduleDecl elmVersion
27 preDocsComments <- option [] freshLine
28 (docs, postDocsComments) <-
29 choice
30 [ (,) <$> addLocation (Just <$> docCommentAsMarkdown) <*> freshLine
31 , (,) <$> addLocation (return Nothing) <*> return []
32 ]
33 (preImportComments, imports', postImportComments) <- imports elmVersion
34 topLevels <-
35 fmap I.Fix $
36 addLocation $
37 fmap TopLevel $
38 do
39 decls <- topLevel $ Decl.declaration elmVersion
40 trailingComments <-
41 (++)
42 <$> option [] freshLine
43 <*> option [] spaces
44 eof
45 return ((map BodyComment postImportComments) ++ decls ++ (map BodyComment trailingComments))
46
47 return $
48 Module.Module
49 preModule
50 h
51 docs
52 (C (preDocsComments ++ postDocsComments ++ preImportComments) imports')
53 topLevels
54
55
56 topLevel :: IParser a -> IParser [TopLevelStructure a]
57 topLevel entry =
58 (++) <$> option [] (((\x -> [x]) <$> Decl.topLevelStructure entry))
59 <*> (concat <$> many (freshDef entry))
60
61
62 freshDef :: IParser a -> IParser [TopLevelStructure a]
63 freshDef entry =
64 commitIf (freshLine >> (letter <|> char '_')) $
65 do comments <- freshLine
66 decl <- Decl.topLevelStructure entry
67 return $ (map BodyComment comments) ++ [decl]
68
69
70 moduleDecl :: ElmVersion -> IParser (Maybe Module.Header)
71 moduleDecl elmVersion =
72 choice
73 [ try $ Just <$> moduleDecl_0_16 elmVersion
74 , Just <$> moduleDecl_0_17 elmVersion
75 , return Nothing
76 ]
77
78
79 moduleDecl_0_16 :: ElmVersion -> IParser Module.Header
80 moduleDecl_0_16 elmVersion =
81 expecting "a module declaration" $
82 do try (reserved elmVersion "module")
83 preName <- whitespace
84 names <- dotSep1 (capVar elmVersion) <?> "the name of this module"
85 postName <- whitespace
86 exports <- option (OpenListing (C ([], []) ())) (listing $ detailedListing elmVersion)
87 preWhere <- whitespace
88 reserved elmVersion "where"
89 return $
90 Module.Header
91 Module.Normal
92 (C (preName, postName) names)
93 Nothing
94 (Just $ C (preWhere, []) exports)
95
96
97 moduleDecl_0_17 :: ElmVersion -> IParser Module.Header
98 moduleDecl_0_17 elmVersion =
99 expecting "a module declaration" $
100 do
101 srcTag <-
102 try $
103 choice
104 [ Module.Port <$> (reserved elmVersion "port" *> whitespace)
105 , Module.Effect <$> (reserved elmVersion "effect" *> whitespace)
106 , return Module.Normal
107 ]
108 <* reserved elmVersion "module"
109 preName <- whitespace
110 names <- dotSep1 (capVar elmVersion) <?> "the name of this module"
111 whereClause <-
112 optionMaybe $
113 commentedKeyword elmVersion "where" $
114 brackets $ (\f pre post _ -> f pre post) <$> commaSep1 (keyValue equals (lowVar elmVersion) (capVar elmVersion))
115
116 exports <-
117 optionMaybe $
118 commentedKeyword elmVersion "exposing" (listing $ detailedListing elmVersion)
119 <|> try (listingWithoutExposing elmVersion)
120
121 return $
122 Module.Header
123 srcTag
124 (C (preName, []) names)
125 whereClause
126 exports
127
128 listingWithoutExposing :: ElmVersion -> IParser (C2 beforeKeyword afterKeyword (Listing DetailedListing))
129 listingWithoutExposing elmVersion = do
130 let pre = []
131 post <- whitespace
132 C (pre, post) <$> listing (detailedListing elmVersion)
133
134 mergePreCommented :: (a -> a -> a) -> C1 before a -> C1 before a -> C1 before a
135 mergePreCommented merge (C pre1 left) (C pre2 right) =
136 C (pre1 ++ pre2) (merge left right)
137
138 mergeC2 :: (a -> b -> c) -> C2 before after a -> C2 before after b -> C2 before after c
139 mergeC2 merge (C (pre1, post1) left) (C (pre2, post2) right) =
140 C (pre1 ++ pre2, post1 ++ post2) (merge left right)
141
142
143 mergeDetailedListing :: Module.DetailedListing -> Module.DetailedListing -> Module.DetailedListing
144 mergeDetailedListing left right =
145 Module.DetailedListing
146 (mergeCommentedMap (<>) (Module.values left) (Module.values right))
147 (mergeCommentedMap (<>) (Module.operators left) (Module.operators right))
148 (mergeCommentedMap (mergePreCommented $ mergeListing $ mergeCommentedMap (<>)) (Module.types left) (Module.types right))
149
150
151 imports :: ElmVersion -> IParser (Comments, Map [UppercaseIdentifier] (C1 'BeforeTerm ImportMethod), Comments)
152 imports elmVersion =
153 let
154 merge :: C1 'BeforeTerm ImportMethod -> C1 'BeforeTerm ImportMethod -> C1 'BeforeTerm ImportMethod
155 merge (C comments1 import1) (C comments2 import2) =
156 C (comments1 ++ comments2) $
157 Module.ImportMethod
158 (Module.alias import1 Control.Applicative.<|> Module.alias import2)
159 (mergeC2 (mergeListing mergeDetailedListing) (Module.exposedVars import1) (Module.exposedVars import2))
160
161 step (comments, m, finalComments) (((C pre name), method), post) =
162 ( comments ++ finalComments
163 , insertWith merge name (C pre method) m
164 , post
165 )
166
167 done :: [(Module.UserImport, Comments)] -> (Comments, Map [UppercaseIdentifier] (C1 'BeforeTerm ImportMethod), Comments)
168 done results =
169 foldl step ([], empty, []) results
170 in
171 done <$> many ((,) <$> import' elmVersion <*> freshLine)
172
173
174 import' :: ElmVersion -> IParser Module.UserImport
175 import' elmVersion =
176 expecting "an import" $
177 do try (reserved elmVersion "import")
178 preName <- whitespace
179 names <- dotSep1 $ capVar elmVersion
180 method' <- method names
181 return (C preName names, method')
182 where
183 method :: [UppercaseIdentifier] -> IParser Module.ImportMethod
184 method originalName =
185 Module.ImportMethod
186 <$> option Nothing (Just <$> as' originalName)
187 <*> option (C ([], []) ClosedListing) (exposing <|> try (listingWithoutExposing elmVersion))
188
189 as' :: [UppercaseIdentifier] -> IParser (C2 'BeforeSeparator 'AfterSeparator UppercaseIdentifier)
190 as' moduleName =
191 do preAs <- try (whitespace <* reserved elmVersion "as")
192 postAs <- whitespace
193 C (preAs, postAs) <$> capVar elmVersion <?> ("an alias for module `" ++ show moduleName ++ "`") -- TODO: do something correct instead of show
194
195 exposing :: IParser (C2 'BeforeSeparator 'AfterSeparator (Listing Module.DetailedListing))
196 exposing =
197 do preExposing <- try (whitespace <* reserved elmVersion "exposing")
198 postExposing <- whitespace
199 imports <-
200 choice
201 [ listing $ detailedListing elmVersion
202 , listingWithoutParens elmVersion
203 ]
204 return $ C (preExposing, postExposing) imports
205
206
207 listing :: IParser (Comments -> Comments -> a) -> IParser (Listing a)
208 listing explicit =
209 let
210 subparser = choice
211 [ (\_ pre post _ -> (OpenListing (C (pre, post) ()))) <$> string ".."
212 , (\x pre post sawNewline -> (ExplicitListing (x pre post) sawNewline)) <$>
213 explicit
214 ]
215 in
216 expecting "a listing of values and types to expose, like (..)" $
217 do _ <- try (char '(')
218 ((pre, listing, post), multiline) <- trackNewline ((,,) <$> whitespace <*> subparser <*> whitespace)
219 _ <- char ')'
220 return $ listing pre post $ multilineToBool multiline
221
222
223 listingWithoutParens :: ElmVersion -> IParser (Listing Module.DetailedListing)
224 listingWithoutParens elmVersion =
225 expecting "a listing of values and types to expose, but with missing parentheses" $
226 choice
227 [ (\_ -> (OpenListing (C ([], []) ()))) <$> string ".."
228 , (\x -> (ExplicitListing (x [] []) False)) <$> detailedListing elmVersion
229 ]
230
231
232 commentedSet :: Ord a => IParser a -> IParser (Comments -> Comments -> Listing.CommentedMap a ())
233 commentedSet item =
234 commaSep1Set' ((\x -> (x, ())) <$> item) (\() () -> ())
235
236
237 detailedListing :: ElmVersion -> IParser (Comments -> Comments -> Module.DetailedListing)
238 detailedListing elmVersion =
239 do
240 values <- commaSep1' (value elmVersion)
241 return $ \pre post -> toDetailedListing $ values pre post
242
243
244 toDetailedListing :: [C2 before after Listing.Value] -> Module.DetailedListing
245 toDetailedListing values =
246 let
247 merge
248 (C (pre1, post1) (C inner1 tags1))
249 (C (pre2, post2) (C inner2 tags2))
250 =
251 C (pre1 ++ pre2, post1 ++ post2) $
252 C (inner1 ++ inner2) $
253 mergeListing (mergeCommentedMap (<>)) tags1 tags2
254
255 step (vs, os, ts) (C (pre, post) val) =
256 case val of
257 Listing.Value name ->
258 (insert name (C (pre, post) ()) vs, os, ts)
259 Listing.OpValue name ->
260 (vs, insert name (C (pre, post) ()) os, ts)
261 Listing.Union (C inner name) tags ->
262 (vs, os, insertWith merge name (C (pre, post) (C inner tags)) ts)
263
264 done (vs, os, ts) =
265 Module.DetailedListing vs os ts
266 in
267 foldl step (empty, empty, empty) values
268 |> done
269
270
271 value :: ElmVersion -> IParser Listing.Value
272 value elmVersion =
273 val <|> tipe <?> "a value or type to expose"
274 where
275 val =
276 (Listing.Value <$> lowVar elmVersion) <|> (Listing.OpValue <$> parens' symOp)
277
278 tipe =
279 do name <- capVar elmVersion
280 maybeCtors <- optionMaybe (try $ (,) <$> whitespace <*> listing (commentedSet $ capVar elmVersion))
281 case maybeCtors of
282 Nothing -> return $ Listing.Union (C [] name) Listing.ClosedListing
283 Just (pre, ctors) -> return (Listing.Union (C pre name) ctors)