git.iko.soy/elk
on 96dfd88 help sign in
elk/src/Elm/Compiler/Type.hs
157 lines 3.9 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.ByteString.Lazy.Char8 as BS
12import qualified Data.List as List
13import qualified Data.Text as Text
15import qualified AST.Helpers as Help
16import Elm.Utils ((|>))
19data Type
20 = Lambda Type Type
21 | Var String
22 | Type String
23 | App Type [Type]
24 | Record [(String, Type)] (Maybe Type)
27-- TO STRING
29data Context = None | ADT | Function
32toString :: Type -> String
33toString tipe =
34 toStringHelp None tipe
37toStringHelp :: Context -> Type -> String
38toStringHelp context tipe =
39 case tipe of
40 Lambda t1 t2 ->
41 let string = toStringHelp Function t1 ++ " -> " ++ toString t2
42 in
43 case context of
44 None -> string
45 _ -> parens string
47 Var name -> name
49 Type name -> name
51 App (Type name) args
52 | Help.isTuple name ->
53 map toString args
54 |> List.intercalate ", "
55 |> parens
57 | otherwise ->
58 let string = name ++ spacePrefix (map (toStringHelp ADT) args)
59 in
60 case (context, args) of
61 (ADT, _ : _) -> parens string
62 _ -> string
64 Record fields maybeExtension ->
65 let viewField (key, value) =
66 key ++ " : " ++ toString value
68 viewExtension maybeType =
69 case maybeType of
70 Nothing -> ""
71 Just t -> toString t ++ " | "
72 in
73 sandwich "{ " " }" $
74 concat
75 [ viewExtension maybeExtension
76 , map viewField fields
77 |> List.intercalate ", "
78 ]
81parens :: String -> String
82parens string =
83 sandwich "(" ")" string
86spacePrefix :: [String] -> String
87spacePrefix strings =
88 concatMap (" " ++) strings
91sandwich :: String -> String -> String -> String
92sandwich start stop string =
93 start ++ string ++ stop
96-- JSON for TYPE
98instance Json.ToJSON Type where
99 toJSON tipe =
100 Json.object (getFields tipe)
101 where
102 getFields tipe =
103 case tipe of
104 Lambda t1 t2 ->
105 [ "tag" .= ("lambda" :: Text.Text)
106 , "in" .= Json.toJSON t1
107 , "out" .= Json.toJSON t2
108 ]
110 Var x ->
111 [ "tag" .= ("var" :: Text.Text)
112 , "name" .= Json.toJSON x
113 ]
115 Type name ->
116 [ "tag" .= ("type" :: Text.Text)
117 , "name" .= Json.toJSON name
118 ]
120 App t ts ->
121 [ "tag" .= ("app" :: Text.Text)
122 , "func" .= Json.toJSON t
123 , "args" .= Json.toJSON ts
124 ]
126 Record fields ext ->
127 [ "tag" .= ("record" :: Text.Text)
128 , "fields" .= Json.toJSON (map (Json.toJSON . second Json.toJSON) fields)
129 , "extension" .= Json.toJSON ext
130 ]
133instance Json.FromJSON Type where
134 parseJSON (Json.Object obj) =
135 do tag <- obj .: "tag"
136 case (tag :: String) of
137 "lambda" ->
138 Lambda <$> obj .: "in" <*> obj .: "out"
140 "var" ->
141 Var <$> obj .: "name"
143 "type" ->
144 Type <$> obj .: "name"
146 "app" ->
147 App <$> obj .: "func" <*> obj .: "args"
149 "record" ->
150 Record <$> obj .: "fields" <*> obj .: "extension"
152 _ ->
153 fail $ "Error when decoding type with tag: " ++ tag
156 parseJSON value =
157 fail $ "Cannot decode Value from: " ++ BS.unpack (Json.encode value)