@@ -1,158 +1,242 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE Rank2Types #-}
34module Elm.Compiler.Type.Extract
4− ( extract
5− , extractProgram
5+ ( fromAnnotation
6+ , fromType
7+ , fromProgram
68 )
79 where
810
9−import qualified Control.Monad.Writer.Strict as Writer
11+
12+import Data.Map ((!))
1013import qualified Data.Map as Map
1114import qualified Data.Maybe as Maybe
15+import Data.Monoid ((<>))
1216import qualified Data.Set as Set
13−import Data.Text (Text)
1417
15−import qualified AST.Module as Module
18+import qualified AST.Canonical as Can
19+import qualified AST.Optimized as Opt
1620import qualified AST.Module.Name as ModuleName
17−import qualified AST.Type as T
18−import qualified AST.Variable as Var
19−import Elm.Compiler.Type (Type(..), Program(Program))
21+import qualified AST.Utils.Type as Type
22+import qualified Elm.Compiler.Type as T
23+import qualified Elm.Interface as I
24+import qualified Elm.Name as N
2025
2126
2227
2328-- EXTRACTION
2429
2530
26−extract :: T.Canonical -> Type
27−extract astType =
28− fst $ Writer.runWriter $ extractHelp astType
31+fromAnnotation :: Can.Annotation -> T.Type
32+fromAnnotation (Can.Forall _ astType) =
33+ fromType astType
2934
3035
31−type Deps =
32− ( Set.Set Var.Canonical -- aliases
33− , Set.Set Var.Canonical -- unions
34− )
36+fromType :: Can.Type -> T.Type
37+fromType astType =
38+ snd (run (extract astType))
3539
3640
37−diff :: Deps -> Deps -> Deps
38−diff (oldAliases, oldUnions) (newAliases, newUnions) =
39− ( Set.difference newAliases oldAliases
40− , Set.difference newUnions oldUnions
41− )
41+extract :: Can.Type -> Extractor T.Type
42+extract astType =
43+ case astType of
44+ Can.TLambda arg result ->
45+ T.Lambda
46+ <$> extract arg
47+ <*> extract result
4248
49+ Can.TVar x ->
50+ pure (T.Var x)
4351
44−extractHelp :: T.Canonical -> Writer.Writer Deps Type
45−extractHelp astType =
46− case astType of
47− T.Lambda arg result ->
48− Lambda <$> extractHelp arg <*> extractHelp result
52+ Can.TType home name args ->
53+ addUnion (Opt.Global home name) (T.Type (toPublicName home name))
54+ <*> traverse extract args
55+
56+ Can.TRecord fields ext ->
57+ T.Record
58+ <$> fmap Map.toList (traverse extract fields)
59+ <*> traverse extract ext
4960
50− T.Var x ->
51− return (Var x)
61+ Can.TUnit ->
62+ pure T.Unit
5263
53− T.Type var args ->
54− do Writer.tell ( Set.empty, Set.singleton var )
55− Type (Var.toText var) <$> traverse extractHelp args
64+ Can.TTuple a b maybeC ->
65+ T.Tuple
66+ <$> extract a
67+ <*> extract b
68+ <*> traverse extract (Maybe.maybeToList maybeC)
5669
57− T.Record fields ext ->
58− Record
59− <$> traverse (traverse extractHelp) fields
60− <*> traverse extractHelp ext
70+ Can.TAlias home name args aliasType ->
71+ do addAlias (Opt.Global home name) ()
72+ _ <- extract (Type.dealias args aliasType)
73+ T.Type (toPublicName home name)
74+ <$> traverse (extract . snd) args
6175
62− T.Aliased name args aliasedType ->
63− do Writer.tell ( Set.singleton name, Set.empty )
64− _ <- extractHelp (T.dealias args aliasedType)
65− Type (Var.toText name) <$> traverse (extractHelp . snd) args
76+
77+toPublicName :: ModuleName.Canonical -> N.Name -> N.Name
78+toPublicName (ModuleName.Canonical _ home) name =
79+ home <> "." <> name
6680
6781
6882
6983-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
7084
7185
72−extractProgram :: Module.Interfaces -> ModuleName.Canonical -> Maybe Program
73−extractProgram interfaces name =
86+fromProgram :: I.Interfaces -> ModuleName.Canonical -> Maybe T.Program
87+fromProgram interfaces name =
7488 do iface <- Map.lookup name interfaces
75− mainType <- Map.lookup "main" (Module.iTypes iface)
76−
77− message <-
78− case T.deepDealias mainType of
79− T.Type _program [_flags, _model, msg] -> Just msg
80− T.Type _node [msg] -> Just msg
81− _ -> Nothing
89+ mainType <- Map.lookup "main" (I._types iface)
90+ message <- getMessage mainType
8291
83− let (msgType, msgDeps) = Writer.runWriter (extractHelp message)
84− let (aliases, unions) = extractTransitive interfaces mempty msgDeps
85− Just (Program msgType aliases unions)
92+ let (msgDeps, msgType) = run (extract message)
93+ let (aliases, unions) = extractTransitive interfaces noDeps msgDeps
94+ Just (T.Program msgType aliases unions)
8695
8796
88−type Alias =
89− ( Text, [Text], Type )
97+getMessage :: Can.Annotation -> Maybe Can.Type
98+getMessage (Can.Forall _ mainType) =
99+ case Type.deepDealias mainType of
100+ Can.TType _ _program [_flags, _model, msg] ->
101+ Just msg
90102
103+ Can.TType _ _node [msg] ->
104+ Just msg
91105
92−type Union =
93− ( Text, [Text], [(Text, [Type])] )
106+ _ ->
107+ Nothing
94108
95109
96−extractTransitive :: Module.Interfaces -> Deps -> Deps -> ( [Alias], [Union] )
97−extractTransitive interfaces oldDeps currentDeps =
110+extractTransitive :: I.Interfaces -> Deps -> Deps -> ( [T.Alias], [T.Union] )
111+extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =
98112 let
99− (aliases, unions) =
100− diff oldDeps currentDeps
113+ aliases = Set.difference nextAliases seenAliases
114+ unions = Set.difference nextUnions seenUnions
101115 in
102116 if Set.null aliases && Set.null unions then
103117 ( [], [] )
104118
105119 else
106120 let
107− (result, newDeps) =
108− Writer.runWriter $ do
109− publicAliases <- mapM (extractAlias interfaces) (Set.toList aliases)
110− publicUnions <- mapM (extractUnion interfaces) (Set.toList unions)
111− return ( Maybe.catMaybes publicAliases, Maybe.catMaybes publicUnions )
121+ (newDeps, result) =
122+ run $
123+ (,)
124+ <$> traverse (extractAlias interfaces) (Set.toList aliases)
125+ <*> traverse (extractUnion interfaces) (Set.toList unions)
126+
127+ oldDeps =
128+ Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions)
112129
113130 remainingResult =
114− extractTransitive interfaces (mappend oldDeps currentDeps) newDeps
131+ extractTransitive interfaces oldDeps newDeps
115132 in
116133 mappend result remainingResult
117134
118135
119−extractAlias :: Module.Interfaces -> Var.Canonical -> Writer.Writer Deps (Maybe Alias)
120−extractAlias interfaces var =
136+extractAlias :: I.Interfaces -> Opt.Global -> Extractor T.Alias
137+extractAlias interfaces (Opt.Global home name) =
121138 let
122− toAlias (args, tipe) =
123− (,,) (Var.toText var) args <$> extractHelp tipe
139+ (I.Interface _ _ aliases _) = interfaces ! home
140+ (Can.Alias args aliasType _) = aliases ! name
124141 in
125− traverse toAlias (get Module.iAliases interfaces var)
142+ T.Alias (toPublicName home name) args <$> extract aliasType
126143
127144
128−extractUnion :: Module.Interfaces -> Var.Canonical -> Writer.Writer Deps (Maybe Union)
129−extractUnion interfaces var =
145+extractUnion :: I.Interfaces -> Opt.Global -> Extractor T.Union
146+extractUnion interfaces (Opt.Global home name) =
130147 let
131− toUnion (args, constructors) =
132− (,,) (Var.toText var) args
133− <$> traverse (traverse (traverse extractHelp)) constructors
148+ (I.Interface _ unions _ _) = interfaces ! home
149+ (Can.Union args constructors) = unions ! name
134150 in
135− traverse toUnion (get Module.iUnions interfaces var)
151+ T.Union (toPublicName home name) args
152+ <$> traverse (traverse (traverse extract)) constructors
136153
137154
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)
143155
156+-- DEPS
157+
158+
159+data Deps =
160+ Deps
161+ { _aliases :: Set.Set Opt.Global
162+ , _unions :: Set.Set Opt.Global
163+ }
144164
145−getHome :: Var.Canonical -> Maybe (ModuleName.Canonical, Text)
146−getHome (Var.Canonical home name) =
147− case home of
148− Var.BuiltIn ->
149− Nothing
150165
151− Var.Module moduleName ->
152− Just (moduleName, name)
166+{-# NOINLINE noDeps #-}
167+noDeps :: Deps
168+noDeps =
169+ Deps Set.empty Set.empty
153170
154− Var.TopLevel moduleName ->
155− Just (moduleName, name)
156171
157− Var.Local ->
158− Nothing
172+
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