git.iko.soy/elk
on d87affe help sign in
elk/src/Elm/Compiler/Type.hs
160 lines 4.0 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 "List") [t] ->
52 sandwich "[" "]" (toString t)
54 App (Type name) args
55 | Help.isTuple name ->
56 map toString args
57 |> List.intercalate ", "
58 |> parens
60 | otherwise ->
61 let string = name ++ spacePrefix (map (toStringHelp ADT) args)
62 in
63 case (context, args) of
64 (ADT, _ : _) -> parens string
65 _ -> string
67 Record fields maybeExtension ->
68 let viewField (key, value) =
69 key ++ " : " ++ toString value
71 viewExtension maybeType =
72 case maybeType of
73 Nothing -> ""
74 Just t -> toString t ++ " | "
75 in
76 sandwich "{ " " }" $
77 concat
78 [ viewExtension maybeExtension
79 , map viewField fields
80 |> List.intercalate ", "
81 ]
84parens :: String -> String
85parens string =
86 sandwich "(" ")" string
89spacePrefix :: [String] -> String
90spacePrefix strings =
91 concatMap (" " ++) strings
94sandwich :: String -> String -> String -> String
95sandwich start stop string =
96 start ++ string ++ stop
99-- JSON for TYPE
101instance Json.ToJSON Type where
102 toJSON tipe =
103 Json.object (getFields tipe)
104 where
105 getFields tipe =
106 case tipe of
107 Lambda t1 t2 ->
108 [ "tag" .= ("lambda" :: Text.Text)
109 , "in" .= Json.toJSON t1
110 , "out" .= Json.toJSON t2
111 ]
113 Var x ->
114 [ "tag" .= ("var" :: Text.Text)
115 , "name" .= Json.toJSON x
116 ]
118 Type name ->
119 [ "tag" .= ("type" :: Text.Text)
120 , "name" .= Json.toJSON name
121 ]
123 App t ts ->
124 [ "tag" .= ("app" :: Text.Text)
125 , "func" .= Json.toJSON t
126 , "args" .= Json.toJSON ts
127 ]
129 Record fields ext ->
130 [ "tag" .= ("record" :: Text.Text)
131 , "fields" .= Json.toJSON (map (Json.toJSON . second Json.toJSON) fields)
132 , "extension" .= Json.toJSON ext
133 ]
136instance Json.FromJSON Type where
137 parseJSON (Json.Object obj) =
138 do tag <- obj .: "tag"
139 case (tag :: String) of
140 "lambda" ->
141 Lambda <$> obj .: "in" <*> obj .: "out"
143 "var" ->
144 Var <$> obj .: "name"
146 "type" ->
147 Type <$> obj .: "name"
149 "app" ->
150 App <$> obj .: "func" <*> obj .: "args"
152 "record" ->
153 Record <$> obj .: "fields" <*> obj .: "extension"
155 _ ->
156 fail $ "Error when decoding type with tag: " ++ tag
159 parseJSON value =
160 fail $ "Cannot decode Value from: " ++ BS.unpack (Json.encode value)