git.iko.soy/elk
on efe80bc help sign in
elk/compiler/src/Elm/Compiler/Type.hs
196 lines 4.2 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
18import qualified Data.Text as Text
19import qualified Data.Text.Encoding as Text
21import qualified AST.Source as Src
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 Name.Name
41 | Type Name.Name [Type]
42 | Record [(Name.Name, Type)] (Maybe Name.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 Name.Name [Name.Name] Type
56data Union = Union Name.Name [Name.Name] [(Name.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 -> (Name.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 Name.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 Name.toText name ==>
188 Encode.object
189 [ "args" ==> Encode.list Encode.name args
190 , "tags" ==> Encode.object (map toCtorObject constructors)
191 ]
194toCtorObject :: (Name.Name, [Type]) -> ( Text.Text, Encode.Value )
195toCtorObject (name, args) =
196 Name.toText name ==> Encode.list encode args