@@ -1,15 +1,20 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE Rank2Types #-}
2+{-# LANGUAGE BangPatterns, OverloadedStrings, Rank2Types #-}
43module Elm.Compiler.Type.Extract
54 ( fromAnnotation
65 , fromType
6+ , Types(..)
7+ , mergeMany
8+ , merge
9+ , fromInterface
10+ , fromDependencyInterface
711 , fromMsg
812 )
913 where
1014
1115
1216import Data.Map ((!))
17+import qualified Data.Map as Map
1318import qualified Data.Maybe as Maybe
1419import qualified Data.Name as Name
1520import qualified Data.Set as Set
@@ -77,23 +82,70 @@ toPublicName (ModuleName.Canonical _ home) name =
7782
7883
7984
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+
80132-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
81133
82134
83−fromMsg :: I.Interfaces -> Can.Type -> T.DebugMetadata
84−fromMsg interfaces message =
135+fromMsg :: Types -> Can.Type -> T.DebugMetadata
136+fromMsg types message =
85137 let
86138 (msgDeps, msgType) =
87139 run (extract message)
88140
89141 (aliases, unions) =
90− extractTransitive interfaces noDeps msgDeps
142+ extractTransitive types noDeps msgDeps
91143 in
92144 T.DebugMetadata msgType aliases unions
93145
94146
95−extractTransitive :: I.Interfaces -> Deps -> Deps -> ( [T.Alias], [T.Union] )
96−extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =
147+extractTransitive :: Types -> Deps -> Deps -> ( [T.Alias], [T.Union] )
148+extractTransitive types (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =
97149 let
98150 aliases = Set.difference nextAliases seenAliases
99151 unions = Set.difference nextUnions seenUnions
@@ -106,39 +158,36 @@ extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nex
106158 (newDeps, result) =
107159 run $
108160 (,)
109− <$> traverse (extractAlias interfaces) (Set.toList aliases)
110− <*> traverse (extractUnion interfaces) (Set.toList unions)
161+ <$> traverse (extractAlias types) (Set.toList aliases)
162+ <*> traverse (extractUnion types) (Set.toList unions)
111163
112164 oldDeps =
113165 Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions)
114166
115167 remainingResult =
116− extractTransitive interfaces oldDeps newDeps
168+ extractTransitive types oldDeps newDeps
117169 in
118170 mappend result remainingResult
119171
120172
121−extractAlias :: I.Interfaces -> Opt.Global -> Extractor T.Alias
122−extractAlias interfaces (Opt.Global home name) =
173+extractAlias :: Types -> Opt.Global -> Extractor T.Alias
174+extractAlias (Types dict) (Opt.Global home name) =
123175 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
126177 in
127178 T.Alias (toPublicName home name) args <$> extract aliasType
128179
129180
130−extractUnion :: I.Interfaces -> Opt.Global -> Extractor T.Union
131−extractUnion interfaces (Opt.Global home name) =
181+extractUnion :: Types -> Opt.Global -> Extractor T.Union
182+extractUnion (Types dict) (Opt.Global home name) =
132183 if name == Name.list && home == ModuleName.list
133184 then return $ T.Union (toPublicName home name) ["a"] []
134185 else
135186 let
136187 pname = toPublicName home name
137− unions = I._unions (interfaces ! home)
188+ (Can.Union vars ctors _ _) = _union_info (dict ! home) ! name
138189 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
142191
143192
144193extractCtor :: Can.Ctor -> Extractor (Name.Name, [T.Type])