git.iko.soy/elk
on master help sign in
Get public types working again
22736cfEvan Czaplicki
src/Elm/Compiler/Type.hs+80−91
compare with master
unifiedsplit
@@ -5,24 +5,24 @@ module Elm.Compiler.Type
5 , Format(..)
5 , Format(..)
6 , toString
6 , toString
7 , Program(..)
7 , Program(..)
8+ , Alias(..)
9+ , Union(..)
8 , encode
10 , encode
9 , decoder
11 , decoder
10 , encodeProgram
12 , encodeProgram
11 )
13 )
12 where
14 where
13
15
14−import Control.Arrow ((***))
16+
15−import Data.Aeson ((.:))
16−import qualified Data.Aeson as Aeson
17−import qualified Data.Text as Text
18import Data.Text (Text)
17import Data.Text (Text)
18+import qualified Data.Text as Text
19+import qualified Data.Text.Encoding as Text
19import qualified Text.PrettyPrint as P
20import qualified Text.PrettyPrint as P
20import Text.PrettyPrint ((<+>))
21import Text.PrettyPrint ((<+>))
21
22
22−import qualified AST.Helpers as Help
23+import qualified AST.Source as Src
23−import qualified AST.Type as Type
24+import qualified Elm.Name as N
24−import qualified AST.Variable as Var
25−import qualified Parse.Helpers as Parse
25+import qualified Parse.Primitives as Parse
26import qualified Parse.Type as Type
26import qualified Parse.Type as Type
27import qualified Reporting.Annotation as A
27import qualified Reporting.Annotation as A
28import qualified Json.Decode as Decode
28import qualified Json.Decode as Decode
@@ -36,19 +36,25 @@ import Json.Encode ((==>))
36
36
37data Type
37data Type
38 = Lambda Type Type
38 = Lambda Type Type
39− | Var Text
39+ | Var N.Name
40− | Type Text [Type]
40+ | Type N.Name [Type]
41− | Record [(Text, Type)] (Maybe Type)
41+ | Record [(N.Name, Type)] (Maybe Type)
42+ | Unit
43+ | Tuple Type Type [Type]
42
44
43
45
44data Program =
46data Program =
45 Program
47 Program
46 { _message :: Type
48 { _message :: Type
47− , _aliases :: [( Text, [Text], Type )]
49+ , _aliases :: [Alias]
48− , _unions :: [( Text, [Text], [(Text, [Type])] )]
50+ , _unions :: [Union]
49 }
51 }
50
52
51
53
54+data Alias = Alias N.Name [N.Name] Type
55+data Union = Union N.Name [N.Name] [(N.Name, [Type])]
56+
57+
52
58
53-- TO STRING
59-- TO STRING
54
60
@@ -89,30 +95,38 @@ toDoc context tipe =
89 Var name ->
95 Var name ->
90 P.text (Text.unpack name)
96 P.text (Text.unpack name)
91
97
92− Type name [] ->
98+ Unit ->
93− P.text (if name == Help.zeroTuple then "()" else Text.unpack name)
99+ "()"
94−
100+
95− Type name arguments@(arg:args) ->
101+ Tuple a b cs ->
96− if Help.isTuple name then
97− P.sep
102+ P.sep
103+ [ P.cat $
104+ [ "(" <+> toDoc None a
105+ , "," <+> toDoc None b
106+ ]
98− [ P.cat ("(" <+> toDoc None arg : map (\a -> "," <+> toDoc None a) args)
107+ ++ map ("," <+>) (map (toDoc None) cs)
99− , ")"
108+ , ")"
100− ]
109+ ]
101−
110+
102− else
111+ Type name args ->
112+ case args of
113+ [] ->
114+ P.text (Text.unpack name)
115+
116+ _ ->
103− let
117+ let
104− application =
118+ application =
105− P.hang
119+ P.hang
106− (P.text (Text.unpack name))
120+ (P.text (Text.unpack name))
107− 2
121+ 2
108− (P.sep $ map (toDoc InType) arguments)
122+ (P.sep $ map (toDoc InType) args)
109− in
123+ in
110− case context of
124+ case context of
111− InType ->
125+ InType ->
112− P.parens application
126+ P.parens application
113
127
114− _ ->
128+ _ ->
115− application
129+ application
116
130
117 Record _ _ ->
131 Record _ _ ->
118 case flattenRecord tipe of
132 case flattenRecord tipe of
@@ -175,66 +189,41 @@ encode tipe =
175
189
176decoder :: Decode.Decoder Type
190decoder :: Decode.Decoder Type
177decoder =
191decoder =
178− Decode.oneOf
179− [
180− do txt <- Decode.text
192+ do txt <- Decode.text
181− case Parse.run Type.expression (Text.replace "'" "_" txt) of
193+ case Parse.run Type.expression (Text.encodeUtf8 (Text.replace "'" "_" txt)) of
182− Left _ ->
194+ Left _ ->
183− Decode.fail "Expecting a type, like (String -> Int)"
195+ Decode.fail "Expecting a type, like (String -> Int)"
184−
185− Right (tipe, _, _) ->
186− Decode.succeed (fromRawType tipe)
187− ,
188− Decode.aeson
189− ]
190−
191
196
192−instance Aeson.FromJSON Type where
197+ Right (tipe, _, _) ->
193− parseJSON =
198+ Decode.succeed (fromRawType tipe)
194− Aeson.withObject "Type" $ \object ->
195− do tag <- object .: "tag"
196− case (tag :: String) of
197− "lambda" ->
198− Lambda <$> object .: "in" <*> object .: "out"
199
199
200− "var" ->
201− Var <$> object .: "name"
202
200
203− "type" ->
204− do name <- object .: "name"
205− return (Type name [])
206−
207− "app" ->
208− do func <- object .: "func"
209− args <- object .: "args"
210− case func of
211− Type name [] ->
212− return (Type name args)
213−
214− _ ->
215− fail "unexpected type application"
216−
217− "record" ->
218− Record <$> object .: "fields" <*> object .: "extension"
219−
220− _ ->
221− fail $ "Error when decoding type with tag: " ++ tag
222−
223−
224−fromRawType :: Type.Raw -> Type
201+fromRawType :: Src.Type -> Type
225−fromRawType (A.A _ astType) =
202+fromRawType (A.At _ astType) =
226 case astType of
203 case astType of
227− Type.RLambda t1 t2 ->
204+ Src.TLambda t1 t2 ->
228 Lambda (fromRawType t1) (fromRawType t2)
205 Lambda (fromRawType t1) (fromRawType t2)
229
206
230− Type.RVar x ->
207+ Src.TVar x ->
231 Var x
208 Var x
232
209
210+ Src.TUnit ->
211+ Unit
212+
213+ Src.TTuple a b cs ->
214+ Tuple
215+ (fromRawType a)
216+ (fromRawType b)
217+ (map fromRawType cs)
218+
233− Type.RType (A.A _ name) args ->
219+ Src.TType _ _ name args ->
234− Type (Var.rawToText name) (map fromRawType args)
220+ Type name (map fromRawType args)
235
221
236− Type.RRecord fields ext ->
222+ Src.TRecord fields ext ->
223+ let fromField (A.At _ field, tipe) = (field, fromRawType tipe) in
224+ Record
225+ (map fromField fields)
237− Record (map (A.drop *** fromRawType) fields) (fmap fromRawType ext)
226+ (fmap fromRawType ext)
238
227
239
228
240
229
@@ -250,8 +239,8 @@ encodeProgram (Program msg aliases unions) =
250 ]
239 ]
251
240
252
241
253−toAliasField :: ( Text, [Text], Type ) -> ( String, Encode.Value )
242+toAliasField :: Alias -> ( String, Encode.Value )
254−toAliasField ( name, args, tipe ) =
243+toAliasField (Alias name args tipe) =
255 Text.unpack name ==>
244 Text.unpack name ==>
256 Encode.object
245 Encode.object
257 [ "args" ==> Encode.list Encode.text args
246 [ "args" ==> Encode.list Encode.text args
@@ -259,8 +248,8 @@ toAliasField ( name, args, tipe ) =
259 ]
248 ]
260
249
261
250
262−toUnionField :: ( Text, [Text], [(Text, [Type])] ) -> ( String, Encode.Value )
251+toUnionField :: Union -> ( String, Encode.Value )
263−toUnionField ( name, args, constructors ) =
252+toUnionField (Union name args constructors) =
264 Text.unpack name ==>
253 Text.unpack name ==>
265 Encode.object
254 Encode.object
266 [ "args" ==> Encode.list Encode.text args
255 [ "args" ==> Encode.list Encode.text args
src/Elm/Compiler/Type/Extract.hs+175−91
@@ -1,158 +1,242 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE Rank2Types #-}
3module Elm.Compiler.Type.Extract
4module Elm.Compiler.Type.Extract
4− ( extract
5+ ( fromAnnotation
5− , extractProgram
6+ , fromType
7+ , fromProgram
6 )
8 )
7 where
9 where
8
10
9−import qualified Control.Monad.Writer.Strict as Writer
11+
12+import Data.Map ((!))
10import qualified Data.Map as Map
13import qualified Data.Map as Map
11import qualified Data.Maybe as Maybe
14import qualified Data.Maybe as Maybe
15+import Data.Monoid ((<>))
12import qualified Data.Set as Set
16import qualified Data.Set as Set
13−import Data.Text (Text)
14
17
15−import qualified AST.Module as Module
18+import qualified AST.Canonical as Can
19+import qualified AST.Optimized as Opt
16import qualified AST.Module.Name as ModuleName
20import qualified AST.Module.Name as ModuleName
17−import qualified AST.Type as T
21+import qualified AST.Utils.Type as Type
22+import qualified Elm.Compiler.Type as T
18−import qualified AST.Variable as Var
23+import qualified Elm.Interface as I
19−import Elm.Compiler.Type (Type(..), Program(Program))
24+import qualified Elm.Name as N
20
25
21
26
22
27
23-- EXTRACTION
28-- EXTRACTION
24
29
25
30
26−extract :: T.Canonical -> Type
31+fromAnnotation :: Can.Annotation -> T.Type
27−extract astType =
32+fromAnnotation (Can.Forall _ astType) =
28− fst $ Writer.runWriter $ extractHelp astType
33+ fromType astType
29
34
30
35
31−type Deps =
36+fromType :: Can.Type -> T.Type
32− ( Set.Set Var.Canonical -- aliases
37+fromType astType =
33− , Set.Set Var.Canonical -- unions
38+ snd (run (extract astType))
34− )
35
39
36
40
37−diff :: Deps -> Deps -> Deps
41+extract :: Can.Type -> Extractor T.Type
38−diff (oldAliases, oldUnions) (newAliases, newUnions) =
42+extract astType =
39− ( Set.difference newAliases oldAliases
43+ case astType of
40− , Set.difference newUnions oldUnions
44+ Can.TLambda arg result ->
41− )
45+ T.Lambda
46+ <$> extract arg
47+ <*> extract result
42
48
49+ Can.TVar x ->
50+ pure (T.Var x)
43
51
44−extractHelp :: T.Canonical -> Writer.Writer Deps Type
52+ Can.TType home name args ->
45−extractHelp astType =
53+ addUnion (Opt.Global home name) (T.Type (toPublicName home name))
46− case astType of
54+ <*> traverse extract args
47− T.Lambda arg result ->
55+
48− Lambda <$> extractHelp arg <*> extractHelp result
56+ Can.TRecord fields ext ->
57+ T.Record
58+ <$> fmap Map.toList (traverse extract fields)
59+ <*> traverse extract ext
49
60
50− T.Var x ->
61+ Can.TUnit ->
51− return (Var x)
62+ pure T.Unit
52
63
53− T.Type var args ->
64+ Can.TTuple a b maybeC ->
54− do Writer.tell ( Set.empty, Set.singleton var )
65+ T.Tuple
55− Type (Var.toText var) <$> traverse extractHelp args
66+ <$> extract a
67+ <*> extract b
68+ <*> traverse extract (Maybe.maybeToList maybeC)
56
69
57− T.Record fields ext ->
70+ Can.TAlias home name args aliasType ->
58− Record
71+ do addAlias (Opt.Global home name) ()
59− <$> traverse (traverse extractHelp) fields
72+ _ <- extract (Type.dealias args aliasType)
60− <*> traverse extractHelp ext
73+ T.Type (toPublicName home name)
74+ <$> traverse (extract . snd) args
61
75
62− T.Aliased name args aliasedType ->
76+
63− do Writer.tell ( Set.singleton name, Set.empty )
77+toPublicName :: ModuleName.Canonical -> N.Name -> N.Name
64− _ <- extractHelp (T.dealias args aliasedType)
78+toPublicName (ModuleName.Canonical _ home) name =
65− Type (Var.toText name) <$> traverse (extractHelp . snd) args
79+ home <> "." <> name
66
80
67
81
68
82
69-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
83-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
70
84
71
85
72−extractProgram :: Module.Interfaces -> ModuleName.Canonical -> Maybe Program
86+fromProgram :: I.Interfaces -> ModuleName.Canonical -> Maybe T.Program
73−extractProgram interfaces name =
87+fromProgram interfaces name =
74 do iface <- Map.lookup name interfaces
88 do iface <- Map.lookup name interfaces
75− mainType <- Map.lookup "main" (Module.iTypes iface)
89+ mainType <- Map.lookup "main" (I._types iface)
76−
77− message <-
90+ message <- getMessage mainType
78− case T.deepDealias mainType of
79− T.Type _program [_flags, _model, msg] -> Just msg
80− T.Type _node [msg] -> Just msg
81− _ -> Nothing
82
91
83− let (msgType, msgDeps) = Writer.runWriter (extractHelp message)
92+ let (msgDeps, msgType) = run (extract message)
84− let (aliases, unions) = extractTransitive interfaces mempty msgDeps
93+ let (aliases, unions) = extractTransitive interfaces noDeps msgDeps
85− Just (Program msgType aliases unions)
94+ Just (T.Program msgType aliases unions)
86
95
87
96
88−type Alias =
97+getMessage :: Can.Annotation -> Maybe Can.Type
89− ( Text, [Text], Type )
98+getMessage (Can.Forall _ mainType) =
99+ case Type.deepDealias mainType of
100+ Can.TType _ _program [_flags, _model, msg] ->
101+ Just msg
90
102
103+ Can.TType _ _node [msg] ->
104+ Just msg
91
105
92−type Union =
106+ _ ->
93− ( Text, [Text], [(Text, [Type])] )
107+ Nothing
94
108
95
109
96−extractTransitive :: Module.Interfaces -> Deps -> Deps -> ( [Alias], [Union] )
110+extractTransitive :: I.Interfaces -> Deps -> Deps -> ( [T.Alias], [T.Union] )
97−extractTransitive interfaces oldDeps currentDeps =
111+extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =
98 let
112 let
99− (aliases, unions) =
113+ aliases = Set.difference nextAliases seenAliases
100− diff oldDeps currentDeps
114+ unions = Set.difference nextUnions seenUnions
101 in
115 in
102 if Set.null aliases && Set.null unions then
116 if Set.null aliases && Set.null unions then
103 ( [], [] )
117 ( [], [] )
104
118
105 else
119 else
106 let
120 let
107− (result, newDeps) =
121+ (newDeps, result) =
108− Writer.runWriter $ do
122+ run $
123+ (,)
109− publicAliases <- mapM (extractAlias interfaces) (Set.toList aliases)
124+ <$> traverse (extractAlias interfaces) (Set.toList aliases)
110− publicUnions <- mapM (extractUnion interfaces) (Set.toList unions)
125+ <*> traverse (extractUnion interfaces) (Set.toList unions)
111− return ( Maybe.catMaybes publicAliases, Maybe.catMaybes publicUnions )
126+
127+ oldDeps =
128+ Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions)
112
129
113 remainingResult =
130 remainingResult =
114− extractTransitive interfaces (mappend oldDeps currentDeps) newDeps
131+ extractTransitive interfaces oldDeps newDeps
115 in
132 in
116 mappend result remainingResult
133 mappend result remainingResult
117
134
118
135
119−extractAlias :: Module.Interfaces -> Var.Canonical -> Writer.Writer Deps (Maybe Alias)
136+extractAlias :: I.Interfaces -> Opt.Global -> Extractor T.Alias
120−extractAlias interfaces var =
137+extractAlias interfaces (Opt.Global home name) =
121 let
138 let
122− toAlias (args, tipe) =
139+ (I.Interface _ _ aliases _) = interfaces ! home
123− (,,) (Var.toText var) args <$> extractHelp tipe
140+ (Can.Alias args aliasType _) = aliases ! name
124 in
141 in
125− traverse toAlias (get Module.iAliases interfaces var)
142+ T.Alias (toPublicName home name) args <$> extract aliasType
126
143
127
144
128−extractUnion :: Module.Interfaces -> Var.Canonical -> Writer.Writer Deps (Maybe Union)
145+extractUnion :: I.Interfaces -> Opt.Global -> Extractor T.Union
129−extractUnion interfaces var =
146+extractUnion interfaces (Opt.Global home name) =
130 let
147 let
131− toUnion (args, constructors) =
148+ (I.Interface _ unions _ _) = interfaces ! home
132− (,,) (Var.toText var) args
149+ (Can.Union args constructors) = unions ! name
133− <$> traverse (traverse (traverse extractHelp)) constructors
134 in
150 in
135− traverse toUnion (get Module.iUnions interfaces var)
151+ T.Union (toPublicName home name) args
152+ <$> traverse (traverse (traverse extract)) constructors
136
153
137
154
138−get :: (Module.Interface -> Map.Map Text a) -> Module.Interfaces -> Var.Canonical -> Maybe a
139−get getInfo interfaces var =
140− do (home, name) <- getHome var
141− iface <- Map.lookup home interfaces
142− Map.lookup name (getInfo iface)
143
155
156+-- DEPS
157+
158+
159+data Deps =
160+ Deps
161+ { _aliases :: Set.Set Opt.Global
162+ , _unions :: Set.Set Opt.Global
163+ }
144
164
145−getHome :: Var.Canonical -> Maybe (ModuleName.Canonical, Text)
146−getHome (Var.Canonical home name) =
147− case home of
148− Var.BuiltIn ->
149− Nothing
150
165
151− Var.Module moduleName ->
166+{-# NOINLINE noDeps #-}
152− Just (moduleName, name)
167+noDeps :: Deps
168+noDeps =
169+ Deps Set.empty Set.empty
153
170
154− Var.TopLevel moduleName ->
155− Just (moduleName, name)
156
171
157− Var.Local ->
172+
158− Nothing
173+-- EXTRACTOR
174+
175+
176+newtype Extractor a =
177+ Extractor (
178+ forall result.
179+ Set.Set Opt.Global
180+ -> Set.Set Opt.Global
181+ -> (Set.Set Opt.Global -> Set.Set Opt.Global -> a -> result)
182+ -> result
183+ )
184+
185+
186+run :: Extractor a -> (Deps, a)
187+run (Extractor k) =
188+ k Set.empty Set.empty $ \aliases unions value ->
189+ ( Deps aliases unions, value )
190+
191+
192+addAlias :: Opt.Global -> a -> Extractor a
193+addAlias alias value =
194+ Extractor $ \aliases unions ok ->
195+ ok (Set.insert alias aliases) unions value
196+
197+
198+addUnion :: Opt.Global -> a -> Extractor a
199+addUnion union value =
200+ Extractor $ \aliases unions ok ->
201+ ok aliases (Set.insert union unions) value
202+
203+
204+instance Functor Extractor where
205+ fmap func (Extractor k) =
206+ Extractor $ \aliases unions ok ->
207+ let
208+ ok1 a1 u1 value =
209+ ok a1 u1 (func value)
210+ in
211+ k aliases unions ok1
212+
213+
214+instance Applicative Extractor where
215+ pure value =
216+ Extractor $ \aliases unions ok ->
217+ ok aliases unions value
218+
219+ (<*>) (Extractor kf) (Extractor kv) =
220+ Extractor $ \aliases unions ok ->
221+ let
222+ ok1 a1 u1 func =
223+ let
224+ ok2 a2 u2 value =
225+ ok a2 u2 (func value)
226+ in
227+ kv a1 u1 ok2
228+ in
229+ kf aliases unions ok1
230+
231+
232+instance Monad Extractor where
233+ return = pure
234+
235+ (>>=) (Extractor ka) callback =
236+ Extractor $ \aliases unions ok ->
237+ let
238+ ok1 a1 u1 value =
239+ case callback value of
240+ Extractor kb -> kb a1 u1 ok
241+ in
242+ ka aliases unions ok1