git.iko.soy/elk
on master help sign in
Make it possible to extract types from Module.Interface
09301c6Evan Czaplicki
elm-compiler.cabal+3−1
compare with master
unifiedsplit
@@ -44,11 +44,11 @@ Library
44 exposed-modules:
44 exposed-modules:
45 Elm.Compiler,
45 Elm.Compiler,
46 Elm.Compiler.Module,
46 Elm.Compiler.Module,
47+ Elm.Compiler.Type,
47 Elm.Docs,
48 Elm.Docs,
48 Elm.Utils
49 Elm.Utils
49
50
50 other-modules:
51 other-modules:
51− Elm.Compiler.Version,
52 AST.Annotation,
52 AST.Annotation,
53 AST.Declaration,
53 AST.Declaration,
54 AST.Expression.General,
54 AST.Expression.General,
@@ -63,6 +63,8 @@ Library
63 AST.Type,
63 AST.Type,
64 AST.Variable,
64 AST.Variable,
65 Compile,
65 Compile,
66+ Elm.Compiler.Type.Extract,
67+ Elm.Compiler.Version,
66 Generate.JavaScript,
68 Generate.JavaScript,
67 Generate.JavaScript.Helpers,
69 Generate.JavaScript.Helpers,
68 Generate.JavaScript.Ports,
70 Generate.JavaScript.Ports,
src/Docs.hs+4−31
@@ -13,10 +13,8 @@ import qualified Data.Aeson.Encode.Pretty as Json
13import qualified Data.Map as Map
13import qualified Data.Map as Map
14import qualified Data.ByteString.Lazy.Char8 as BS
14import qualified Data.ByteString.Lazy.Char8 as BS
15
15
16−import qualified AST.Type as Type
17import qualified AST.Declaration as Decl
16import qualified AST.Declaration as Decl
18import qualified AST.Expression.Source as Source
17import qualified AST.Expression.Source as Source
19−import qualified AST.Variable as Var
20
18
21import Text.Parsec hiding (newline, spaces)
19import Text.Parsec hiding (newline, spaces)
22import qualified Parse.Declaration as Parse (typeDecl, infixDecl)
20import qualified Parse.Declaration as Parse (typeDecl, infixDecl)
@@ -24,6 +22,7 @@ import qualified Parse.Expression as Parse (typeAnnotation)
24import qualified Parse.Helpers as Parse
22import qualified Parse.Helpers as Parse
25import qualified Parse.Module as Parse (header)
23import qualified Parse.Module as Parse (header)
26import qualified Elm.Compiler.Module as Module
24import qualified Elm.Compiler.Module as Module
25+import qualified Elm.Compiler.Type.Extract as Type
27import qualified Elm.Docs as Docs
26import qualified Elm.Docs as Docs
28
27
29
28
@@ -172,18 +171,18 @@ collectInfo (comment, decl) info =
172 case def of
171 case def of
173 Source.Definition _ _ -> error errorMessage
172 Source.Definition _ _ -> error errorMessage
174 Source.TypeAnnotation name tipe ->
173 Source.TypeAnnotation name tipe ->
175− let value = Docs.Value name comment (toDocType tipe) Nothing
174+ let value = Docs.Value name comment (Type.fromInternalType tipe) Nothing
176 in
175 in
177 info { values = Map.insert name value (values info) }
176 info { values = Map.insert name value (values info) }
178
177
179 Decl.Datatype name args cases ->
178 Decl.Datatype name args cases ->
180− let cases' = map (second (map toDocType)) cases
179+ let cases' = map (second (map Type.fromInternalType)) cases
181 union = Docs.Union name comment args cases'
180 union = Docs.Union name comment args cases'
182 in
181 in
183 info { unions = union : unions info }
182 info { unions = union : unions info }
184
183
185 Decl.TypeAlias name args tipe ->
184 Decl.TypeAlias name args tipe ->
186− let alias = Docs.Alias name comment args (toDocType tipe)
185+ let alias = Docs.Alias name comment args (Type.fromInternalType tipe)
187 in
186 in
188 info { aliases = alias : aliases info }
187 info { aliases = alias : aliases info }
189
188
@@ -201,29 +200,3 @@ errorMessage =
201 "there appears to be a bug in this tool.\n" ++
200 "there appears to be a bug in this tool.\n" ++
202 "Please report it to <https://github.com/elm-lang/Elm/issues>"
201 "Please report it to <https://github.com/elm-lang/Elm/issues>"
203
202
204−
205−-- AST TYPE TO DOC TYPE
206−
207−toDocType :: Type.Type Var.Raw -> Docs.Type
208−toDocType astType =
209− case astType of
210− Type.Lambda t1 t2 ->
211− Docs.Lambda (toDocType t1) (toDocType t2)
212−
213− Type.Var x ->
214− Docs.Var x
215−
216− Type.Type (Var.Raw name) ->
217− Docs.Type name
218−
219− Type.App t ts ->
220− Docs.App (toDocType t) (map toDocType ts)
221−
222− Type.Record fields ext ->
223− Docs.Record (map (second toDocType) fields) (fmap toDocType ext)
224−
225− Type.Aliased _ t ->
226− toDocType t
227−
228−
229−
src/Elm/Compiler/Module.hs+15−3
@@ -5,6 +5,7 @@ module Elm.Compiler.Module
5 , hyphenate, dehyphenate
5 , hyphenate, dehyphenate
6 , defaultImports
6 , defaultImports
7 , interfacePorts
7 , interfacePorts
8+ , interfaceTypes
8 )
9 )
9 where
10 where
10
11
@@ -18,8 +19,12 @@ import System.FilePath ((</>))
18
19
19import qualified AST.Module as Module
20import qualified AST.Module as Module
20import qualified Transform.AddDefaultImports as Defaults
21import qualified Transform.AddDefaultImports as Defaults
22+import qualified Elm.Compiler.Type as Type
23+import qualified Elm.Compiler.Type.Extract as Extract
21
24
22
25
26+-- EXPOSED TYPES
27+
23type Interface = Module.Interface
28type Interface = Module.Interface
24
29
25
30
@@ -32,12 +37,19 @@ defaultImports =
32 map Name (Map.keys Defaults.defaultImports)
37 map Name (Map.keys Defaults.defaultImports)
33
38
34
39
40+-- POKING AROUND INTERFACES
41+
35interfacePorts :: Interface -> [String]
42interfacePorts :: Interface -> [String]
36interfacePorts interface =
43interfacePorts interface =
37 Module.iPorts interface
44 Module.iPorts interface
38
45
39
46
47+interfaceTypes :: Interface -> Map.Map String Type.Type
48+interfaceTypes interface =
49+ Map.map Extract.fromInternalType (Module.iTypes interface)
50+
51+
40−-- STRING CONVERSIONS
52+-- STRING CONVERSIONS for NAMES
41
53
42nameToPath :: Name -> FilePath
54nameToPath :: Name -> FilePath
43nameToPath (Name names) =
55nameToPath (Name names) =
@@ -83,7 +95,7 @@ fromString sep raw =
83 Char.isAlphaNum char || char `elem` "_'"
95 Char.isAlphaNum char || char `elem` "_'"
84
96
85
97
86−-- JSON CONVERSIONS
98+-- JSON for NAME
87
99
88instance Json.ToJSON Name where
100instance Json.ToJSON Name where
89 toJSON name =
101 toJSON name =
@@ -97,4 +109,4 @@ instance Json.FromJSON Name where
97 Nothing -> fail (rawName ++ " is not a valid module name")
109 Nothing -> fail (rawName ++ " is not a valid module name")
98 Just name -> return name
110 Just name -> return name
99
111
100− parseJSON _ = mzero
112+ parseJSON _ = mzero
src/Elm/Compiler/Type.hsnew file+99
@@ -0,0 +1,99 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Elm.Compiler.Type
3+ ( Type(..)
4+ , toString
5+ ) where
6+
7+import Control.Applicative ((<$>), (<*>))
8+import Control.Arrow (second)
9+import Data.Aeson ((.:), (.:?), (.=))
10+import qualified Data.Aeson as Json
11+import qualified Data.ByteString.Lazy.Char8 as BS
12+import qualified Data.Text as Text
13+
14+import qualified AST.Type as Type
15+import qualified AST.Variable as Var
16+
17+
18+data Type
19+ = Lambda Type Type
20+ | Var String
21+ | Type String
22+ | App Type [Type]
23+ | Record [(String, Type)] (Maybe Type)
24+
25+
26+-- TO STRING
27+
28+toString :: Type -> String
29+toString tipe =
30+ case tipe of
31+ Lambda t t' -> undefined
32+ Var x -> undefined
33+ Type name -> undefined
34+ App t ts -> undefined
35+ Record fields maybeExtension -> undefined
36+
37+
38+-- JSON for TYPE
39+
40+instance Json.ToJSON Type where
41+ toJSON tipe =
42+ Json.object (getFields tipe)
43+ where
44+ getFields tipe =
45+ case tipe of
46+ Lambda t1 t2 ->
47+ [ "tag" .= ("lambda" :: Text.Text)
48+ , "in" .= Json.toJSON t1
49+ , "out" .= Json.toJSON t2
50+ ]
51+
52+ Var x ->
53+ [ "tag" .= ("var" :: Text.Text)
54+ , "name" .= Json.toJSON x
55+ ]
56+
57+ Type name ->
58+ [ "tag" .= ("type" :: Text.Text)
59+ , "name" .= Json.toJSON name
60+ ]
61+
62+ App t ts ->
63+ [ "tag" .= ("app" :: Text.Text)
64+ , "func" .= Json.toJSON t
65+ , "args" .= Json.toJSON ts
66+ ]
67+
68+ Record fields ext ->
69+ [ "tag" .= ("record" :: Text.Text)
70+ , "fields" .= Json.toJSON (map (Json.toJSON . second Json.toJSON) fields)
71+ , "extension" .= Json.toJSON ext
72+ ]
73+
74+
75+instance Json.FromJSON Type where
76+ parseJSON (Json.Object obj) =
77+ do tag <- obj .: "tag"
78+ case (tag :: String) of
79+ "lambda" ->
80+ Lambda <$> obj .: "in" <*> obj .: "out"
81+
82+ "var" ->
83+ Var <$> obj .: "name"
84+
85+ "type" ->
86+ Type <$> obj .: "name"
87+
88+ "app" ->
89+ App <$> obj .: "func" <*> obj .: "args"
90+
91+ "record" ->
92+ Record <$> obj .: "fields" <*> obj .: "extension"
93+
94+ _ ->
95+ fail $ "Error when decoding type with tag: " ++ tag
96+
97+
98+ parseJSON value =
99+ fail $ "Cannot decode Value from: " ++ BS.unpack (Json.encode value)
src/Elm/Compiler/Type/Extract.hsnew file+30
@@ -0,0 +1,30 @@
1+module Elm.Compiler.Type.Extract where
2+
3+import Control.Arrow (second)
4+import qualified AST.Type as Type
5+import qualified AST.Variable as Var
6+import qualified Elm.Compiler.Type as T
7+
8+
9+-- INTERNAL TYPE to PUBLIC TYPE
10+
11+fromInternalType :: Var.ToString a => Type.Type a -> T.Type
12+fromInternalType astType =
13+ case astType of
14+ Type.Lambda t1 t2 ->
15+ T.Lambda (fromInternalType t1) (fromInternalType t2)
16+
17+ Type.Var x ->
18+ T.Var x
19+
20+ Type.Type var ->
21+ T.Type (Var.toString var)
22+
23+ Type.App t ts ->
24+ T.App (fromInternalType t) (map fromInternalType ts)
25+
26+ Type.Record fields ext ->
27+ T.Record (map (second fromInternalType) fields) (fmap fromInternalType ext)
28+
29+ Type.Aliased _ t ->
30+ fromInternalType t
src/Elm/Docs.hs+4−73
@@ -10,6 +10,7 @@ import qualified Data.ByteString.Lazy.Char8 as BS
10import qualified Data.Text as Text
10import qualified Data.Text as Text
11
11
12import qualified Elm.Compiler.Module as Module
12import qualified Elm.Compiler.Module as Module
13+import qualified Elm.Compiler.Type as Type
13
14
14
15
15data Documentation = Documentation
16data Documentation = Documentation
@@ -25,7 +26,7 @@ data Alias = Alias
25 { aliasName :: String
26 { aliasName :: String
26 , aliasComment :: String
27 , aliasComment :: String
27 , aliasArgs :: [String]
28 , aliasArgs :: [String]
28− , aliasType :: Type
29+ , aliasType :: Type.Type
29 }
30 }
30
31
31
32
@@ -33,26 +34,18 @@ data Union = Union
33 { unionName :: String
34 { unionName :: String
34 , unionComment :: String
35 , unionComment :: String
35 , unionArgs :: [String]
36 , unionArgs :: [String]
36− , unionCases :: [(String, [Type])]
37+ , unionCases :: [(String, [Type.Type])]
37 }
38 }
38
39
39
40
40data Value = Value
41data Value = Value
41 { valueName :: String
42 { valueName :: String
42 , valueComment :: String
43 , valueComment :: String
43− , valueType :: Type
44+ , valueType :: Type.Type
44 , valueAssocPrec :: Maybe (String,Int)
45 , valueAssocPrec :: Maybe (String,Int)
45 }
46 }
46
47
47
48
48−data Type
49− = Lambda Type Type
50− | Var String
51− | Type String
52− | App Type [Type]
53− | Record [(String, Type)] (Maybe Type)
54−
55−
56-- JSON for DOCUMENTATION
49-- JSON for DOCUMENTATION
57
50
58instance Json.ToJSON Documentation where
51instance Json.ToJSON Documentation where
@@ -156,65 +149,3 @@ instance Json.FromJSON Value where
156 parseJSON value =
149 parseJSON value =
157 fail $ "Cannot decode Value from: " ++ BS.unpack (Json.encode value)
150 fail $ "Cannot decode Value from: " ++ BS.unpack (Json.encode value)
158
151
159−
160−-- JSON for TYPE
161−
162−instance Json.ToJSON Type where
163− toJSON tipe =
164− Json.object (getFields tipe)
165− where
166− getFields tipe =
167− case tipe of
168− Lambda t1 t2 ->
169− [ "tag" .= ("lambda" :: Text.Text)
170− , "in" .= Json.toJSON t1
171− , "out" .= Json.toJSON t2
172− ]
173−
174− Var x ->
175− [ "tag" .= ("var" :: Text.Text)
176− , "name" .= Json.toJSON x
177− ]
178−
179− Type name ->
180− [ "tag" .= ("type" :: Text.Text)
181− , "name" .= Json.toJSON name
182− ]
183−
184− App t ts ->
185− [ "tag" .= ("app" :: Text.Text)
186− , "func" .= Json.toJSON t
187− , "args" .= Json.toJSON ts
188− ]
189−
190− Record fields ext ->
191− [ "tag" .= ("record" :: Text.Text)
192− , "fields" .= Json.toJSON (map (Json.toJSON . second Json.toJSON) fields)
193− , "extension" .= Json.toJSON ext
194− ]
195−
196−instance Json.FromJSON Type where
197− parseJSON (Json.Object obj) =
198− do tag <- obj .: "tag"
199− case (tag :: String) of
200− "lambda" ->
201− Lambda <$> obj .: "in" <*> obj .: "out"
202−
203− "var" ->
204− Var <$> obj .: "name"
205−
206− "type" ->
207− Type <$> obj .: "name"
208−
209− "app" ->
210− App <$> obj .: "func" <*> obj .: "args"
211−
212− "record" ->
213− Record <$> obj .: "fields" <*> obj .: "extension"
214−
215− _ ->
216− fail $ "Error when decoding type with tag: " ++ tag
217−
218−
219− parseJSON value =
220− fail $ "Cannot decode Value from: " ++ BS.unpack (Json.encode value)