git.iko.soy/elk
on master help sign in
Fix #766, properly trim explicit exports of ADTs and type aliases
8a045c7Evan Czaplicki
compiler/Build/Source.hs+7−7
compare with master
unifiedsplit
@@ -4,22 +4,22 @@ module Build.Source (build) where
4import qualified Data.Map as Map
4import qualified Data.Map as Map
5import Text.PrettyPrint (Doc)
5import Text.PrettyPrint (Doc)
6
6
7−import AST.Module as Module
7+import qualified AST.Module as Module
8import qualified Parse.Parse as Parse
8import qualified Parse.Parse as Parse
9import qualified Metadata.Prelude as Prelude
9import qualified Metadata.Prelude as Prelude
10import qualified Transform.Check as Check
10import qualified Transform.Check as Check
11import qualified Type.Inference as TI
11import qualified Type.Inference as TI
12import qualified Transform.Canonicalize as Canonical
12import qualified Transform.Canonicalize as Canonical
13
13
14−build :: Bool -> Interfaces -> String -> Either [Doc] CanonicalModule
14+build :: Bool -> Module.Interfaces -> String -> Either [Doc] Module.CanonicalModule
15build noPrelude interfaces source =
15build noPrelude interfaces source =
16 do let infixes = Map.fromList . map (\(assoc,lvl,op) -> (op,(lvl,assoc)))
16 do let infixes = Map.fromList . map (\(assoc,lvl,op) -> (op,(lvl,assoc)))
17− . concatMap iFixities $ Map.elems interfaces
17+ . concatMap Module.iFixities $ Map.elems interfaces
18
18
19 -- Parse the source code and validate that it is well formed.
19 -- Parse the source code and validate that it is well formed.
20 validModule <- do
20 validModule <- do
21 modul <- Prelude.add noPrelude `fmap` Parse.program infixes source
21 modul <- Prelude.add noPrelude `fmap` Parse.program infixes source
22− case Check.mistakes (body modul) of
22+ case Check.mistakes (Module.body modul) of
23 [] -> return modul
23 [] -> return modul
24 ms -> Left ms
24 ms -> Left ms
25
25
@@ -30,7 +30,7 @@ build noPrelude interfaces source =
30 types <- TI.infer interfaces canonicalModule
30 types <- TI.infer interfaces canonicalModule
31
31
32 -- Trim down the set of exported values to the stuff that is actually exported.
32 -- Trim down the set of exported values to the stuff that is actually exported.
33+ let bodyWithTypes = (Module.body canonicalModule) { Module.types = types }
33− let types' = Canonical.filterExports types (Module.exports canonicalModule)
34+ body = Canonical.filterExports bodyWithTypes (Module.exports canonicalModule)
34− body' = (body canonicalModule) { types = types' }
35
35
36− return $ canonicalModule { body = body' }
36+ return $ canonicalModule { Module.body = body }
compiler/Transform/Canonicalize.hs+49−15
@@ -106,23 +106,54 @@ delist fullList (Var.Listing partial open)
106
106
107 _ -> go list xs partial
107 _ -> go list xs partial
108
108
109−filterExports :: Module.Types -> [Var.Value] -> Module.Types
109+filterExports :: Module.CanonicalBody -> [Var.Value] -> Module.CanonicalBody
110−filterExports types values =
110+filterExports body exportedValues =
111+ body
112+ { Module.types =
113+ Map.fromList (concatMap getTypes exportedValues)
114+ , Module.aliases =
115+ Map.fromList (concatMap getAliases exportedValues)
116+ , Module.datatypes =
111− Map.fromList (concatMap getValue values)
117+ Map.fromList (concatMap getAdts exportedValues)
118+ }
112 where
119 where
113− getValue :: Var.Value -> [(String, Type.CanonicalType)]
120+ get :: Map.Map String a -> String -> [(String, a)]
114− getValue value =
115− case value of
116− Var.Value x -> get x
117− Var.Alias x -> get x
118− Var.ADT _ (Var.Listing ctors _) -> concatMap get ctors
119−
120− get :: String -> [(String, Type.CanonicalType)]
121− get x =
121+ get dict x =
122− case Map.lookup x types of
122+ case Map.lookup x dict of
123 Just t -> [(x,t)]
123 Just t -> [(x,t)]
124 Nothing -> []
124 Nothing -> []
125
125
126+ getTypes :: Var.Value -> [(String, Type.CanonicalType)]
127+ getTypes value =
128+ case value of
129+ Var.Value x -> getType x
130+ Var.Alias _ -> []
131+ Var.ADT _ (Var.Listing ctors _) -> concatMap getType ctors
132+
133+ getType :: String -> [(String, Type.CanonicalType)]
134+ getType = get (Module.types body)
135+
136+ getAliases :: Var.Value -> [(String, ([String], Type.CanonicalType))]
137+ getAliases value =
138+ case value of
139+ Var.Value _ -> []
140+ Var.Alias name -> get (Module.aliases body) name
141+ Var.ADT _ _ -> []
142+
143+ getAdts :: Var.Value -> [(String, Module.AdtInfo String)]
144+ getAdts value =
145+ case value of
146+ Var.Value _ -> []
147+ Var.Alias _ -> []
148+ Var.ADT name (Var.Listing exportedCtors _) ->
149+ case Map.lookup name (Module.datatypes body) of
150+ Nothing -> []
151+ Just (tvars, ctors) ->
152+ [(name, (tvars, filter isExported ctors))]
153+ where
154+ isExported (ctor, _) = ctor `elem` exportedCtors
155+
156+
126declToValue :: D.ValidDecl -> [Var.Value]
157declToValue :: D.ValidDecl -> [Var.Value]
127declToValue decl =
158declToValue decl =
128 case decl of
159 case decl of
@@ -132,8 +163,11 @@ declToValue decl =
132 D.Datatype name _tvs ctors ->
163 D.Datatype name _tvs ctors ->
133 [ Var.ADT name (Var.Listing (map fst ctors) False) ]
164 [ Var.ADT name (Var.Listing (map fst ctors) False) ]
134
165
135− D.TypeAlias name _ (Type.Record _ _) ->
166+ D.TypeAlias name _ tipe ->
167+ case tipe of
168+ Type.Record _ _ ->
169+ [ Var.Alias name, Var.Value name ]
136− [ Var.Alias name ]
170+ _ -> [ Var.Alias name ]
137
171
138 _ -> []
172 _ -> []
139
173
libraries/Dict.elm+33−26
@@ -1,13 +1,15 @@
1+module Dict
2+ ( Dict
1−module Dict (empty,singleton,insert,update
3+ , empty, singleton, insert, update
2− ,get,getOrElse,getOrFail
4+ , get, getOrElse, getOrFail
3− ,remove,member
5+ , remove, member
4− ,filter
6+ , filter
5− ,partition
7+ , partition
6− ,foldl,foldr,map
8+ , foldl, foldr, map
7− ,union,intersect,diff
9+ , union, intersect, diff
8− ,keys,values
10+ , keys, values
9− ,toList,fromList
11+ , toList, fromList
10− ) where
12+ ) where
11
13
12{-| A dictionary mapping unique keys to values. The keys can be any comparable
14{-| A dictionary mapping unique keys to values. The keys can be any comparable
13type. This includes `Int`, `Float`, `Time`, `Char`, `String`, and tuples or
15type. This includes `Int`, `Float`, `Time`, `Char`, `String`, and tuples or
@@ -40,34 +42,39 @@ import List
40import List ((::))
42import List ((::))
41import Native.Utils
43import Native.Utils
42
44
45+type Fakeout = (Int, Int)
46+
47+type Another = (Int, Int)
48+
43-- BBlack and NBlack should only be used during the deletion
49-- BBlack and NBlack should only be used during the deletion
44-- algorithm. Any other occurrence is a bug and should fail an assert.
50-- algorithm. Any other occurrence is a bug and should fail an assert.
45−data NColor = Red
51+data NColor
52+ = Red
46− | Black
53+ | Black
47− -- ^ Double Black, counts as 2 blacks for the invariant
54+ | BBlack -- Double Black, counts as 2 blacks for the invariant
48− | BBlack
49− -- ^ Negative Black, counts as -1 blacks for the invariant
55+ | NBlack -- Negative Black, counts as -1 blacks for the invariant
50− | NBlack
51
56
52
57
53showNColor : NColor -> String
58showNColor : NColor -> String
54−showNColor c = case c of
59+showNColor c =
60+ case c of
55− Red -> "Red"
61+ Red -> "Red"
56− Black -> "Black"
62+ Black -> "Black"
57− BBlack -> "BBlack"
63+ BBlack -> "BBlack"
58− NBlack -> "NBlack"
64+ NBlack -> "NBlack"
59
65
60−data LeafColor = LBlack
66+data LeafColor
67+ = LBlack
61− -- ^ Double Black, counts as 2
68+ | LBBlack -- Double Black, counts as 2
62− | LBBlack
63
69
64showLColor : LeafColor -> String
70showLColor : LeafColor -> String
65showLColor c = case c of
71showLColor c = case c of
66 LBlack -> "LBlack"
72 LBlack -> "LBlack"
67 LBBlack -> "LBBlack"
73 LBBlack -> "LBBlack"
68
74
75+data Dict k v
69−data Dict k v = RBNode NColor k v (Dict k v) (Dict k v)
76+ = RBNode NColor k v (Dict k v) (Dict k v)
70− | RBEmpty LeafColor
77+ | RBEmpty LeafColor
71
78
72{-| Create an empty dictionary. -}
79{-| Create an empty dictionary. -}
73empty : Dict comparable v
80empty : Dict comparable v
libraries/Set.elm+9−7
@@ -1,11 +1,13 @@
1
1
2+module Set
3+ ( Set
2−module Set (empty,singleton,insert,remove
4+ , empty, singleton, insert, remove
3− ,member
5+ , member
4− ,foldl,foldr,map
6+ , foldl, foldr, map
5− ,filter,partition
7+ , filter, partition
6− ,union,intersect,diff
8+ , union, intersect, diff
7− ,toList,fromList
9+ , toList, fromList
8− ) where
10+ ) where
9
11
10{-| A set of unique values. The values can be any comparable type. This
12{-| A set of unique values. The values can be any comparable type. This
11includes `Int`, `Float`, `Time`, `Char`, `String`, and tuples or lists
13includes `Int`, `Float`, `Time`, `Char`, `String`, and tuples or lists