git.iko.soy/elk
on master help sign in
Make sure type information is available for --debug metadata
c224b36Evan Czaplicki
compiler/src/Canonicalize/Environment/Foreign.hs+25−7
compare with master
unifiedsplit
@@ -84,8 +84,8 @@ addImport (State vs ts cs bs qvs qts qcs) (Import home (I.Interface defs unions
84 let
84 let
85 !rawTypeInfo =
85 !rawTypeInfo =
86 Map.union
86 Map.union
87− (Map.mapWithKey (unionToType home) unions)
87+ (Map.mapMaybeWithKey (unionToType home) unions)
88− (Map.mapWithKey (aliasToType home) aliases)
88+ (Map.mapMaybeWithKey (aliasToType home) aliases)
89
89
90 !vars = Map.map (Map.singleton home) defs
90 !vars = Map.map (Map.singleton home) defs
91 !types = Map.map (Map.singleton home . fst) rawTypeInfo
91 !types = Map.map (Map.singleton home . fst) rawTypeInfo
@@ -123,11 +123,16 @@ addQualified prefix exposed qualified =
123
123
124
124
125
125
126−-- CANONICAL DATA TO ENVIRONMENT DATA
126+-- UNION
127
127
128
128
129−unionToType :: ModuleName.Canonical -> N.Name -> Can.Union -> (Env.Type, Env.Exposed Env.Ctor)
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)
130−unionToType home name union@(Can.Union vars ctors _ _) =
135+unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
131 let
136 let
132 addCtor dict (Can.Ctor ctor index _ args) =
137 addCtor dict (Can.Ctor ctor index _ args) =
133 Map.insert ctor (Map.singleton home (Env.Ctor home name union index args)) dict
138 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 _ _) =
137 )
142 )
138
143
139
144
145+
146+-- ALIAS
147+
148+
140−aliasToType :: ModuleName.Canonical -> N.Name -> Can.Alias -> (Env.Type, Env.Exposed Env.Ctor)
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)
141−aliasToType home name (Can.Alias vars tipe maybeRecordFields) =
155+aliasToTypeHelp home name (Can.Alias vars tipe maybeRecordFields) =
142 (
156 (
143 Env.Alias (length vars) home vars tipe
157 Env.Alias (length vars) home vars tipe
144 ,
158 ,
@@ -159,6 +173,10 @@ aliasToType home name (Can.Alias vars tipe maybeRecordFields) =
159 )
173 )
160
174
161
175
176+
177+-- BINOP
178+
179+
162binopToBinop :: ModuleName.Canonical -> N.Name -> I.Binop -> Map.Map ModuleName.Canonical Env.Binop
180binopToBinop :: ModuleName.Canonical -> N.Name -> I.Binop -> Map.Map ModuleName.Canonical Env.Binop
163binopToBinop home op (I.Binop name annotation associativity precedence) =
181binopToBinop home op (I.Binop name annotation associativity precedence) =
164 Map.singleton home (Env.Binop op home name annotation associativity precedence)
182 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
123extractAlias interfaces (Opt.Global home name) =
123extractAlias interfaces (Opt.Global home name) =
124 let
124 let
125 (I.Interface _ _ aliases _) = interfaces ! home
125 (I.Interface _ _ aliases _) = interfaces ! home
126− (Can.Alias args aliasType _) = aliases ! name
126+ (Can.Alias args aliasType _) = I.toAliasInternals (aliases ! name)
127 in
127 in
128 T.Alias (toPublicName home name) args <$> extract aliasType
128 T.Alias (toPublicName home name) args <$> extract aliasType
129
129
@@ -134,7 +134,7 @@ extractUnion interfaces (Opt.Global home name) =
134 pname = toPublicName home name
134 pname = toPublicName home name
135 unions = I._unions (interfaces ! home)
135 unions = I._unions (interfaces ! home)
136 in
136 in
137− case unions ! name of
137+ case I.toUnionInternals (unions ! name) of
138 Can.Union vars ctors _ _ ->
138 Can.Union vars ctors _ _ ->
139 T.Union pname vars <$> traverse extractCtor ctors
139 T.Union pname vars <$> traverse extractCtor ctors
140
140
compiler/src/Elm/Interface.hs+134−21
@@ -2,8 +2,14 @@
2module Elm.Interface
2module Elm.Interface
3 ( Interfaces
3 ( Interfaces
4 , Interface(..)
4 , Interface(..)
5+ , Union
6+ , Alias
5 , Binop(..)
7 , Binop(..)
6 , fromModule
8 , fromModule
9+ , toPublicUnion
10+ , toPublicAlias
11+ , toUnionInternals
12+ , toAliasInternals
7 )
13 )
8 where
14 where
9
15
@@ -12,6 +18,7 @@ import Control.Monad (liftM4)
12import Data.Binary
18import Data.Binary
13import Data.Map ((!))
19import Data.Map ((!))
14import qualified Data.Map as Map
20import qualified Data.Map as Map
21+import qualified Data.Map.Merge.Strict as Map
15
22
16import qualified AST.Canonical as Can
23import qualified AST.Canonical as Can
17import qualified AST.Module.Name as ModuleName
24import qualified AST.Module.Name as ModuleName
@@ -35,12 +42,23 @@ type Interfaces =
35data Interface =
42data Interface =
36 Interface
43 Interface
37 { _types :: Map.Map N.Name Can.Annotation
44 { _types :: Map.Map N.Name Can.Annotation
38− , _unions :: Map.Map N.Name Can.Union
45+ , _unions :: Map.Map N.Name Union
39− , _aliases :: Map.Map N.Name Can.Alias
46+ , _aliases :: Map.Map N.Name Alias
40 , _binops :: Map.Map N.Name Binop
47 , _binops :: Map.Map N.Name Binop
41 }
48 }
42
49
43
50
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+
44data Binop =
62data Binop =
45 Binop
63 Binop
46 { _op_name :: N.Name
64 { _op_name :: N.Name
@@ -57,39 +75,104 @@ data Binop =
57fromModule :: Map.Map N.Name Can.Annotation -> Can.Module -> Interface
75fromModule :: Map.Map N.Name Can.Annotation -> Can.Module -> Interface
58fromModule types (Can.Module _ _ exports _ unions aliases binops _) =
76fromModule types (Can.Module _ _ exports _ unions aliases binops _) =
59 Interface
77 Interface
60− { _types = privatize exports const types
78+ { _types = privatize exports types
61− , _unions = privatize exports toUnion unions
79+ , _unions = privatizeUnions exports unions
62− , _aliases = privatize exports const aliases
80+ , _aliases = privatizeAliases exports aliases
63− , _binops = privatize exports const (Map.map (toOp types) binops)
81+ , _binops = privatize exports (Map.map (toOp types) binops)
64 }
82 }
65
83
66
84
67−privatize :: Can.Exports -> (a -> A.Located Can.Export -> a) -> Map.Map N.Name a -> Map.Map N.Name a
85+privatize :: Can.Exports -> Map.Map N.Name a -> Map.Map N.Name a
68−privatize exports func dict =
86+privatize exports dict =
69 case exports of
87 case exports of
70 Can.ExportEverything _ ->
88 Can.ExportEverything _ ->
71 dict
89 dict
72
90
73 Can.Export explicitExports ->
91 Can.Export explicitExports ->
74− Map.intersectionWith func dict explicitExports
92+ Map.intersection dict explicitExports
75
93
76
94
77−toUnion :: Can.Union -> A.Located Can.Export -> Can.Union
95+toOp :: Map.Map N.Name Can.Annotation -> Can.Binop -> Binop
78−toUnion union@(Can.Union vars _ _ opts) (A.At _ export) =
96+toOp types (Can.Binop_ associativity precedence name) =
79− case export of
97+ Binop name (types ! name) associativity precedence
80− Can.ExportUnionOpen ->
81− union
82
98
83− Can.ExportUnionClosed ->
84− Can.Union vars [] 0 opts
85
99
86− _ ->
100+privatizeUnions :: Can.Exports -> Map.Map N.Name Can.Union -> Map.Map N.Name Union
87− error "Compiler bug. Should not run into non-union exports here."
101+privatizeUnions exports unions =
102+ case exports of
103+ Can.ExportEverything _ ->
104+ Map.map OpenUnion unions
88
105
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
89
123
90−toOp :: Map.Map N.Name Can.Annotation -> Can.Binop -> Binop
124+ Can.Export explicitExports ->
91−toOp types (Can.Binop_ associativity precedence name) =
125+ Map.merge onLeft onRight onBoth explicitExports aliases
92− Binop name (types ! name) associativity precedence
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
93
176
94
177
95
178
@@ -104,6 +187,36 @@ instance Binary Interface where
104 put a >> put b >> put c >> put d
187 put a >> put b >> put c >> put d
105
188
106
189
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+
107instance Binary Binop where
220instance Binary Binop where
108 get =
221 get =
109 liftM4 Binop get get get get
222 liftM4 Binop get get get get