never executed always true always false
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE DeriveGeneric #-}
3 {-# LANGUAGE TypeFamilies #-}
4 {-# LANGUAGE PolyKinds #-}
5 module ElmFormat.AST.PublicAST.Module (Module(..), fromModule, toModule) where
6
7 import ElmFormat.AST.PublicAST.Core
8 import ElmFormat.AST.PublicAST.Comment
9 import ElmFormat.AST.PublicAST.Expression
10 import ElmFormat.AST.PublicAST.Type
11 import qualified AST.V0_16 as AST
12 import qualified AST.Module as AST
13 import qualified AST.Listing as AST
14 import Data.Map.Strict (Map)
15 import qualified Data.Maybe as Maybe
16 import qualified ElmFormat.ImportInfo as ImportInfo
17 import qualified Data.Map.Strict as Map
18 import qualified Data.Indexed as I
19 import AST.MatchReferences (fromMatched, matchReferences)
20 import Data.Text (Text)
21 import qualified Data.Either as Either
22 import qualified Data.Text as Text
23 import Data.Maybe (fromMaybe)
24
25
26 data Module
27 = Module
28 { moduleName :: ModuleName
29 , imports :: Map ModuleName Import
30 , body :: List (MaybeF LocatedIfRequested TopLevelStructure)
31 }
32
33 fromModule :: Config -> AST.Module [UppercaseIdentifier] (ASTNS Located [UppercaseIdentifier] 'TopLevelNK) -> Module
34 fromModule config = \case
35 modu@(AST.Module _ maybeHeader _ (C _ imports) body) ->
36 let
37 header =
38 Maybe.fromMaybe AST.defaultHeader maybeHeader
39
40 (AST.Header _ (C _ name) _ _) = header
41
42 importInfo =
43 ImportInfo.fromModule mempty modu
44
45 normalize =
46 mapNs (fromMatched []) . matchReferences importInfo
47 in
48 Module
49 (ModuleName name)
50 (Map.mapWithKey (\m (C comments i) -> fromImportMethod m i) $ Map.mapKeys ModuleName imports)
51 (fromTopLevelStructures config $ normalize body)
52
53 toModule :: Module -> AST.Module [UppercaseIdentifier] (ASTNS Identity [UppercaseIdentifier] 'TopLevelNK)
54 toModule (Module (ModuleName name) imports body) =
55 -- TODO: remove this placeholder
56 AST.Module
57 []
58 (Just $ AST.Header
59 AST.Normal
60 (C ([], []) name)
61 Nothing
62 Nothing
63 )
64 (noRegion Nothing)
65 (C [] $ Map.mapKeys (\(ModuleName ns) -> ns) $ C [] . toImportMethod <$> imports)
66 (f $ AST.TopLevel $ mconcat $ fmap (toTopLevelStructures . extract) body)
67 where
68 f = I.Fix . Identity
69
70 instance ToJSON Module where
71 toJSON = undefined
72 toEncoding = \case
73 Module moduleName imports body ->
74 pairs $ mconcat
75 [ "moduleName" .= moduleName
76 , "imports" .= imports
77 , "body" .= body
78 ]
79
80 instance FromJSON Module where
81 parseJSON = withObject "Module" $ \obj ->
82 (\moduleName makeImports -> Module moduleName (Map.mapWithKey (\importModuleName makeImport -> makeImport importModuleName) makeImports))
83 <$> obj .: "moduleName"
84 <*> obj .:? "imports" .!= mempty
85 <*> obj .: "body"
86
87
88 data Import
89 = Import
90 { as :: ModuleName
91 , exposing :: AST.Listing AST.DetailedListing
92 }
93 deriving (Generic)
94
95 fromImportMethod :: ModuleName -> AST.ImportMethod -> Import
96 fromImportMethod moduleName (AST.ImportMethod alias (C comments exposing)) =
97 let
98 as_ =
99 case alias of
100 Nothing -> moduleName
101 Just (C c a) -> ModuleName [ a ]
102 in
103 Import as_ exposing
104
105 toImportMethod :: Import -> AST.ImportMethod
106 toImportMethod (Import alias exposing) =
107 AST.ImportMethod
108 (case alias of
109 ModuleName [single] ->
110 Just $ C ([], []) single
111 _ ->
112 Nothing
113 )
114 (C ([], []) exposing)
115
116 instance ToJSON Import where
117 toEncoding = genericToEncoding defaultOptions
118
119 instance FromJSON (ModuleName -> Import) where
120 -- This results in a function that when given that actual name of the module, returns the Import
121 parseJSON = withObject "Import" $ \obj ->
122 (\makeAs exposing moduleName -> Import (makeAs moduleName) exposing)
123 <$> (fmap const <$> obj .:? "as") .!= id
124 <*> obj .:? "exposing" .!= AST.ClosedListing
125
126
127 data TopLevelStructure
128 = DefinitionStructure Definition
129 | TypeAlias
130 { name_ta :: UppercaseIdentifier
131 , parameters_ta :: List LowercaseIdentifier
132 , type_ta :: LocatedIfRequested Type_
133 }
134 | CustomType
135 { name_ct :: UppercaseIdentifier
136 , parameters_ct :: List LowercaseIdentifier
137 , variants :: List CustomTypeVariant
138 }
139 | Comment_tls Comment
140 | TODO_TopLevelStructure String
141
142 fromTopLevelStructures :: Config -> ASTNS Located [UppercaseIdentifier] 'TopLevelNK -> List (MaybeF LocatedIfRequested TopLevelStructure)
143 fromTopLevelStructures config (I.Fix (A _ (AST.TopLevel decls))) =
144 let
145 toDefBuilder :: AST.TopLevelStructure
146 (ASTNS Located [UppercaseIdentifier] 'TopLevelDeclarationNK) -> MaybeF LocatedIfRequested (DefinitionBuilder TopLevelStructure)
147 toDefBuilder decl =
148 case fmap I.unFix decl of
149 AST.Entry (A region entry) ->
150 JustF $ fromLocated config $ A region $
151 case entry of
152 AST.CommonDeclaration (I.Fix (A _ def)) ->
153 Right def
154
155 AST.TypeAlias c1 (C (c2, c3) (AST.NameWithArgs name args)) (C c4 t) ->
156
157 Left $ TypeAlias name (fmap (\(C c a) -> a) args) (fromRawAST config t)
158
159 AST.Datatype (C (c1, c2) (AST.NameWithArgs name args)) variants ->
160 Left $ CustomType
161 name
162 ((\(C c a) -> a) <$> args)
163 ((\(C c a) -> mkCustomTypeVariant config a) <$> AST.toCommentedList variants)
164
165 other ->
166 Left $ TODO_TopLevelStructure ("TODO: " ++ show other)
167
168 AST.BodyComment comment ->
169 NothingF $ Left $ Comment_tls (mkComment comment)
170
171 _ ->
172 NothingF $ Left $
173 TODO_TopLevelStructure ("TODO: " ++ show decl)
174 in
175 mkDefinitions config DefinitionStructure $ fmap toDefBuilder decls
176
177 toTopLevelStructures :: TopLevelStructure -> List (AST.TopLevelStructure (ASTNS Identity [UppercaseIdentifier] 'TopLevelDeclarationNK))
178 toTopLevelStructures = \case
179 DefinitionStructure def ->
180 AST.Entry . I.Fix . Identity . AST.CommonDeclaration <$> fromDefinition def
181
182 TypeAlias name parameters typ ->
183 pure $ AST.Entry $ I.Fix $ Identity $ AST.TypeAlias
184 []
185 (C ([], []) (AST.NameWithArgs name (fmap (C []) parameters)))
186 (C [] $ toRawAST typ)
187
188 CustomType name parameters variants ->
189 pure $ AST.Entry $ I.Fix $ Identity $ AST.Datatype
190 (C ([], []) (AST.NameWithArgs name (fmap (C []) parameters)))
191 (Either.fromRight undefined $ AST.fromCommentedList (C ([], [], Nothing) . fromCustomTypeVariant <$> variants))
192
193 Comment_tls comment ->
194 pure $ AST.BodyComment $ fromComment comment
195
196 instance ToJSON TopLevelStructure where
197 toJSON = undefined
198 toEncoding = pairs . toPairs
199
200 instance ToPairs TopLevelStructure where
201 toPairs = \case
202 DefinitionStructure def ->
203 toPairs def
204
205 TypeAlias name parameters t ->
206 mconcat
207 [ type_ "TypeAlias"
208 , "name" .= name
209 , "parameters" .= parameters
210 , "type" .= t
211 ]
212
213 CustomType name parameters variants ->
214 mconcat
215 [ type_ "CustomType"
216 , "name" .= name
217 , "parameters" .= parameters
218 , "variants" .= variants
219 ]
220
221 Comment_tls comment ->
222 toPairs comment
223
224 TODO_TopLevelStructure s ->
225 "TODO" .= s
226
227 instance FromJSON TopLevelStructure where
228 parseJSON = withObject "TopLevelStructure" $ \obj -> do
229 tag :: Text <- obj .: "tag"
230 case tag of
231 "Definition" ->
232 DefinitionStructure <$> parseJSON (Object obj)
233
234 "TypeAlias" ->
235 TypeAlias
236 <$> obj .: "name"
237 <*> obj .:? "parameters" .!= []
238 <*> obj .: "type"
239
240 "CustomType" ->
241 CustomType
242 <$> obj .: "name"
243 <*> obj .:? "parameters" .!= []
244 <*> obj .: "variants"
245
246 "Comment" ->
247 Comment_tls <$> parseJSON (Object obj)
248
249 _ ->
250 fail ("unexpected TopLevelStructure tag: " <> Text.unpack tag)