git.iko.soy/elk
on master help sign in
Merge branch 'exposing'
876c49eEvan Czaplicki
src/AST/Module.hs+39−30
compare with master
unifiedsplit
@@ -1,4 +1,14 @@
1−module AST.Module where
1+module AST.Module
2+ ( Interfaces
3+ , Types, Aliases, ADTs
4+ , AdtInfo, CanonicalAdt
5+ , SourceModule, ValidModule, CanonicalModule
6+ , Module(..), CanonicalBody(..)
7+ , HeaderAndImports(..)
8+ , Name, nameToString, nameIsNative
9+ , Interface(..), toInterface
10+ , ImportMethod(..)
11+ ) where
2
12
3import Data.Binary
13import Data.Binary
4import qualified Data.List as List
14import qualified Data.List as List
@@ -65,10 +75,14 @@ data HeaderAndImports = HeaderAndImports
65 , _imports :: [(Name, ImportMethod)]
75 , _imports :: [(Name, ImportMethod)]
66 }
76 }
67
77
78+
68type Name = [String] -- must be non-empty
79type Name = [String] -- must be non-empty
69
80
81+
70nameToString :: Name -> String
82nameToString :: Name -> String
83+nameToString =
71−nameToString = List.intercalate "."
84+ List.intercalate "."
85+
72
86
73nameIsNative :: Name -> Bool
87nameIsNative :: Name -> Bool
74nameIsNative name =
88nameIsNative name =
@@ -121,27 +135,19 @@ instance Binary Interface where
121
135
122-- IMPORT METHOD
136-- IMPORT METHOD
123
137
124−data ImportMethod
138+data ImportMethod = ImportMethod
125− = As !String
139+ { alias :: Maybe String
126− | Open !(Var.Listing Var.Value)
140+ , exposedVars :: !(Var.Listing Var.Value)
127−
141+ }
128−open :: ImportMethod
129−open = Open (Var.openListing)
130
142
131−importing :: [Var.Value] -> ImportMethod
132−importing xs = Open (Var.Listing xs False)
133
143
134instance Binary ImportMethod where
144instance Binary ImportMethod where
135− put method =
145+ put (ImportMethod alias exposedVars) =
136− case method of
137− As alias -> putWord8 0 >> put alias
146+ do put alias
138− Open listing -> putWord8 1 >> put listing
147+ put exposedVars
139
148
140− get = do tag <- getWord8
149+ get =
141− case tag of
150+ ImportMethod <$> get <*> get
142− 0 -> As <$> get
143− 1 -> Open <$> get
144− _ -> error "Error reading valid ImportMethod type from serialized string"
145
151
146
152
147-- PRETTY PRINTING
153-- PRETTY PRINTING
@@ -150,19 +156,22 @@ instance (Pretty exs, Pretty body) => Pretty (Module exs body) where
150 pretty (Module names _ exs ims body) =
156 pretty (Module names _ exs ims body) =
151 P.vcat [modul, P.text "", prettyImports, P.text "", pretty body]
157 P.vcat [modul, P.text "", prettyImports, P.text "", pretty body]
152 where
158 where
159+ modul =
153− modul = P.text "module" <+> name <+> pretty exs <+> P.text "where"
160+ P.text "module" <+> name <+> pretty exs <+> P.text "where"
154− name = P.text (List.intercalate "." names)
161+
162+ name =
163+ P.text (nameToString names)
155
164
156 prettyImports =
165 prettyImports =
157− P.vcat $ map prettyMethod ims
166+ P.vcat $ map prettyMethod ims
158
167
159
168
160prettyMethod :: (Name, ImportMethod) -> Doc
169prettyMethod :: (Name, ImportMethod) -> Doc
161−prettyMethod import' =
170+prettyMethod (name, ImportMethod maybeAlias exposedVars) =
171+ let prettyAlias =
162− case import' of
172+ case maybeAlias of
163− ([name], As alias)
164− | name == alias -> P.empty
173+ Nothing -> P.empty
165−
174+ Just alias ->
166− (_, As alias) -> P.text "as" <+> P.text alias
175+ P.text "as" <+> P.text alias
167−
176+ in
168− (_, Open listing) -> pretty listing
177+ prettyAlias <+> P.text "exposing" <+> pretty exposedVars
src/AST/Variable.hs+10
@@ -137,6 +137,16 @@ openListing =
137 Listing [] True
137 Listing [] True
138
138
139
139
140+closedListing :: Listing a
141+closedListing =
142+ Listing [] False
143+
144+
145+listing :: [a] -> Listing a
146+listing xs =
147+ Listing xs False
148+
149+
140-- | A value that can be imported or exported
150-- | A value that can be imported or exported
141data Value
151data Value
142 = Value !String
152 = Value !String
src/Elm/Compiler/Module.hs+1−1
@@ -34,7 +34,7 @@ newtype Name = Name [String]
34
34
35defaultImports :: [Name]
35defaultImports :: [Name]
36defaultImports =
36defaultImports =
37− map Name (Map.keys Defaults.defaultImports)
37+ map (Name . fst) Defaults.defaultImports
38
38
39
39
40-- POKING AROUND INTERFACES
40-- POKING AROUND INTERFACES
src/Parse/Helpers.hs+1−1
@@ -29,7 +29,7 @@ reserveds =
29 , "let", "in"
29 , "let", "in"
30 , "type"
30 , "type"
31 , "module", "where"
31 , "module", "where"
32− , "import", "as", "hiding", "open"
32+ , "import", "as", "hiding", "exposing"
33 , "export", "foreign"
33 , "export", "foreign"
34 , "deriving"
34 , "deriving"
35 , "input", "output"
35 , "input", "output"
src/Parse/Module.hs+19−14
@@ -1,7 +1,6 @@
1module Parse.Module (header, headerAndImports, getModuleName) where
1module Parse.Module (header, headerAndImports, getModuleName) where
2
2
3import Control.Applicative ((<$>), (<*>))
3import Control.Applicative ((<$>), (<*>))
4−import Data.List (intercalate)
5import Text.Parsec hiding (newline, spaces)
4import Text.Parsec hiding (newline, spaces)
6
5
7import Parse.Helpers
6import Parse.Helpers
@@ -18,7 +17,7 @@ getModuleName source =
18 getModuleName =
17 getModuleName =
19 do optional freshLine
18 do optional freshLine
20 (names, _) <- header
19 (names, _) <- header
21− return (intercalate "." names)
20+ return (Module.nameToString names)
22
21
23
22
24headerAndImports :: IParser Module.HeaderAndImports
23headerAndImports :: IParser Module.HeaderAndImports
@@ -52,19 +51,25 @@ import' =
52 do try (reserved "import")
51 do try (reserved "import")
53 whitespace
52 whitespace
54 names <- dotSep1 capVar
53 names <- dotSep1 capVar
55− (,) names <$> option (Module.As (intercalate "." names)) method
54+ (,) names <$> method (Module.nameToString names)
56 where
55 where
57− method :: IParser Module.ImportMethod
56+ method :: String -> IParser Module.ImportMethod
58− method = as' <|> importing'
57+ method defaultAlias =
59−
58+ Module.ImportMethod
59+ <$> option (Just defaultAlias) (Just <$> as')
60+ <*> option Var.closedListing exposing
61+
60− as' :: IParser Module.ImportMethod
62+ as' :: IParser String
61− as' = do
63+ as' =
62− try (whitespace >> reserved "as")
64+ do try (whitespace >> reserved "as")
63− whitespace
65+ whitespace
64− Module.As <$> capVar <?> "alias for module"
66+ capVar <?> "alias for module"
65−
67+
66− importing' :: IParser Module.ImportMethod
68+ exposing :: IParser (Var.Listing Var.Value)
69+ exposing =
70+ do try (whitespace >> reserved "exposing")
71+ whitespace
67− importing' = Module.Open <$> listing value
72+ listing value
68
73
69
74
70listing :: IParser a -> IParser (Var.Listing a)
75listing :: IParser a -> IParser (Var.Listing a)
src/Transform/AddDefaultImports.hs+12−62
@@ -1,47 +1,28 @@
1−{-# LANGUAGE FlexibleContexts #-}
2module Transform.AddDefaultImports (add, defaultImports) where
1module Transform.AddDefaultImports (add, defaultImports) where
3
2
4−import Prelude hiding (maybe)
5−import qualified Data.Map as Map
6−
7import qualified AST.Module as Module
3import qualified AST.Module as Module
8import qualified AST.Variable as Var
4import qualified AST.Variable as Var
9
5
10
6
11−type ImportDict =
12− Map.Map Module.Name ([String], Var.Listing Var.Value)
13−
14−
15-- DESCRIPTION OF DEFAULT IMPORTS
7-- DESCRIPTION OF DEFAULT IMPORTS
16
8
17(==>) :: a -> b -> (a,b)
9(==>) :: a -> b -> (a,b)
18(==>) = (,)
10(==>) = (,)
19
11
20
12
21−defaultImports :: ImportDict
13+defaultImports :: [(Module.Name, Module.ImportMethod)]
22defaultImports =
14defaultImports =
23− Map.fromList
24− [ ["Basics"] ==> ([], Var.openListing)
15+ [ ["Basics"] ==> Module.ImportMethod Nothing Var.openListing
25− , ["List"] ==> ([], Var.Listing [Var.Value "::"] False)
16+ , ["List"] ==> exposing [Var.Value "::"]
26− , ["Maybe"] ==> ([], Var.Listing [maybe] False)
17+ , ["Maybe"] ==> exposing [Var.Union "Maybe" Var.openListing]
27− , ["Result"] ==> ([], Var.Listing [result] False)
18+ , ["Result"] ==> exposing [Var.Union "Result" Var.openListing]
28− , ["Signal"] ==> ([], Var.Listing [signal] False)
19+ , ["Signal"] ==> exposing [Var.Union "Signal" Var.closedListing]
29 ]
20 ]
30
21
31
22
32−maybe :: Var.Value
23+exposing :: [Var.Value] -> Module.ImportMethod
33−maybe =
24+exposing vars =
34− Var.Union "Maybe" Var.openListing
25+ Module.ImportMethod Nothing (Var.listing vars)
35−
36−
37−result :: Var.Value
38−result =
39− Var.Union "Result" Var.openListing
40−
41−
42−signal :: Var.Value
43−signal =
44− Var.Union "Signal" (Var.Listing [] False)
45
26
46
27
47-- ADDING DEFAULT IMPORTS TO A MODULE
28-- ADDING DEFAULT IMPORTS TO A MODULE
@@ -51,37 +32,6 @@ add needsDefaults (Module.Module moduleName path exports imports decls) =
51 Module.Module moduleName path exports ammendedImports decls
32 Module.Module moduleName path exports ammendedImports decls
52 where
33 where
53 ammendedImports =
34 ammendedImports =
54− importDictToList $
35+ if needsDefaults
55− foldr addImport (if needsDefaults then defaultImports else Map.empty) imports
36+ then defaultImports ++ imports
56−
57−
58−importDictToList :: ImportDict -> [(Module.Name, Module.ImportMethod)]
59−importDictToList dict =
60− concatMap toImports (Map.toList dict)
61− where
62− toImports (name, (qualifiers, listing@(Var.Listing explicits open))) =
63− map (\qualifier -> (name, Module.As qualifier)) qualifiers
64− ++
65− if open || not (null explicits)
66− then [(name, Module.Open listing)]
67− else []
37+ else imports
68−
69−
70−addImport :: (Module.Name, Module.ImportMethod) -> ImportDict -> ImportDict
71−addImport (name, method) importDict =
72− Map.alter mergeMethods name importDict
73− where
74− mergeMethods :: Maybe ([String], Var.Listing Var.Value)
75− -> Maybe ([String], Var.Listing Var.Value)
76− mergeMethods entry =
77− let (qualifiers, listing) =
78− case entry of
79− Nothing -> ([], Var.Listing [] False)
80− Just v -> v
81− in
82− case method of
83− Module.As qualifier ->
84− Just (qualifier : qualifiers, listing)
85−
86− Module.Open newListing ->
87− Just (qualifiers, newListing)
src/Transform/Canonicalize/Setup.hs+125−69
@@ -30,11 +30,18 @@ import qualified Transform.Interface as Interface
30
30
31environment :: Module.Interfaces -> Module.ValidModule -> Canonicalizer [Doc] Environment
31environment :: Module.Interfaces -> Module.ValidModule -> Canonicalizer [Doc] Environment
32environment interfaces modul@(Module.Module _ _ _ imports decls) =
32environment interfaces modul@(Module.Module _ _ _ imports decls) =
33− do () <- allImportsAvailable
33+ do () <- allImportsAvailable
34+ let moduleName =
34− let moduleName = Module.names modul
35+ Module.names modul
36+
37+ nonLocalEnv <-
35− nonLocalEnv <- foldM (addImports moduleName interfaces) (builtIns moduleName) imports
38+ foldM (addImports moduleName interfaces) (builtIns moduleName) imports
39+
40+ let (aliases, env) =
36− let (aliases, env) = List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls
41+ List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls
42+
37− addTypeAliases moduleName aliases env
43+ addTypeAliases moduleName aliases env
44+
38 where
45 where
39 allImportsAvailable :: Canonicalizer [Doc] ()
46 allImportsAvailable :: Canonicalizer [Doc] ()
40 allImportsAvailable =
47 allImportsAvailable =
@@ -42,53 +49,80 @@ environment interfaces modul@(Module.Module _ _ _ imports decls) =
42 [] -> return ()
49 [] -> return ()
43 missings -> throwError [ P.text (missingModuleError missings) ]
50 missings -> throwError [ P.text (missingModuleError missings) ]
44 where
51 where
52+ modules =
45− modules = map fst imports
53+ map fst imports
46
54
55+ found m =
47− found m = Map.member m interfaces || Module.nameIsNative m
56+ Map.member m interfaces || Module.nameIsNative m
48
57
49 missingModuleError missings =
58 missingModuleError missings =
59+ concat
50− concat [ "The following imports were not found:\n "
60+ [ "The following imports were not found:\n "
51− , List.intercalate ", " (map Module.nameToString missings)
61+ , List.intercalate ", " (map Module.nameToString missings)
52− ]
62+ ]
53
63
54
64
65+addImports
66+ :: Module.Name
67+ -> Module.Interfaces
68+ -> Environment
55−addImports :: Module.Name -> Module.Interfaces -> Environment -> (Module.Name, Module.ImportMethod)
69+ -> (Module.Name, Module.ImportMethod)
56− -> Canonicalizer [Doc] Environment
70+ -> Canonicalizer [Doc] Environment
57addImports moduleName interfaces environ (name, method)
71addImports moduleName interfaces environ (name, method)
58− | Module.nameIsNative name = return environ
72+ | Module.nameIsNative name =
73+ return environ
74+
59 | otherwise =
75 | otherwise =
60− case method of
76+ let (Module.ImportMethod maybeAlias listing) = method
61− Module.As name' ->
62− return (updateEnviron (name' ++ "."))
63
77
64− Module.Open (Var.Listing vs open)
78+ (Var.Listing exposedVars open) = listing
79+
80+ qualifier =
81+ maybe (Module.nameToString name) id maybeAlias
82+
83+ env =
84+ updateEnviron (qualifier ++ ".") environ
85+ in
86+ if open
65− | open -> return (updateEnviron "")
87+ then return (updateEnviron "" env)
66− | otherwise -> foldM (addValue name interface) environ vs
88+ else foldM (addValue name interface) env exposedVars
67− where
89+ where
90+ interface =
68− interface = Interface.filterExports ((Map.!) interfaces name)
91+ Interface.filterExports ((Map.!) interfaces name)
69−
92+
70− updateEnviron prefix =
93+ updateEnviron prefix env =
71− let dict' = dict . map (first (prefix++)) in
94+ let dict' = dict . map (first (prefix++)) in
72− merge environ $
95+ merge env $
73− Env { _home = moduleName
96+ Env { _home = moduleName
74− , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors
97+ , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors
75− , _adts = dict' $ map pair (Map.keys (iAdts interface))
98+ , _adts = dict' $ map pair (Map.keys (iAdts interface))
76− , _aliases = dict' $ map alias (Map.toList (iAliases interface))
99+ , _aliases = dict' $ map alias (Map.toList (iAliases interface))
77− , _patterns = dict' $ ctors
100+ , _patterns = dict' $ ctors
78− }
101+ }
79
102
80− canonical :: String -> Var.Canonical
103+ canonical :: String -> Var.Canonical
104+ canonical =
81− canonical = Var.Canonical (Var.Module name)
105+ Var.Canonical (Var.Module name)
82
106
83− pair :: String -> (String, Var.Canonical)
107+ pair :: String -> (String, Var.Canonical)
108+ pair key =
84− pair key = (key, canonical key)
109+ (key, canonical key)
85
110
111+ alias (x,(tvars,tipe)) =
86− alias (x,(tvars,tipe)) = (x, (canonical x, tvars, tipe))
112+ (x, (canonical x, tvars, tipe))
87
113
114+ ctors =
115+ concatMap
116+ (map (pair . fst) . snd . snd)
88− ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))
117+ (Map.toList (iAdts interface))
89
118
119+
120+addValue
121+ :: Module.Name
90−addValue :: Module.Name -> Module.Interface -> Environment -> Var.Value
122+ -> Module.Interface
123+ -> Environment
124+ -> Var.Value
91− -> Canonicalizer [Doc] Environment
125+ -> Canonicalizer [Doc] Environment
92addValue moduleName interface env value =
126addValue moduleName interface env value =
93 let name = Module.nameToString moduleName
127 let name = Module.nameToString moduleName
94 insert' x = insert x (Var.Canonical (Var.Module moduleName) x)
128 insert' x = insert x (Var.Canonical (Var.Module moduleName) x)
@@ -98,7 +132,9 @@ addValue moduleName interface env value =
98 in
132 in
99 case value of
133 case value of
100 Var.Value x
134 Var.Value x
101− | Map.notMember x (iTypes interface) -> notFound x
135+ | Map.notMember x (iTypes interface) ->
136+ notFound x
137+
102 | otherwise ->
138 | otherwise ->
103 return $ env { _values = insert' x (_values env) }
139 return $ env { _values = insert' x (_values env) }
104
140
@@ -126,11 +162,12 @@ addValue moduleName interface env value =
126 case Map.lookup x (iAdts interface) of
162 case Map.lookup x (iAdts interface) of
127 Nothing -> notFound x
163 Nothing -> notFound x
128 Just (_tvars, ctors) ->
164 Just (_tvars, ctors) ->
129− do ctors' <- filterNames (map fst ctors)
165+ do ctors' <- filterNames (map fst ctors)
166+ return $ env
130− return $ env { _adts = insert' x (_adts env)
167+ { _adts = insert' x (_adts env)
131− , _values = foldr insert' (_values env) ctors'
168+ , _values = foldr insert' (_values env) ctors'
132− , _patterns = foldr insert' (_patterns env) ctors'
169+ , _patterns = foldr insert' (_patterns env) ctors'
133− }
170+ }
134 where
171 where
135 filterNames names
172 filterNames names
136 | open = return names
173 | open = return names
@@ -139,19 +176,22 @@ addValue moduleName interface env value =
139 [] -> return names
176 [] -> return names
140 c:_ -> notFound c
177 c:_ -> notFound c
141
178
179+
142type Node = ((String, [String], Type.RawType), String, [String])
180type Node = ((String, [String], Type.RawType), String, [String])
143
181
182+
144node :: String -> [String] -> Type.RawType -> Node
183node :: String -> [String] -> Type.RawType -> Node
184+node name tvars alias =
145−node name tvars alias = ((name, tvars, alias), name, edges alias)
185+ ((name, tvars, alias), name, edges alias)
146− where
186+ where
147− edges tipe =
187+ edges tipe =
148− case tipe of
188+ case tipe of
149− Type.Lambda t1 t2 -> edges t1 ++ edges t2
189+ Type.Lambda t1 t2 -> edges t1 ++ edges t2
150− Type.Var _ -> []
190+ Type.Var _ -> []
151− Type.Type (Var.Raw x) -> [x]
191+ Type.Type (Var.Raw x) -> [x]
152− Type.App t ts -> edges t ++ concatMap edges ts
192+ Type.App t ts -> edges t ++ concatMap edges ts
153− Type.Record fs ext -> maybe [] edges ext ++ concatMap (edges . snd) fs
193+ Type.Record fs ext -> maybe [] edges ext ++ concatMap (edges . snd) fs
154− Type.Aliased _ t -> edges t
194+ Type.Aliased _ t -> edges t
155
195
156
196
157addTypeAliases
197addTypeAliases
@@ -232,7 +272,11 @@ typeAliasErrorExplanation =
232-- When canonicalizing, all _values should be Local, but all _adts and _patterns
272-- When canonicalizing, all _values should be Local, but all _adts and _patterns
233-- should be fully namespaced. With _adts, they may appear in types that can
273-- should be fully namespaced. With _adts, they may appear in types that can
234-- escape the module.
274-- escape the module.
275+addDecl
276+ :: Module.Name
235−addDecl :: Module.Name -> ([Node], Environment) -> D.ValidDecl -> ([Node], Environment)
277+ -> ([Node], Environment)
278+ -> D.ValidDecl
279+ -> ([Node], Environment)
236addDecl moduleName info@(nodes,env) decl =
280addDecl moduleName info@(nodes,env) decl =
237 let namespacedVar = Var.Canonical (Var.Module moduleName)
281 let namespacedVar = Var.Canonical (Var.Module moduleName)
238 addLocal x e = insert x (Var.local x) e
282 addLocal x e = insert x (Var.local x) e
@@ -241,29 +285,41 @@ addDecl moduleName info@(nodes,env) decl =
241 case decl of
285 case decl of
242 D.Definition (Valid.Definition pattern _ _) ->
286 D.Definition (Valid.Definition pattern _ _) ->
243 (,) nodes $ env
287 (,) nodes $ env
288+ { _values =
244− { _values = foldr addLocal (_values env) (P.boundVarList pattern) }
289+ foldr addLocal (_values env) (P.boundVarList pattern)
290+ }
245
291
246 D.Datatype name _ ctors ->
292 D.Datatype name _ ctors ->
247 (,) nodes $ env
293 (,) nodes $ env
294+ { _values =
248− { _values = addCtors addLocal (_values env)
295+ addCtors addLocal (_values env)
296+ , _adts =
249− , _adts = addNamespaced name (_adts env)
297+ addNamespaced name (_adts env)
298+ , _patterns =
250− , _patterns = addCtors addNamespaced (_patterns env)
299+ addCtors addNamespaced (_patterns env)
251− }
300+ }
252 where
301 where
253 addCtors how e = foldr how e (map fst ctors)
302 addCtors how e = foldr how e (map fst ctors)
254
303
255 D.TypeAlias name tvars alias ->
304 D.TypeAlias name tvars alias ->
256 (,) (node name tvars alias : nodes) $ env
305 (,) (node name tvars alias : nodes) $ env
306+ { _values =
257− { _values = case alias of
307+ case alias of
308+ Type.Record _ _ ->
258− Type.Record _ _ -> addLocal name (_values env)
309+ addLocal name (_values env)
310+ _ ->
259− _ -> _values env
311+ _values env
260− }
312+ }
261
313
262 D.Port port ->
314 D.Port port ->
263− let portName = case port of
315+ let portName =
316+ case port of
264− D.Out name _ _ -> name
317+ D.Out name _ _ -> name
265− D.In name _ -> name
318+ D.In name _ -> name
266 in
319 in
320+ (,) nodes $ env
321+ { _values =
267− (,) nodes $ env { _values = addLocal portName (_values env) }
322+ addLocal portName (_values env)
323+ }
268
324
269 D.Fixity _ _ _ -> info
325 D.Fixity _ _ _ -> info