git.iko.soy/elk
on f4401ac help sign in
elk/compiler/src/Elm/Compiler/Type.hs
194 lines 4.0 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Elm.Compiler.Type
4 ( Type(..)
5 , RT.Context(..)
6 , toDoc
7 , DebugMetadata(..)
8 , Alias(..)
9 , Union(..)
10 , encode
11 , decoder
12 , encodeMetadata
13 )
14 where
17import qualified Data.Name as Name
19import qualified AST.Source as Src
20import qualified Json.Decode as D
21import qualified Json.Encode as E
22import Json.Encode ((==>))
23import qualified Json.String as Json
24import qualified Parse.Primitives as P
25import qualified Parse.Type as Type
26import qualified Reporting.Annotation as A
27import qualified Reporting.Doc as D
28import qualified Reporting.Render.Type as RT
29import qualified Reporting.Render.Type.Localizer as L
33-- TYPES
36data Type
37 = Lambda Type Type
38 | Var Name.Name
39 | Type Name.Name [Type]
40 | Record [(Name.Name, Type)] (Maybe Name.Name)
41 | Unit
42 | Tuple Type Type [Type]
45data DebugMetadata =
46 DebugMetadata
47 { _message :: Type
48 , _aliases :: [Alias]
49 , _unions :: [Union]
50 }
53data Alias = Alias Name.Name [Name.Name] Type
54data Union = Union Name.Name [Name.Name] [(Name.Name, [Type])]
58-- TO DOC
61toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc
62toDoc localizer context tipe =
63 case tipe of
64 Lambda _ _ ->
65 let
66 a:b:cs =
67 map (toDoc localizer RT.Func) (collectLambdas tipe)
68 in
69 RT.lambda context a b cs
71 Var name ->
72 D.fromName name
74 Unit ->
75 "()"
77 Tuple a b cs ->
78 RT.tuple
79 (toDoc localizer RT.None a)
80 (toDoc localizer RT.None b)
81 (map (toDoc localizer RT.None) cs)
83 Type name args ->
84 RT.apply
85 context
86 (D.fromName name)
87 (map (toDoc localizer RT.App) args)
89 Record fields ext ->
90 RT.record
91 (map (entryToDoc localizer) fields)
92 (fmap D.fromName ext)
95entryToDoc :: L.Localizer -> (Name.Name, Type) -> (D.Doc, D.Doc)
96entryToDoc localizer (field, fieldType) =
97 ( D.fromName field, toDoc localizer RT.None fieldType )
100collectLambdas :: Type -> [Type]
101collectLambdas tipe =
102 case tipe of
103 Lambda arg body ->
104 arg : collectLambdas body
106 _ ->
107 [tipe]
111-- JSON for TYPE
114encode :: Type -> E.Value
115encode tipe =
116 E.chars $ D.toLine (toDoc L.empty RT.None tipe)
119decoder :: D.Decoder () Type
120decoder =
121 let
122 parser =
123 P.specialize (\_ _ _ -> ()) (fromRawType . fst <$> Type.expression)
124 in
125 D.customString parser (\_ _ -> ())
128fromRawType :: Src.Type -> Type
129fromRawType (A.At _ astType) =
130 case astType of
131 Src.TLambda t1 t2 ->
132 Lambda (fromRawType t1) (fromRawType t2)
134 Src.TVar x ->
135 Var x
137 Src.TUnit ->
138 Unit
140 Src.TTuple a b cs ->
141 Tuple
142 (fromRawType a)
143 (fromRawType b)
144 (map fromRawType cs)
146 Src.TType _ name args ->
147 Type name (map fromRawType args)
149 Src.TTypeQual _ _ name args ->
150 Type name (map fromRawType args)
152 Src.TRecord fields ext ->
153 let fromField (A.At _ field, tipe) = (field, fromRawType tipe) in
154 Record
155 (map fromField fields)
156 (fmap A.toValue ext)
160-- JSON for PROGRAM
163encodeMetadata :: DebugMetadata -> E.Value
164encodeMetadata (DebugMetadata msg aliases unions) =
165 E.object
166 [ "message" ==> encode msg
167 , "aliases" ==> E.object (map toTypeAliasField aliases)
168 , "unions" ==> E.object (map toCustomTypeField unions)
169 ]
172toTypeAliasField :: Alias -> ( Json.String, E.Value )
173toTypeAliasField (Alias name args tipe) =
174 ( Json.fromName name
175 , E.object
176 [ "args" ==> E.list E.name args
177 , "type" ==> encode tipe
178 ]
179 )
182toCustomTypeField :: Union -> ( Json.String, E.Value )
183toCustomTypeField (Union name args constructors) =
184 ( Json.fromName name
185 , E.object
186 [ "args" ==> E.list E.name args
187 , "tags" ==> E.object (map toVariantObject constructors)
188 ]
189 )
192toVariantObject :: (Name.Name, [Type]) -> ( Json.String, E.Value )
193toVariantObject (name, args) =
194 ( Json.fromName name, E.list encode args )