git.iko.soy/elk
on fb43331 help sign in
elk/compiler/src/Elm/Compiler/Type.hs
195 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.Name as Name
18import qualified Data.Utf8 as Utf8
20import qualified AST.Source as Src
21import qualified Parse.Primitives as P
22import qualified Parse.Type as Type
23import qualified Reporting.Annotation as A
24import qualified Reporting.Doc as D
25import qualified Reporting.Render.Type as RT
26import qualified Reporting.Render.Type.Localizer as L
28import qualified Json.Decode as D
29import qualified Json.Encode as E
30import Json.Encode ((==>))
34-- TYPES
37data Type
38 = Lambda Type Type
39 | Var Name.Name
40 | Type Name.Name [Type]
41 | Record [(Name.Name, Type)] (Maybe Name.Name)
42 | Unit
43 | Tuple Type Type [Type]
46data DebugMetadata =
47 DebugMetadata
48 { _message :: Type
49 , _aliases :: [Alias]
50 , _unions :: [Union]
51 }
54data Alias = Alias Name.Name [Name.Name] Type
55data Union = Union Name.Name [Name.Name] [(Name.Name, [Type])]
59-- TO DOC
62toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc
63toDoc localizer context tipe =
64 case tipe of
65 Lambda _ _ ->
66 let
67 a:b:cs =
68 map (toDoc localizer RT.Func) (collectLambdas tipe)
69 in
70 RT.lambda context a b cs
72 Var name ->
73 D.fromName name
75 Unit ->
76 "()"
78 Tuple a b cs ->
79 RT.tuple
80 (toDoc localizer RT.None a)
81 (toDoc localizer RT.None b)
82 (map (toDoc localizer RT.None) cs)
84 Type name args ->
85 RT.apply
86 context
87 (D.fromName name)
88 (map (toDoc localizer RT.App) args)
90 Record fields ext ->
91 RT.record
92 (map (entryToDoc localizer) fields)
93 (fmap D.fromName ext)
96entryToDoc :: L.Localizer -> (Name.Name, Type) -> (D.Doc, D.Doc)
97entryToDoc localizer (field, fieldType) =
98 ( D.fromName field, toDoc localizer RT.None fieldType )
101collectLambdas :: Type -> [Type]
102collectLambdas tipe =
103 case tipe of
104 Lambda arg body ->
105 arg : collectLambdas body
107 _ ->
108 [tipe]
112-- JSON for TYPE
115encode :: Type -> E.Value
116encode tipe =
117 E.string $ Utf8.fromChars $ D.toLine (toDoc L.empty RT.None tipe)
120decoder :: D.Decoder () Type
121decoder =
122 do str <- D.string
123 case P.fromByteString Type.expression (error "TODO turn Utf8 to something that can be parsed" str) of
124 P.Ok (tipe, _, _) _ ->
125 return (fromRawType tipe)
127 P.Err _ _ _ _ ->
128 D.failure ()
131fromRawType :: Src.Type -> Type
132fromRawType (A.At _ astType) =
133 case astType of
134 Src.TLambda t1 t2 ->
135 Lambda (fromRawType t1) (fromRawType t2)
137 Src.TVar x ->
138 Var x
140 Src.TUnit ->
141 Unit
143 Src.TTuple a b cs ->
144 Tuple
145 (fromRawType a)
146 (fromRawType b)
147 (map fromRawType cs)
149 Src.TType _ name args ->
150 Type name (map fromRawType args)
152 Src.TTypeQual _ _ name args ->
153 Type name (map fromRawType args)
155 Src.TRecord fields ext ->
156 let fromField (A.At _ field, tipe) = (field, fromRawType tipe) in
157 Record
158 (map fromField fields)
159 (fmap A.toValue ext)
163-- JSON for PROGRAM
166encodeMetadata :: DebugMetadata -> E.Value
167encodeMetadata (DebugMetadata msg aliases unions) =
168 E.object
169 [ "message" ==> encode msg
170 , "aliases" ==> E.object (map toAliasField aliases)
171 , "unions" ==> E.object (map toUnionField unions)
172 ]
175toAliasField :: Alias -> ( Utf8.String, E.Value )
176toAliasField (Alias name args tipe) =
177 Name.toUtf8 name ==>
178 E.object
179 [ "args" ==> E.list E.name args
180 , "type" ==> encode tipe
181 ]
184toUnionField :: Union -> ( Utf8.String, E.Value )
185toUnionField (Union name args constructors) =
186 Name.toUtf8 name ==>
187 E.object
188 [ "args" ==> E.list E.name args
189 , "tags" ==> E.object (map toCtorObject constructors)
190 ]
193toCtorObject :: (Name.Name, [Type]) -> ( Utf8.String, E.Value )
194toCtorObject (name, args) =
195 Name.toUtf8 name ==> E.list encode args