never executed always true always false
1 {-# LANGUAGE DeriveGeneric #-}
2 {-# LANGUAGE TypeFamilies #-}
3 {-# LANGUAGE DataKinds #-}
4 {-# OPTIONS_GHC -Wno-orphans #-}
5 module ElmFormat.AST.PublicAST.Type (Type_(..), CustomTypeVariant(..), mkCustomTypeVariant, fromCustomTypeVariant) where
6
7 import ElmFormat.AST.PublicAST.Core
8 import qualified AST.V0_16 as AST
9 import Data.Map.Strict (Map)
10 import qualified Data.Map.Strict as Map
11 import qualified Data.Indexed as I
12 import qualified Data.ReversedList as ReversedList
13 import Data.ReversedList (Reversed)
14 import qualified Data.Either as Either
15 import Data.Maybe (fromMaybe)
16
17
18 data Type_
19 = UnitType
20 | TypeReference
21 { name_tr :: UppercaseIdentifier
22 , module_ :: ModuleName
23 , arguments :: List (LocatedIfRequested Type_)
24 }
25 | TypeVariable
26 { name_tv :: LowercaseIdentifier
27 }
28 | TupleType
29 { terms :: List (LocatedIfRequested Type_) -- At least two items
30 }
31 | RecordType
32 { base :: Maybe LowercaseIdentifier
33 , fields :: Map LowercaseIdentifier (LocatedIfRequested Type_) -- Cannot be empty if base is present
34 , display :: RecordDisplay
35 }
36 | FunctionType
37 { returnType :: LocatedIfRequested Type_
38 , argumentTypes :: List (LocatedIfRequested Type_) -- Non-empty
39 }
40
41 instance ToPublicAST 'TypeNK where
42 type PublicAST 'TypeNK = Type_
43
44 fromRawAST' config = \case
45 AST.UnitType comments ->
46 UnitType
47
48 AST.TypeConstruction (AST.NamedConstructor ( namespace, name )) args forceMultine ->
49 TypeReference
50 name
51 (ModuleName namespace)
52 (fmap (\(C comments a) -> fromRawAST config a) args)
53
54 AST.TypeConstruction (AST.TupleConstructor _) _ _ ->
55 error "TODO"
56
57 AST.TypeVariable name ->
58 TypeVariable name
59
60 AST.TypeParens (C comments t) ->
61 fromRawAST' config (extract $ I.unFix t)
62
63 AST.TupleType terms multiline ->
64 TupleType
65 (fmap (\(C comments a) -> fromRawAST config a) terms)
66
67 AST.RecordType base fields comments multiline ->
68 RecordType
69 (fmap (\(C comments a) -> a) base)
70 (Map.fromList $ (\(C cp (Pair (C ck key) (C cv value) ml)) -> (key, fromRawAST config value)) <$> AST.toCommentedList fields)
71 $ RecordDisplay
72 (extract . _key . extract <$> AST.toCommentedList fields)
73
74 AST.FunctionType first rest multiline ->
75 case firstRestToRestLast first (AST.toCommentedList rest) of
76 (args, C comments last) ->
77 FunctionType
78 (fromRawAST config last)
79 (fmap (\(C comments a) -> fromRawAST config a) args)
80 where
81 firstRestToRestLast :: AST.C0Eol x -> List (AST.C2Eol a b x) -> (List (AST.C2Eol a b x), AST.C0Eol x)
82 firstRestToRestLast first rest =
83 done $ foldl (flip step) (ReversedList.empty, first) rest
84 where
85 step :: AST.C2Eol a b x -> (Reversed (AST.C2Eol a b x), AST.C0Eol x) -> (Reversed (AST.C2Eol a b x), AST.C0Eol x)
86 step (C (a, b, dn) next) (acc, C dn' last) =
87 (ReversedList.push (C (a, b, dn') last) acc, C dn next)
88
89 done :: (Reversed (AST.C2Eol a b x), AST.C0Eol x) -> (List (AST.C2Eol a b x), AST.C0Eol x)
90 done (acc, last) =
91 (ReversedList.toList acc, last)
92
93 instance FromPublicAST 'TypeNK where
94 toRawAST' = \case
95 UnitType ->
96 AST.UnitType []
97
98 TypeReference name (ModuleName namespace) args ->
99 AST.TypeConstruction
100 (AST.NamedConstructor ( namespace, name ))
101 (C [] . toRawAST <$> args)
102 (AST.ForceMultiline False)
103
104 TypeVariable name ->
105 AST.TypeVariable name
106
107 TupleType terms ->
108 AST.TupleType
109 (C ([], [], Nothing) . toRawAST <$> terms)
110 (AST.ForceMultiline False)
111
112 RecordType base fields display ->
113 AST.RecordType
114 (C ([], []) <$> base)
115 (Either.fromRight undefined $ AST.fromCommentedList ((\(key, value) -> C ([], [], Nothing) $ Pair (C [] key) (C [] $ toRawAST value) (AST.ForceMultiline False)) <$> Map.toList fields))
116 []
117 (AST.ForceMultiline True)
118
119 FunctionType returnType argumentTypes ->
120 case argumentTypes ++ [ returnType ] of
121 first : rest ->
122 AST.FunctionType
123 (C Nothing $ toRawAST first)
124 (Either.fromRight undefined $ AST.fromCommentedList $ fmap (C ([], [], Nothing) . toRawAST) rest)
125 (AST.ForceMultiline False)
126
127 [] ->
128 undefined
129
130 instance ToJSON Type_ where
131 toJSON = undefined
132 toEncoding = pairs . toPairs
133
134 instance ToPairs Type_ where
135 toPairs = \case
136 UnitType ->
137 mconcat
138 [ type_ "UnitType"
139 ]
140
141 TypeReference name module_ arguments ->
142 mconcat
143 [ type_ "TypeReference"
144 , "name" .= name
145 , "module" .= module_
146 , "arguments" .= arguments
147 ]
148
149 TypeVariable name ->
150 mconcat
151 [ type_ "TypeVariable"
152 , "name" .= name
153 ]
154
155 TupleType terms ->
156 mconcat
157 [ type_ "TupleType"
158 , "terms" .= terms
159 ]
160
161 RecordType Nothing fields display ->
162 mconcat
163 [ type_ "RecordType"
164 , "fields" .= fields
165 , "display" .= display
166 ]
167
168 RecordType (Just base) fields display ->
169 mconcat
170 [ type_ "RecordTypeExtension"
171 , "base" .= base
172 , "fields" .= fields
173 , "display" .= display
174 ]
175
176 FunctionType returnType argumentTypes ->
177 mconcat
178 [ type_ "FunctionType"
179 , "returnType" .= returnType
180 , "argumentTypes" .= argumentTypes
181 ]
182
183 instance FromJSON Type_ where
184 parseJSON = withObject "Type" $ \obj -> do
185 tag <- obj .: "tag"
186 case tag of
187 "UnitType" ->
188 return UnitType
189
190 "TypeReference" ->
191 TypeReference
192 <$> obj .: "name"
193 <*> (fromMaybe (ModuleName []) <$> obj .:? "module")
194 <*> obj .:? "arguments" .!= []
195
196 "TypeVariable" ->
197 TypeVariable
198 <$> obj .: "name"
199
200 "TupleType" ->
201 TupleType
202 <$> obj .: "terms"
203
204 "RecordType" ->
205 RecordType Nothing
206 <$> obj .: "fields"
207 <*> return (RecordDisplay [])
208
209 "RecordTypeExtension" ->
210 RecordType
211 <$> (Just <$> obj .: "base")
212 <*> obj .: "fields"
213 <*> return (RecordDisplay [])
214
215 "FunctionType" ->
216 FunctionType
217 <$> obj .: "returnType"
218 <*> obj .: "argumentTypes"
219
220 _ ->
221 fail ("unexpected Type tag: \"" <> tag <> "\"")
222
223
224 data CustomTypeVariant
225 = CustomTypeVariant
226 { name :: UppercaseIdentifier
227 , parameterTypes :: List (LocatedIfRequested Type_)
228 }
229 deriving (Generic)
230
231 mkCustomTypeVariant :: Config -> AST.NameWithArgs UppercaseIdentifier (ASTNS Located [UppercaseIdentifier] 'TypeNK) -> CustomTypeVariant
232 mkCustomTypeVariant config (AST.NameWithArgs name args) =
233 CustomTypeVariant
234 name
235 ((\(C c a) -> fromRawAST config a) <$> args)
236
237 fromCustomTypeVariant :: CustomTypeVariant -> AST.NameWithArgs UppercaseIdentifier (ASTNS Identity [UppercaseIdentifier] 'TypeNK)
238 fromCustomTypeVariant = \case
239 CustomTypeVariant name parameterTypes ->
240 AST.NameWithArgs
241 name
242 (C [] . toRawAST <$> parameterTypes)
243
244 instance ToJSON CustomTypeVariant where
245 toEncoding = genericToEncoding defaultOptions
246
247 instance FromJSON CustomTypeVariant where
248 parseJSON = withObject "CustomTypeVariant" $ \obj ->
249 CustomTypeVariant
250 <$> obj .: "name"
251 <*> obj .:? "parameterTypes" .!= []