git.iko.soy/elk
on master help sign in
Transitive type deps of program Model and Msg
014d640Evan Czaplicki
src/Docs/Centralize.hs+3−3
compare with master
unifiedsplit
@@ -46,7 +46,7 @@ defToEntry infixDict (A.A (_, maybeComment) (Canonical.Def _ pattern _ maybeType
46 value =
46 value =
47 Docs.Value
47 Docs.Value
48 maybeComment
48 maybeComment
49− (fmap (Extract.toAliasedType . A.drop) maybeType)
49+ (fmap (Extract.extract . A.drop) maybeType)
50 (Map.lookup name infixDict)
50 (Map.lookup name infixDict)
51 in
51 in
52 Just (name, A.A subregion value)
52 Just (name, A.A subregion value)
@@ -59,7 +59,7 @@ unionToEntry :: A.Commented (D.Union Type.Canonical) -> (String, A.Located Docs.
59unionToEntry (A.A (region, maybeComment) (D.Type name args ctors)) =
59unionToEntry (A.A (region, maybeComment) (D.Type name args ctors)) =
60 let
60 let
61 ctors' =
61 ctors' =
62− map (second (map Extract.toAliasedType)) ctors
62+ map (second (map Extract.extract)) ctors
63 in
63 in
64 (name, A.A region (Docs.Union maybeComment args ctors'))
64 (name, A.A region (Docs.Union maybeComment args ctors'))
65
65
@@ -67,7 +67,7 @@ unionToEntry (A.A (region, maybeComment) (D.Type name args ctors)) =
67aliasToEntry :: A.Commented (D.Alias Type.Canonical) -> (String, A.Located Docs.Alias)
67aliasToEntry :: A.Commented (D.Alias Type.Canonical) -> (String, A.Located Docs.Alias)
68aliasToEntry (A.A (region, maybeComment) (D.Type name args tipe)) =
68aliasToEntry (A.A (region, maybeComment) (D.Type name args tipe)) =
69 ( name
69 ( name
70− , A.A region (Docs.Alias maybeComment args (Extract.toAliasedType tipe))
70+ , A.A region (Docs.Alias maybeComment args (Extract.extract tipe))
71 )
71 )
72
72
73
73
src/Elm/Compiler/Module.hs+10−4
@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -Wall #-}
1module Elm.Compiler.Module
2module Elm.Compiler.Module
2 ( Interface, Interfaces
3 ( Interface, Interfaces
3 , ModuleName.Raw
4 , ModuleName.Raw
@@ -6,7 +7,7 @@ module Elm.Compiler.Module
6 , hyphenate, dehyphenate
7 , hyphenate, dehyphenate
7 , RawForJson(RawForJson), fromJson
8 , RawForJson(RawForJson), fromJson
8 , defaultImports
9 , defaultImports
9− , interfaceAliasedTypes
10+ , interfaceAliasedTypes, programTypes
10 , ModuleName.Canonical(..), qualifiedVar
11 , ModuleName.Canonical(..), qualifiedVar
11 )
12 )
12 where
13 where
@@ -21,7 +22,7 @@ import System.FilePath ((</>))
21import qualified AST.Module as Module
22import qualified AST.Module as Module
22import qualified AST.Module.Name as ModuleName
23import qualified AST.Module.Name as ModuleName
23import qualified Elm.Compiler.Imports as Imports
24import qualified Elm.Compiler.Imports as Imports
24−import qualified Elm.Compiler.Type as Type
25+import qualified Elm.Compiler.Type as PublicType
25import qualified Elm.Compiler.Type.Extract as Extract
26import qualified Elm.Compiler.Type.Extract as Extract
26import qualified Generate.JavaScript.Variable as Gen
27import qualified Generate.JavaScript.Variable as Gen
27
28
@@ -36,9 +37,14 @@ type Interface = Module.Interface
36type Interfaces = Module.Interfaces
37type Interfaces = Module.Interfaces
37
38
38
39
39−interfaceAliasedTypes :: Interface -> Map.Map String Type.Type
40+interfaceAliasedTypes :: Interface -> Map.Map String PublicType.Type
40interfaceAliasedTypes interface =
41interfaceAliasedTypes interface =
41− Map.map Extract.toAliasedType (Module.iTypes interface)
42+ Map.map Extract.extract (Module.iTypes interface)
43+
44+
45+programTypes :: Interfaces -> ModuleName.Canonical -> Maybe PublicType.Program
46+programTypes =
47+ Extract.extractProgram
42
48
43
49
44
50
src/Elm/Compiler/Type.hs+53−4
@@ -1,11 +1,12 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module Elm.Compiler.Type
2module Elm.Compiler.Type
3− ( Type(..)
4− , toString
3+ ( Type(..), toString
4+ , Program(..)
5+ )
5− ) where
6+ where
6
7
7import Control.Arrow (second)
8import Control.Arrow (second)
8−import Data.Aeson ((.:))
9+import Data.Aeson ((.:), (.=))
9import qualified Data.Aeson as Json
10import qualified Data.Aeson as Json
10import qualified Data.Aeson.Types as Json
11import qualified Data.Aeson.Types as Json
11import qualified Data.ByteString.Lazy.Char8 as BS
12import qualified Data.ByteString.Lazy.Char8 as BS
@@ -20,6 +21,7 @@ import qualified Parse.Type as Type
20import qualified Reporting.Annotation as A
21import qualified Reporting.Annotation as A
21
22
22
23
24+
23data Type
25data Type
24 = Lambda Type Type
26 = Lambda Type Type
25 | Var String
27 | Var String
@@ -28,8 +30,19 @@ data Type
28 | Record [(String, Type)] (Maybe Type)
30 | Record [(String, Type)] (Maybe Type)
29
31
30
32
33+data Program =
34+ Program
35+ { _model :: Type
36+ , _msg :: Type
37+ , _aliases :: [( String, [String], Type )]
38+ , _unions :: [( String, [String], [(String, [Type])] )]
39+ }
40+
41+
42+
31-- TO STRING
43-- TO STRING
32
44
45+
33data Context = None | ADT | Function
46data Context = None | ADT | Function
34
47
35
48
@@ -127,8 +140,10 @@ flattenRecord tipe =
127 _ -> error "Trying to flatten ill-formed record."
140 _ -> error "Trying to flatten ill-formed record."
128
141
129
142
143+
130-- JSON for TYPE
144-- JSON for TYPE
131
145
146+
132instance Json.ToJSON Type where
147instance Json.ToJSON Type where
133 toJSON tipe =
148 toJSON tipe =
134 Json.String (Text.unwords (Text.words (Text.pack (toString tipe))))
149 Json.String (Text.unwords (Text.words (Text.pack (toString tipe))))
@@ -195,3 +210,37 @@ fromRawType (A.A _ astType) =
195 Type.RRecord fields ext ->
210 Type.RRecord fields ext ->
196 Record (map (second fromRawType) fields) (fmap fromRawType ext)
211 Record (map (second fromRawType) fields) (fmap fromRawType ext)
197
212
213+
214+
215+-- JSON for PROGRAM
216+
217+
218+instance Json.ToJSON Program where
219+ toJSON (Program model msg aliases unions) =
220+ Json.object
221+ [ "model" .= model
222+ , "message" .= msg
223+ , "aliases" .= Json.object (map toAliasField aliases)
224+ , "unions" .= Json.object (map toUnionField unions)
225+ ]
226+
227+
228+toAliasField :: ( String, [String], Type ) -> Json.Pair
229+toAliasField ( name, args, tipe ) =
230+ Text.pack name .= Json.object
231+ [ "args" .= args
232+ , "type" .= tipe
233+ ]
234+
235+
236+toUnionField :: ( String, [String], [(String, [Type])] ) -> Json.Pair
237+toUnionField ( name, args, constructors ) =
238+ Text.pack name .= Json.object
239+ [ "args" .= args
240+ , "type" .= Json.object (map toCtorObject constructors)
241+ ]
242+
243+
244+toCtorObject :: (String, [Type]) -> Json.Pair
245+toCtorObject (name, args) =
246+ Text.pack name .= args
src/Elm/Compiler/Type/Extract.hs+150−29
@@ -1,45 +1,166 @@
1+{-# OPTIONS_GHC -Wall #-}
1−module Elm.Compiler.Type.Extract (toFullType, toAliasedType) where
2+module Elm.Compiler.Type.Extract
3+ ( extract
4+ , extractProgram
5+ )
6+ where
2
7
3−import Control.Arrow (second)
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
4−import qualified AST.Type as Type
12+import qualified AST.Module.Name as ModuleName
13+import qualified AST.Type as T
5import qualified AST.Variable as Var
14import qualified AST.Variable as Var
6−import qualified Elm.Compiler.Type as T
15+import Elm.Compiler.Type (Type(..), Program(Program))
7
16
8
17
9−toFullType :: Type.Canonical -> T.Type
10−toFullType astType =
11− toType False astType
12
18
19+-- EXTRACTION
13
20
14−toAliasedType :: Type.Canonical -> T.Type
15−toAliasedType astType =
16− toType True astType
17
21
22+extract :: T.Canonical -> Type
23+extract astType =
24+ fst $ Writer.runWriter $ extractHelp astType
18
25
19−toType :: Bool -> Type.Canonical -> T.Type
26+
20−toType useAliases astType =
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 =
21 let
103 let
22− go = toType useAliases
104+ (aliases, unions) =
105+ diff oldDeps currentDeps
23 in
106 in
24− case astType of
107+ if Set.null aliases && Set.null unions then
25− Type.Lambda t1 t2 ->
108+ ( [], [] )
26− T.Lambda (go t1) (go t2)
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+
27
145
28− Type.Var x ->
146+get :: (Module.Interface -> Map.Map String a) -> Module.Interfaces -> Var.Canonical -> Maybe a
29− T.Var x
147+get getInfo interfaces var =
148+ do (home, name) <- getHome var
149+ iface <- Map.lookup home interfaces
150+ Map.lookup name (getInfo iface)
30
151
31− Type.Type var ->
32− T.Type (Var.toString var)
33
152
34− Type.App t ts ->
153+getHome :: Var.Canonical -> Maybe (ModuleName.Canonical, String)
35− T.App (go t) (map go ts)
154+getHome (Var.Canonical home name) =
155+ case home of
156+ Var.BuiltIn ->
157+ Nothing
36
158
37− Type.Record fields ext ->
159+ Var.Module moduleName ->
38− T.Record (map (second go) fields) (fmap go ext)
160+ Just (moduleName, name)
39
161
40− Type.Aliased name args t ->
162+ Var.TopLevel moduleName ->
41− if useAliases then
163+ Just (moduleName, name)
42− T.App (T.Type (Var.toString name)) (map (go . snd) args)
43
164
44− else
165+ Var.Local ->
45− go (Type.dealias args t)
166+ Nothing