git.iko.soy/elk
on master help sign in
Make sure type information is available for --debug metadata

Before I was trimming interfaces down to only the publicly exposed API. This meant that .elmi files were smaller, and there was probably some performance benefit. BUT I actually need to know about all type shapes in --debug so that the debugger can tell if your message types have changed. So even if things are private, the need to get sucked up by that code.

commitc224b36749ea7eef60f8176556571fcf112008fc authorEvan Czaplicki <evancz@users.noreply.github.com> dateTue 10 Apr 2018, 12:50 (9 years ago) parent78cd7e7
3 files changed+161−30
compare with master
unifiedsplit
compiler/src/Canonicalize/Environment/Foreign.hs+25−7 compiler/src/Elm/Compiler/Type/Extract.hs+2−2 compiler/src/Elm/Interface.hs+134−21
compiler/src/Canonicalize/Environment/Foreign.hs+25−7
@@ -84,8 +84,8 @@ addImport (State vs ts cs bs qvs qts qcs) (Import home (I.Interface defs unions
8484 let
8585 !rawTypeInfo =
8686 Map.union
87− (Map.mapWithKey (unionToType home) unions)
88− (Map.mapWithKey (aliasToType home) aliases)
87+ (Map.mapMaybeWithKey (unionToType home) unions)
88+ (Map.mapMaybeWithKey (aliasToType home) aliases)
8989
9090 !vars = Map.map (Map.singleton home) defs
9191 !types = Map.map (Map.singleton home . fst) rawTypeInfo
@@ -123,11 +123,16 @@ addQualified prefix exposed qualified =
123123
124124
125125
126−-- CANONICAL DATA TO ENVIRONMENT DATA
126+-- UNION
127127
128128
129−unionToType :: ModuleName.Canonical -> N.Name -> Can.Union -> (Env.Type, Env.Exposed Env.Ctor)
130−unionToType home name union@(Can.Union vars ctors _ _) =
129+unionToType :: ModuleName.Canonical -> N.Name -> I.Union -> Maybe (Env.Type, Env.Exposed Env.Ctor)
130+unionToType home name union =
131+ unionToTypeHelp home name <$> I.toPublicUnion union
132+
133+
134+unionToTypeHelp :: ModuleName.Canonical -> N.Name -> Can.Union -> (Env.Type, Env.Exposed Env.Ctor)
135+unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
131136 let
132137 addCtor dict (Can.Ctor ctor index _ args) =
133138 Map.insert ctor (Map.singleton home (Env.Ctor home name union index args)) dict
@@ -137,8 +142,17 @@ unionToType home name union@(Can.Union vars ctors _ _) =
137142 )
138143
139144
140−aliasToType :: ModuleName.Canonical -> N.Name -> Can.Alias -> (Env.Type, Env.Exposed Env.Ctor)
141−aliasToType home name (Can.Alias vars tipe maybeRecordFields) =
145+
146+-- ALIAS
147+
148+
149+aliasToType :: ModuleName.Canonical -> N.Name -> I.Alias -> Maybe (Env.Type, Env.Exposed Env.Ctor)
150+aliasToType home name alias =
151+ aliasToTypeHelp home name <$> I.toPublicAlias alias
152+
153+
154+aliasToTypeHelp :: ModuleName.Canonical -> N.Name -> Can.Alias -> (Env.Type, Env.Exposed Env.Ctor)
155+aliasToTypeHelp home name (Can.Alias vars tipe maybeRecordFields) =
142156 (
143157 Env.Alias (length vars) home vars tipe
144158 ,
@@ -159,6 +173,10 @@ aliasToType home name (Can.Alias vars tipe maybeRecordFields) =
159173 )
160174
161175
176+
177+-- BINOP
178+
179+
162180binopToBinop :: ModuleName.Canonical -> N.Name -> I.Binop -> Map.Map ModuleName.Canonical Env.Binop
163181binopToBinop home op (I.Binop name annotation associativity precedence) =
164182 Map.singleton home (Env.Binop op home name annotation associativity precedence)
compiler/src/Elm/Compiler/Type/Extract.hs+2−2
@@ -123,7 +123,7 @@ extractAlias :: I.Interfaces -> Opt.Global -> Extractor T.Alias
123123extractAlias interfaces (Opt.Global home name) =
124124 let
125125 (I.Interface _ _ aliases _) = interfaces ! home
126− (Can.Alias args aliasType _) = aliases ! name
126+ (Can.Alias args aliasType _) = I.toAliasInternals (aliases ! name)
127127 in
128128 T.Alias (toPublicName home name) args <$> extract aliasType
129129
@@ -134,7 +134,7 @@ extractUnion interfaces (Opt.Global home name) =
134134 pname = toPublicName home name
135135 unions = I._unions (interfaces ! home)
136136 in
137− case unions ! name of
137+ case I.toUnionInternals (unions ! name) of
138138 Can.Union vars ctors _ _ ->
139139 T.Union pname vars <$> traverse extractCtor ctors
140140
compiler/src/Elm/Interface.hs+134−21
@@ -2,8 +2,14 @@
22module Elm.Interface
33 ( Interfaces
44 , Interface(..)
5+ , Union
6+ , Alias
57 , Binop(..)
68 , fromModule
9+ , toPublicUnion
10+ , toPublicAlias
11+ , toUnionInternals
12+ , toAliasInternals
713 )
814 where
915
@@ -12,6 +18,7 @@ import Control.Monad (liftM4)
1218import Data.Binary
1319import Data.Map ((!))
1420import qualified Data.Map as Map
21+import qualified Data.Map.Merge.Strict as Map
1522
1623import qualified AST.Canonical as Can
1724import qualified AST.Module.Name as ModuleName
@@ -35,12 +42,23 @@ type Interfaces =
3542data Interface =
3643 Interface
3744 { _types :: Map.Map N.Name Can.Annotation
38− , _unions :: Map.Map N.Name Can.Union
39− , _aliases :: Map.Map N.Name Can.Alias
45+ , _unions :: Map.Map N.Name Union
46+ , _aliases :: Map.Map N.Name Alias
4047 , _binops :: Map.Map N.Name Binop
4148 }
4249
4350
51+data Union
52+ = OpenUnion Can.Union
53+ | ClosedUnion Can.Union
54+ | PrivateUnion Can.Union
55+
56+
57+data Alias
58+ = PublicAlias Can.Alias
59+ | PrivateAlias Can.Alias
60+
61+
4462data Binop =
4563 Binop
4664 { _op_name :: N.Name
@@ -57,39 +75,104 @@ data Binop =
5775fromModule :: Map.Map N.Name Can.Annotation -> Can.Module -> Interface
5876fromModule types (Can.Module _ _ exports _ unions aliases binops _) =
5977 Interface
60− { _types = privatize exports const types
61− , _unions = privatize exports toUnion unions
62− , _aliases = privatize exports const aliases
63− , _binops = privatize exports const (Map.map (toOp types) binops)
78+ { _types = privatize exports types
79+ , _unions = privatizeUnions exports unions
80+ , _aliases = privatizeAliases exports aliases
81+ , _binops = privatize exports (Map.map (toOp types) binops)
6482 }
6583
6684
67−privatize :: Can.Exports -> (a -> A.Located Can.Export -> a) -> Map.Map N.Name a -> Map.Map N.Name a
68−privatize exports func dict =
85+privatize :: Can.Exports -> Map.Map N.Name a -> Map.Map N.Name a
86+privatize exports dict =
6987 case exports of
7088 Can.ExportEverything _ ->
7189 dict
7290
7391 Can.Export explicitExports ->
74− Map.intersectionWith func dict explicitExports
92+ Map.intersection dict explicitExports
7593
7694
77−toUnion :: Can.Union -> A.Located Can.Export -> Can.Union
78−toUnion union@(Can.Union vars _ _ opts) (A.At _ export) =
79− case export of
80− Can.ExportUnionOpen ->
81− union
95+toOp :: Map.Map N.Name Can.Annotation -> Can.Binop -> Binop
96+toOp types (Can.Binop_ associativity precedence name) =
97+ Binop name (types ! name) associativity precedence
8298
83− Can.ExportUnionClosed ->
84− Can.Union vars [] 0 opts
8599
86− _ ->
87− error "Compiler bug. Should not run into non-union exports here."
100+privatizeUnions :: Can.Exports -> Map.Map N.Name Can.Union -> Map.Map N.Name Union
101+privatizeUnions exports unions =
102+ case exports of
103+ Can.ExportEverything _ ->
104+ Map.map OpenUnion unions
88105
106+ Can.Export explicitExports ->
107+ Map.merge onLeft onRight onBoth explicitExports unions
108+ where
109+ onLeft = Map.dropMissing
110+ onRight = Map.mapMissing (\_ u -> PrivateUnion u)
111+ onBoth = Map.zipWithMatched $ \_ e u ->
112+ case A.toValue e of
113+ Can.ExportUnionOpen -> OpenUnion u
114+ Can.ExportUnionClosed -> ClosedUnion u
115+ _ -> error "impossible exports discovered in privatizeUnions"
116+
117+
118+privatizeAliases :: Can.Exports -> Map.Map N.Name Can.Alias -> Map.Map N.Name Alias
119+privatizeAliases exports aliases =
120+ case exports of
121+ Can.ExportEverything _ ->
122+ Map.map PublicAlias aliases
89123
90−toOp :: Map.Map N.Name Can.Annotation -> Can.Binop -> Binop
91−toOp types (Can.Binop_ associativity precedence name) =
92− Binop name (types ! name) associativity precedence
124+ Can.Export explicitExports ->
125+ Map.merge onLeft onRight onBoth explicitExports aliases
126+ where
127+ onLeft = Map.dropMissing
128+ onRight = Map.mapMissing (\_ a -> PrivateAlias a)
129+ onBoth = Map.zipWithMatched (\_ _ a -> PublicAlias a)
130+
131+
132+
133+-- PUBLICIZE
134+
135+
136+toPublicUnion :: Union -> Maybe Can.Union
137+toPublicUnion iUnion =
138+ case iUnion of
139+ OpenUnion union ->
140+ Just union
141+
142+ ClosedUnion (Can.Union vars _ _ opts) ->
143+ Just (Can.Union vars [] 0 opts)
144+
145+ PrivateUnion _ ->
146+ Nothing
147+
148+
149+toPublicAlias :: Alias -> Maybe Can.Alias
150+toPublicAlias iAlias =
151+ case iAlias of
152+ PublicAlias alias ->
153+ Just alias
154+
155+ PrivateAlias _ ->
156+ Nothing
157+
158+
159+
160+-- INTERNALS
161+
162+
163+toUnionInternals :: Union -> Can.Union
164+toUnionInternals iUnion =
165+ case iUnion of
166+ OpenUnion union -> union
167+ ClosedUnion union -> union
168+ PrivateUnion union -> union
169+
170+
171+toAliasInternals :: Alias -> Can.Alias
172+toAliasInternals iAlias =
173+ case iAlias of
174+ PublicAlias alias -> alias
175+ PrivateAlias alias -> alias
93176
94177
95178
@@ -104,6 +187,36 @@ instance Binary Interface where
104187 put a >> put b >> put c >> put d
105188
106189
190+instance Binary Union where
191+ put union =
192+ case union of
193+ OpenUnion u -> putWord8 0 >> put u
194+ ClosedUnion u -> putWord8 1 >> put u
195+ PrivateUnion u -> putWord8 2 >> put u
196+
197+ get =
198+ do n <- getWord8
199+ case n of
200+ 0 -> OpenUnion <$> get
201+ 1 -> ClosedUnion <$> get
202+ 2 -> PrivateUnion <$> get
203+ _ -> error "binary encoding of Union was corrupted"
204+
205+
206+instance Binary Alias where
207+ put union =
208+ case union of
209+ PublicAlias a -> putWord8 0 >> put a
210+ PrivateAlias a -> putWord8 1 >> put a
211+
212+ get =
213+ do n <- getWord8
214+ case n of
215+ 0 -> PublicAlias <$> get
216+ 1 -> PrivateAlias <$> get
217+ _ -> error "binary encoding of Alias was corrupted"
218+
219+
107220instance Binary Binop where
108221 get =
109222 liftM4 Binop get get get get