@@ -1,45 +1,166 @@
1−module Elm.Compiler.Type.Extract (toFullType, toAliasedType) where
1+{-# OPTIONS_GHC -Wall #-}
2+module Elm.Compiler.Type.Extract
3+ ( extract
4+ , extractProgram
5+ )
6+ where
27
3−import Control.Arrow (second)
4−import qualified AST.Type as Type
8+import qualified Control.Monad.Writer as Writer
9+import qualified Data.Map as Map
10+import qualified Data.Set as Set
11+import qualified AST.Module as Module
12+import qualified AST.Module.Name as ModuleName
13+import qualified AST.Type as T
514import qualified AST.Variable as Var
6−import qualified Elm.Compiler.Type as T
15+import Elm.Compiler.Type (Type(..), Program(Program))
716
817
9−toFullType :: Type.Canonical -> T.Type
10−toFullType astType =
11− toType False astType
1218
19+-- EXTRACTION
1320
14−toAliasedType :: Type.Canonical -> T.Type
15−toAliasedType astType =
16− toType True astType
1721
22+extract :: T.Canonical -> Type
23+extract astType =
24+ fst $ Writer.runWriter $ extractHelp astType
1825
19−toType :: Bool -> Type.Canonical -> T.Type
20−toType useAliases astType =
26+
27+type Deps =
28+ ( Set.Set Var.Canonical -- aliases
29+ , Set.Set Var.Canonical -- unions
30+ )
31+
32+
33+diff :: Deps -> Deps -> Deps
34+diff (oldAliases, oldUnions) (newAliases, newUnions) =
35+ ( Set.difference newAliases oldAliases
36+ , Set.difference newUnions oldUnions
37+ )
38+
39+
40+extractHelp :: T.Canonical -> Writer.Writer Deps Type
41+extractHelp astType =
42+ case astType of
43+ T.Lambda arg result ->
44+ Lambda <$> extractHelp arg <*> extractHelp result
45+
46+ T.Var x ->
47+ return $ Var x
48+
49+ T.Type var ->
50+ do Writer.tell ( Set.empty, Set.singleton var )
51+ return $ Type $ Var.toString var
52+
53+ T.App constructor args ->
54+ App <$> extractHelp constructor <*> traverse extractHelp args
55+
56+ T.Record fields ext ->
57+ Record
58+ <$> traverse (traverse extractHelp) fields
59+ <*> traverse extractHelp ext
60+
61+ T.Aliased name args aliasedType ->
62+ do Writer.tell ( Set.singleton name, Set.empty )
63+ _ <- extractHelp (T.dealias args aliasedType)
64+ App (Type (Var.toString name)) <$> traverse (extractHelp . snd) args
65+
66+
67+
68+-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
69+
70+
71+extractProgram :: Module.Interfaces -> ModuleName.Canonical -> Maybe Program
72+extractProgram interfaces name =
73+ do iface <- Map.lookup name interfaces
74+ mainType <- Map.lookup "main" (Module.iTypes iface)
75+ case mainType of
76+ T.App _program [_flags, model, msg] ->
77+ let
78+ (modelType, modelDeps) =
79+ Writer.runWriter (extractHelp model)
80+
81+ (msgType, msgDeps) =
82+ Writer.runWriter (extractHelp msg)
83+
84+ (aliases, unions) =
85+ extractTransitive interfaces mempty (mappend modelDeps msgDeps)
86+ in
87+ Just $ Program modelType msgType aliases unions
88+
89+ _ ->
90+ Nothing
91+
92+
93+type Alias =
94+ ( String, [String], Type )
95+
96+
97+type Union =
98+ ( String, [String], [(String, [Type])] )
99+
100+
101+extractTransitive :: Module.Interfaces -> Deps -> Deps -> ( [Alias], [Union] )
102+extractTransitive interfaces oldDeps currentDeps =
21103 let
22− go = toType useAliases
104+ (aliases, unions) =
105+ diff oldDeps currentDeps
23106 in
24− case astType of
25− Type.Lambda t1 t2 ->
26− T.Lambda (go t1) (go t2)
107+ if Set.null aliases && Set.null unions then
108+ ( [], [] )
109+
110+ else
111+ let
112+ (result, newDeps) =
113+ Writer.runWriter $
114+ (,)
115+ <$> mapM (extractAlias interfaces) (Set.toList aliases)
116+ <*> mapM (extractUnion interfaces) (Set.toList unions)
117+
118+ remainingResult =
119+ extractTransitive interfaces (mappend oldDeps currentDeps) newDeps
120+ in
121+ mappend result remainingResult
122+
123+
124+extractAlias :: Module.Interfaces -> Var.Canonical -> Writer.Writer Deps Alias
125+extractAlias interfaces var =
126+ case get Module.iAliases interfaces var of
127+ Nothing ->
128+ return ( Var.toString var, [], Type "_Tuple0" )
129+
130+ Just (args, tipe) ->
131+ (,,) (Var.toString var) args
132+ <$> extractHelp tipe
133+
134+
135+extractUnion :: Module.Interfaces -> Var.Canonical -> Writer.Writer Deps Union
136+extractUnion interfaces var =
137+ case get Module.iUnions interfaces var of
138+ Nothing ->
139+ return ( Var.toString var, [], [] )
140+
141+ Just (args, constructors) ->
142+ (,,) (Var.toString var) args
143+ <$> traverse (traverse (traverse extractHelp)) constructors
144+
27145
28− Type.Var x ->
29− T.Var x
146+get :: (Module.Interface -> Map.Map String a) -> Module.Interfaces -> Var.Canonical -> Maybe a
147+get getInfo interfaces var =
148+ do (home, name) <- getHome var
149+ iface <- Map.lookup home interfaces
150+ Map.lookup name (getInfo iface)
30151
31− Type.Type var ->
32− T.Type (Var.toString var)
33152
34− Type.App t ts ->
35− T.App (go t) (map go ts)
153+getHome :: Var.Canonical -> Maybe (ModuleName.Canonical, String)
154+getHome (Var.Canonical home name) =
155+ case home of
156+ Var.BuiltIn ->
157+ Nothing
36158
37− Type.Record fields ext ->
38− T.Record (map (second go) fields) (fmap go ext)
159+ Var.Module moduleName ->
160+ Just (moduleName, name)
39161
40− Type.Aliased name args t ->
41− if useAliases then
42− T.App (T.Type (Var.toString name)) (map (go . snd) args)
162+ Var.TopLevel moduleName ->
163+ Just (moduleName, name)
43164
44− else
45− go (Type.dealias args t)
165+ Var.Local ->
166+ Nothing