git.iko.soy/elk
on master help sign in
Have a specific abstraction for tracking types in --debug
af2ea2bEvan Czaplicki
compiler/src/Elm/Compiler/Type/Extract.hs+69−20
compare with master
unifiedsplit
@@ -1,15 +1,20 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, OverloadedStrings, Rank2Types #-}
3−{-# LANGUAGE Rank2Types #-}
4module Elm.Compiler.Type.Extract
3module Elm.Compiler.Type.Extract
5 ( fromAnnotation
4 ( fromAnnotation
6 , fromType
5 , fromType
6+ , Types(..)
7+ , mergeMany
8+ , merge
9+ , fromInterface
10+ , fromDependencyInterface
7 , fromMsg
11 , fromMsg
8 )
12 )
9 where
13 where
10
14
11
15
12import Data.Map ((!))
16import Data.Map ((!))
17+import qualified Data.Map as Map
13import qualified Data.Maybe as Maybe
18import qualified Data.Maybe as Maybe
14import qualified Data.Name as Name
19import qualified Data.Name as Name
15import qualified Data.Set as Set
20import qualified Data.Set as Set
@@ -77,23 +82,70 @@ toPublicName (ModuleName.Canonical _ home) name =
77
82
78
83
79
84
85+-- TRANSITIVELY AVAILABLE TYPES
86+
87+
88+newtype Types =
89+ Types (Map.Map ModuleName.Canonical Types_)
90+ -- TODO profile Opt.Global representation
91+ -- current representation needs less allocation
92+ -- but maybe the lookup is much worse
93+
94+
95+data Types_ =
96+ Types_
97+ { _union_info :: Map.Map Name.Name Can.Union
98+ , _alias_info :: Map.Map Name.Name Can.Alias
99+ }
100+
101+
102+mergeMany :: [Types] -> Types
103+mergeMany listOfTypes =
104+ case listOfTypes of
105+ [] -> Types Map.empty
106+ t:ts -> foldr merge t ts
107+
108+
109+merge :: Types -> Types -> Types
110+merge (Types types1) (Types types2) =
111+ Types (Map.union types1 types2)
112+
113+
114+fromInterface :: ModuleName.Raw -> I.Interface -> Types
115+fromInterface name (I.Interface pkg _ unions aliases _) =
116+ Types $ Map.singleton (ModuleName.Canonical pkg name) $
117+ Types_ (Map.map I.extractUnion unions) (Map.map I.extractAlias aliases)
118+
119+
120+fromDependencyInterface :: ModuleName.Canonical -> I.DependencyInterface -> Types
121+fromDependencyInterface home di =
122+ Types $ Map.singleton home $
123+ case di of
124+ I.Public (I.Interface _ _ unions aliases _) ->
125+ Types_ (Map.map I.extractUnion unions) (Map.map I.extractAlias aliases)
126+
127+ I.Private _ unions aliases ->
128+ Types_ unions aliases
129+
130+
131+
80-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
132-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
81
133
82
134
83−fromMsg :: I.Interfaces -> Can.Type -> T.DebugMetadata
135+fromMsg :: Types -> Can.Type -> T.DebugMetadata
84−fromMsg interfaces message =
136+fromMsg types message =
85 let
137 let
86 (msgDeps, msgType) =
138 (msgDeps, msgType) =
87 run (extract message)
139 run (extract message)
88
140
89 (aliases, unions) =
141 (aliases, unions) =
90− extractTransitive interfaces noDeps msgDeps
142+ extractTransitive types noDeps msgDeps
91 in
143 in
92 T.DebugMetadata msgType aliases unions
144 T.DebugMetadata msgType aliases unions
93
145
94
146
95−extractTransitive :: I.Interfaces -> Deps -> Deps -> ( [T.Alias], [T.Union] )
147+extractTransitive :: Types -> Deps -> Deps -> ( [T.Alias], [T.Union] )
96−extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =
148+extractTransitive types (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =
97 let
149 let
98 aliases = Set.difference nextAliases seenAliases
150 aliases = Set.difference nextAliases seenAliases
99 unions = Set.difference nextUnions seenUnions
151 unions = Set.difference nextUnions seenUnions
@@ -106,39 +158,36 @@ extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nex
106 (newDeps, result) =
158 (newDeps, result) =
107 run $
159 run $
108 (,)
160 (,)
109− <$> traverse (extractAlias interfaces) (Set.toList aliases)
161+ <$> traverse (extractAlias types) (Set.toList aliases)
110− <*> traverse (extractUnion interfaces) (Set.toList unions)
162+ <*> traverse (extractUnion types) (Set.toList unions)
111
163
112 oldDeps =
164 oldDeps =
113 Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions)
165 Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions)
114
166
115 remainingResult =
167 remainingResult =
116− extractTransitive interfaces oldDeps newDeps
168+ extractTransitive types oldDeps newDeps
117 in
169 in
118 mappend result remainingResult
170 mappend result remainingResult
119
171
120
172
121−extractAlias :: I.Interfaces -> Opt.Global -> Extractor T.Alias
173+extractAlias :: Types -> Opt.Global -> Extractor T.Alias
122−extractAlias interfaces (Opt.Global home name) =
174+extractAlias (Types dict) (Opt.Global home name) =
123 let
175 let
124− (I.Interface _ _ aliases _) = interfaces ! home
125− (Can.Alias args aliasType) = I.toAliasInternals (aliases ! name)
176+ (Can.Alias args aliasType) = _alias_info (dict ! home) ! name
126 in
177 in
127 T.Alias (toPublicName home name) args <$> extract aliasType
178 T.Alias (toPublicName home name) args <$> extract aliasType
128
179
129
180
130−extractUnion :: I.Interfaces -> Opt.Global -> Extractor T.Union
181+extractUnion :: Types -> Opt.Global -> Extractor T.Union
131−extractUnion interfaces (Opt.Global home name) =
182+extractUnion (Types dict) (Opt.Global home name) =
132 if name == Name.list && home == ModuleName.list
183 if name == Name.list && home == ModuleName.list
133 then return $ T.Union (toPublicName home name) ["a"] []
184 then return $ T.Union (toPublicName home name) ["a"] []
134 else
185 else
135 let
186 let
136 pname = toPublicName home name
187 pname = toPublicName home name
137− unions = I._unions (interfaces ! home)
188+ (Can.Union vars ctors _ _) = _union_info (dict ! home) ! name
138 in
189 in
139− case I.toUnionInternals (unions ! name) of
140− Can.Union vars ctors _ _ ->
141− T.Union pname vars <$> traverse extractCtor ctors
190+ T.Union pname vars <$> traverse extractCtor ctors
142
191
143
192
144extractCtor :: Can.Ctor -> Extractor (Name.Name, [T.Type])
193extractCtor :: Can.Ctor -> Extractor (Name.Name, [T.Type])