git.iko.soy/elk
on cb3a2fa help sign in
elk/src/Elm/Compiler/Type.hs
195 lines 4.8 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Elm.Compiler.Type
3 ( Type(..)
4 , toString
5 ) where
7import Control.Applicative ((<$>), (<*>))
8import Control.Arrow (second)
9import Data.Aeson ((.:))
10import qualified Data.Aeson as Json
11import qualified Data.Aeson.Types as Json
12import qualified Data.ByteString.Lazy.Char8 as BS
13import qualified Data.Text as Text
14import Text.PrettyPrint as P
16import qualified AST.Helpers as Help
17import qualified AST.Type as Type
18import qualified AST.Variable as Var
19import qualified Parse.Helpers as Parse
20import qualified Parse.Type as Type
21import qualified Reporting.Annotation as A
24data Type
25 = Lambda Type Type
26 | Var String
27 | Type String
28 | App Type [Type]
29 | Record [(String, Type)] (Maybe Type)
32-- TO STRING
34data Context = None | ADT | Function
37toString :: Type -> String
38toString tipe =
39 P.render (toDoc None tipe)
42toDoc :: Context -> Type -> P.Doc
43toDoc context tipe =
44 case tipe of
45 Lambda _ _ ->
46 let t:ts =
47 map (toDoc Function) (collectLambdas tipe)
49 lambda =
50 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
51 in
52 case context of
53 None -> lambda
54 _ -> P.parens lambda
56 Var name ->
57 P.text name
59 Type name ->
60 P.text (if name == "_Tuple0" then "()" else name)
62 App (Type name) args
63 | Help.isTuple name ->
64 P.sep
65 [ P.cat (zipWith (<+>) (P.lparen : repeat P.comma) (map (toDoc None) args))
66 , P.rparen
67 ]
69 | otherwise ->
70 let adt = P.hang (P.text name) 2 (P.sep $ map (toDoc ADT) args)
71 in
72 case (context, args) of
73 (ADT, _ : _) -> P.parens adt
74 _ -> adt
76 App _ _ ->
77 error $
78 "Somehow ended up with an unexpected type, please post a minimal example that\n"
79 ++ "reproduces this error to <https://github.com/elm-lang/elm-compiler/issues>"
81 Record _ _ ->
82 case flattenRecord tipe of
83 ([], Nothing) ->
84 P.text "{}"
86 (fields, Nothing) ->
87 P.sep
88 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
89 , P.rbrace
90 ]
92 (fields, Just x) ->
93 P.hang
94 (P.lbrace <+> P.text x <+> P.text "|")
95 4
96 (P.sep
97 [ P.sep (P.punctuate P.comma (map prettyField fields))
98 , P.rbrace
99 ]
100 )
101 where
102 prettyField (field, tipe) =
103 P.text field <+> P.text ":" <+> toDoc None tipe
106collectLambdas :: Type -> [Type]
107collectLambdas tipe =
108 case tipe of
109 Lambda arg body -> arg : collectLambdas body
110 _ -> [tipe]
113flattenRecord :: Type -> ( [(String, Type)], Maybe String )
114flattenRecord tipe =
115 case tipe of
116 Var x -> ([], Just x)
118 Record fields Nothing -> (fields, Nothing)
120 Record fields (Just ext) ->
121 let (fields',ext') = flattenRecord ext
122 in
123 (fields' ++ fields, ext')
125 _ -> error "Trying to flatten ill-formed record."
128-- JSON for TYPE
130instance Json.ToJSON Type where
131 toJSON tipe =
132 Json.String (Text.unwords (Text.words (Text.pack (toString tipe))))
135instance Json.FromJSON Type where
136 parseJSON value =
137 let
138 failure _ =
139 fail $
140 "Trying to decode a type string, but could not handle this value:\n"
141 ++ BS.unpack (Json.encode value)
142 in
143 case value of
144 Json.String text ->
145 either failure (return . fromRawType)
146 (Parse.iParse Type.expr (Text.unpack text))
148 Json.Object obj ->
149 fromObject obj
151 _ ->
152 failure ()
155fromObject :: Json.Object -> Json.Parser Type
156fromObject obj =
157 do tag <- obj .: "tag"
158 case (tag :: String) of
159 "lambda" ->
160 Lambda <$> obj .: "in" <*> obj .: "out"
162 "var" ->
163 Var <$> obj .: "name"
165 "type" ->
166 Type <$> obj .: "name"
168 "app" ->
169 App <$> obj .: "func" <*> obj .: "args"
171 "record" ->
172 Record <$> obj .: "fields" <*> obj .: "extension"
174 _ ->
175 fail $ "Error when decoding type with tag: " ++ tag
178fromRawType :: Type.Raw -> Type
179fromRawType (A.A _ astType) =
180 case astType of
181 Type.RLambda t1 t2 ->
182 Lambda (fromRawType t1) (fromRawType t2)
184 Type.RVar x ->
185 Var x
187 Type.RType var ->
188 Type (Var.toString var)
190 Type.RApp t ts ->
191 App (fromRawType t) (map fromRawType ts)
193 Type.RRecord fields ext ->
194 Record (map (second fromRawType) fields) (fmap fromRawType ext)