git.iko.soy/elk
on 42f3721 help sign in
elk/compiler/src/Elm/Compiler/Type.hs
196 lines 4.1 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.Text as Text
18import qualified Data.Text.Encoding as Text
20import qualified AST.Source as Src
21import qualified Elm.Name as N
22import qualified Parse.Primitives as Parse
23import qualified Parse.Type as Type
24import qualified Reporting.Annotation as A
25import qualified Reporting.Doc as D
26import qualified Reporting.Render.Type as RT
27import qualified Reporting.Render.Type.Localizer as L
29import qualified Json.Decode as Decode
30import qualified Json.Encode as Encode
31import Json.Encode ((==>))
35-- TYPES
38data Type
39 = Lambda Type Type
40 | Var N.Name
41 | Type N.Name [Type]
42 | Record [(N.Name, Type)] (Maybe N.Name)
43 | Unit
44 | Tuple Type Type [Type]
47data DebugMetadata =
48 DebugMetadata
49 { _message :: Type
50 , _aliases :: [Alias]
51 , _unions :: [Union]
52 }
55data Alias = Alias N.Name [N.Name] Type
56data Union = Union N.Name [N.Name] [(N.Name, [Type])]
60-- TO DOC
63toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc
64toDoc localizer context tipe =
65 case tipe of
66 Lambda _ _ ->
67 let
68 a:b:cs =
69 map (toDoc localizer RT.Func) (collectLambdas tipe)
70 in
71 RT.lambda context a b cs
73 Var name ->
74 D.fromName name
76 Unit ->
77 "()"
79 Tuple a b cs ->
80 RT.tuple
81 (toDoc localizer RT.None a)
82 (toDoc localizer RT.None b)
83 (map (toDoc localizer RT.None) cs)
85 Type name args ->
86 RT.apply
87 context
88 (D.fromName name)
89 (map (toDoc localizer RT.App) args)
91 Record fields ext ->
92 RT.record
93 (map (entryToDoc localizer) fields)
94 (fmap D.fromName ext)
97entryToDoc :: L.Localizer -> (N.Name, Type) -> (D.Doc, D.Doc)
98entryToDoc localizer (field, fieldType) =
99 ( D.fromName field, toDoc localizer RT.None fieldType )
102collectLambdas :: Type -> [Type]
103collectLambdas tipe =
104 case tipe of
105 Lambda arg body ->
106 arg : collectLambdas body
108 _ ->
109 [tipe]
113-- JSON for TYPE
116encode :: Type -> Encode.Value
117encode tipe =
118 Encode.text $ Text.pack $ D.toLine (toDoc L.empty RT.None tipe)
121decoder :: Decode.Decoder () Type
122decoder =
123 do txt <- Decode.text
124 case Parse.run Type.expression (Text.encodeUtf8 (Text.replace "'" "_" txt)) of
125 Left _ ->
126 Decode.fail ()
128 Right (tipe, _, _) ->
129 Decode.succeed (fromRawType tipe)
132fromRawType :: Src.Type -> Type
133fromRawType (A.At _ astType) =
134 case astType of
135 Src.TLambda t1 t2 ->
136 Lambda (fromRawType t1) (fromRawType t2)
138 Src.TVar x ->
139 Var x
141 Src.TUnit ->
142 Unit
144 Src.TTuple a b cs ->
145 Tuple
146 (fromRawType a)
147 (fromRawType b)
148 (map fromRawType cs)
150 Src.TType _ name args ->
151 Type name (map fromRawType args)
153 Src.TTypeQual _ _ name args ->
154 Type name (map fromRawType args)
156 Src.TRecord fields ext ->
157 let fromField (A.At _ field, tipe) = (field, fromRawType tipe) in
158 Record
159 (map fromField fields)
160 (fmap A.toValue ext)
164-- JSON for PROGRAM
167encodeMetadata :: DebugMetadata -> Encode.Value
168encodeMetadata (DebugMetadata msg aliases unions) =
169 Encode.object
170 [ "message" ==> encode msg
171 , "aliases" ==> Encode.object (map toAliasField aliases)
172 , "unions" ==> Encode.object (map toUnionField unions)
173 ]
176toAliasField :: Alias -> ( Text.Text, Encode.Value )
177toAliasField (Alias name args tipe) =
178 N.toText name ==>
179 Encode.object
180 [ "args" ==> Encode.list Encode.name args
181 , "type" ==> encode tipe
182 ]
185toUnionField :: Union -> ( Text.Text, Encode.Value )
186toUnionField (Union name args constructors) =
187 N.toText name ==>
188 Encode.object
189 [ "args" ==> Encode.list Encode.name args
190 , "tags" ==> Encode.object (map toCtorObject constructors)
191 ]
194toCtorObject :: (N.Name, [Type]) -> ( Text.Text, Encode.Value )
195toCtorObject (name, args) =
196 N.toText name ==> Encode.list encode args