git.iko.soy/elk
on master help sign in
Filter unused modules
70bd232Evan Czaplicki
Elm.cabal+1
compare with master
unifiedsplit
@@ -256,6 +256,7 @@ Executable elm-doc
256 pretty,
256 pretty,
257 scientific,
257 scientific,
258 text,
258 text,
259+ transformers >= 0.2,
259 union-find,
260 union-find,
260 yaml
261 yaml
261
262
compiler/AST/PrettyPrint.hs+4
@@ -1,6 +1,7 @@
1{-# LANGUAGE FlexibleInstances #-}
1{-# LANGUAGE FlexibleInstances #-}
2module AST.PrettyPrint where
2module AST.PrettyPrint where
3
3
4+import Control.Monad.Trans.Error
4import Text.PrettyPrint as P
5import Text.PrettyPrint as P
5import qualified AST.Helpers as Help
6import qualified AST.Helpers as Help
6
7
@@ -36,3 +37,6 @@ eightyCharLines indent message = answer
36 step (sentence, slen, space) (word, wlen)
37 step (sentence, slen, space) (word, wlen)
37 | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")
38 | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")
38 | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")
39 | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")
40+
41+instance ErrorList Doc where
42+ listMsg str = [ P.text str ]
compiler/Transform/Canonicalize.hs+29−17
@@ -2,9 +2,11 @@
2module Transform.Canonicalize (module', filterExports) where
2module Transform.Canonicalize (module', filterExports) where
3
3
4import Control.Applicative ((<$>),(<*>))
4import Control.Applicative ((<$>),(<*>))
5−import qualified Data.Either as Either
5+import Control.Monad.Error (runErrorT, throwError)
6+import Control.Monad.State (runState)
6import qualified Data.List as List
7import qualified Data.List as List
7import qualified Data.Map as Map
8import qualified Data.Map as Map
9+import qualified Data.Set as Set
8import qualified Data.Traversable as T
10import qualified Data.Traversable as T
9
11
10import AST.Expression.General (Expr'(..), dummyLet)
12import AST.Expression.General (Expr'(..), dummyLet)
@@ -29,7 +31,18 @@ import qualified Transform.SortDefinitions as Transform
29import qualified Transform.Declaration as Transform
31import qualified Transform.Declaration as Transform
30
32
31module' :: Module.Interfaces -> Module.ValidModule -> Either [Doc] Module.CanonicalModule
33module' :: Module.Interfaces -> Module.ValidModule -> Either [Doc] Module.CanonicalModule
32−module' interfaces modul@(Module.Module _ _ exs _ decls) =
34+module' interfaces modul =
35+ filterImports <$> modul'
36+ where
37+ canonicalizer = moduleHelp interfaces modul
38+ (modul', usedModules) = runState (runErrorT canonicalizer) Set.empty
39+ filterImports m =
40+ let used (name,_) = Set.member name usedModules
41+ in m { Module.imports = filter used (Module.imports m) }
42+
43+moduleHelp :: Module.Interfaces -> Module.ValidModule
44+ -> Canonicalizer [Doc] Module.CanonicalModule
45+moduleHelp interfaces modul@(Module.Module _ _ exs _ decls) =
33 do env <- Setup.environment interfaces modul
46 do env <- Setup.environment interfaces modul
34 canonicalDecls <- mapM (declaration env) decls
47 canonicalDecls <- mapM (declaration env) decls
35 exports' <- delist locals exs
48 exports' <- delist locals exs
@@ -57,15 +70,15 @@ module' interfaces modul@(Module.Module _ _ exs _ decls) =
57 [ D.portName port | D.Port port <- decls ]
70 [ D.portName port | D.Port port <- decls ]
58 }
71 }
59
72
60−delist :: [Var.Value] -> Var.Listing Var.Value -> Either [Doc] [Var.Value]
73+delist :: [Var.Value] -> Var.Listing Var.Value -> Canonicalizer [Doc] [Var.Value]
61delist fullList (Var.Listing partial open)
74delist fullList (Var.Listing partial open)
62 | open = return fullList
75 | open = return fullList
63 | otherwise = go [] (List.sort fullList) (List.sort partial)
76 | otherwise = go [] (List.sort fullList) (List.sort partial)
64 where
77 where
65 notFound xs =
78 notFound xs =
66− Left $ [ P.text "Export Error: trying to export non-existent values:" <+>
79+ throwError [ P.text "Export Error: trying to export non-existent values:" <+>
67− commaSep (map pretty xs)
80+ commaSep (map pretty xs)
68− ]
81+ ]
69
82
70 go list full partial =
83 go list full partial =
71 case (full, partial) of
84 case (full, partial) of
@@ -123,13 +136,13 @@ declToValue decl =
123
136
124 _ -> []
137 _ -> []
125
138
126−declaration :: Environment -> D.ValidDecl -> Either [Doc] D.CanonicalDecl
139+declaration :: Environment -> D.ValidDecl -> Canonicalizer [Doc] D.CanonicalDecl
127declaration env decl =
140declaration env decl =
128 let canonicalize kind context pattern env v =
141 let canonicalize kind context pattern env v =
129− case kind env v of
130− Right v' -> Right v'
131− Left err -> Left [ P.vcat [ ctx, P.text err ] ]
132− where ctx = P.text ("Error in " ++ context) <+> pretty pattern <> P.colon
142+ let ctx = P.text ("Error in " ++ context) <+> pretty pattern <> P.colon
143+ throw err = P.vcat [ ctx, P.text err ]
144+ in
145+ Env.onError throw (kind env v)
133 in
146 in
134 case decl of
147 case decl of
135 D.Definition (Valid.Definition p e t) ->
148 D.Definition (Valid.Definition p e t) ->
@@ -161,14 +174,13 @@ declaration env decl =
161 D.Fixity assoc prec op -> return $ D.Fixity assoc prec op
174 D.Fixity assoc prec op -> return $ D.Fixity assoc prec op
162
175
163
176
164−expression :: Environment -> Valid.Expr -> Either [Doc] Canonical.Expr
177+expression :: Environment -> Valid.Expr -> Canonicalizer [Doc] Canonical.Expr
165expression env (A.A ann expr) =
178expression env (A.A ann expr) =
166 let go = expression env
179 let go = expression env
167 tipe' environ = format . Canonicalize.tipe environ
180 tipe' environ = format . Canonicalize.tipe environ
168− throw err =
169− let msg = P.text "Error" <+> pretty ann <> P.colon
181+ throw err = P.vcat [ P.text "Error" <+> pretty ann <> P.colon
170− in Left [ P.vcat [ msg, P.text err ] ]
182+ , P.text err ]
171− format = Either.either throw return
183+ format = Env.onError throw
172 in
184 in
173 A.A ann <$>
185 A.A ann <$>
174 case expr of
186 case expr of
@@ -228,7 +240,7 @@ expression env (A.A ann expr) =
228
240
229 GLShader uid src tipe -> return (GLShader uid src tipe)
241 GLShader uid src tipe -> return (GLShader uid src tipe)
230
242
231−pattern :: Environment -> P.RawPattern -> Either String P.CanonicalPattern
243+pattern :: Environment -> P.RawPattern -> Canonicalizer String P.CanonicalPattern
232pattern env ptrn =
244pattern env ptrn =
233 case ptrn of
245 case ptrn of
234 P.Var x -> return $ P.Var x
246 P.Var x -> return $ P.Var x
compiler/Transform/Canonicalize/Environment.hs+26
@@ -2,13 +2,19 @@
2module Transform.Canonicalize.Environment where
2module Transform.Canonicalize.Environment where
3
3
4import Control.Arrow (second)
4import Control.Arrow (second)
5+import qualified Control.Monad.Error as Error
6+import qualified Control.Monad.State as State
5import qualified Data.Map as Map
7import qualified Data.Map as Map
8+import qualified Data.Set as Set
6
9
7import AST.Expression.General (saveEnvName)
10import AST.Expression.General (saveEnvName)
8import qualified AST.Pattern as P
11import qualified AST.Pattern as P
9import qualified AST.Type as Type
12import qualified AST.Type as Type
10import qualified AST.Variable as Var
13import qualified AST.Variable as Var
11
14
15+import AST.PrettyPrint ()
16+import Text.PrettyPrint (Doc)
17+
12type Dict a = Map.Map String [a]
18type Dict a = Map.Map String [a]
13
19
14dict :: [(String,a)] -> Dict a
20dict :: [(String,a)] -> Dict a
@@ -17,6 +23,26 @@ dict pairs = Map.fromList $ map (second (:[])) pairs
17insert :: String -> a -> Dict a -> Dict a
23insert :: String -> a -> Dict a -> Dict a
18insert key value = Map.insertWith (++) key [value]
24insert key value = Map.insertWith (++) key [value]
19
25
26+type Canonicalizer err a = Error.ErrorT err (State.State (Set.Set String)) a
27+
28+using :: Var.Canonical -> Canonicalizer String Var.Canonical
29+using var@(Var.Canonical home _) =
30+ do case home of
31+ Var.BuiltIn -> return ()
32+ Var.Module path -> Error.lift (State.modify (Set.insert path))
33+ Var.Local -> return ()
34+ return var
35+
36+onError :: (String -> Doc) -> Canonicalizer String a -> Canonicalizer [Doc] a
37+onError handler canonicalizer =
38+ do usedModules <- Error.lift State.get
39+ let (result, usedModules') =
40+ State.runState (Error.runErrorT canonicalizer) usedModules
41+ Error.lift (State.put usedModules')
42+ case result of
43+ Left err -> Error.throwError [handler err]
44+ Right x -> return x
45+
20data Environment = Env
46data Environment = Env
21 { _values :: Dict Var.Canonical
47 { _values :: Dict Var.Canonical
22 , _adts :: Dict Var.Canonical
48 , _adts :: Dict Var.Canonical
compiler/Transform/Canonicalize/Setup.hs+19−19
@@ -3,7 +3,7 @@ module Transform.Canonicalize.Setup (environment) where
3
3
4import Control.Arrow (first)
4import Control.Arrow (first)
5import Control.Monad (foldM)
5import Control.Monad (foldM)
6−import qualified Data.Either as Either
6+import Control.Monad.Error (throwError)
7import qualified Data.Graph as Graph
7import qualified Data.Graph as Graph
8import qualified Data.List as List
8import qualified Data.List as List
9import qualified Data.Map as Map
9import qualified Data.Map as Map
@@ -22,7 +22,7 @@ import Text.PrettyPrint as P
22import Transform.Canonicalize.Environment as Env
22import Transform.Canonicalize.Environment as Env
23import qualified Transform.Canonicalize.Type as Canonicalize
23import qualified Transform.Canonicalize.Type as Canonicalize
24
24
25−environment :: Module.Interfaces -> Module.ValidModule -> Either [Doc] Environment
25+environment :: Module.Interfaces -> Module.ValidModule -> Canonicalizer [Doc] Environment
26environment interfaces modul@(Module.Module _ _ _ imports decls) =
26environment interfaces modul@(Module.Module _ _ _ imports decls) =
27 do () <- allImportsAvailable
27 do () <- allImportsAvailable
28 nonLocalEnv <- foldM (addImports interfaces) builtIns imports
28 nonLocalEnv <- foldM (addImports interfaces) builtIns imports
@@ -30,11 +30,11 @@ environment interfaces modul@(Module.Module _ _ _ imports decls) =
30 (aliases, env) = List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls
30 (aliases, env) = List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls
31 addTypeAliases moduleName aliases env
31 addTypeAliases moduleName aliases env
32 where
32 where
33− allImportsAvailable :: Either [Doc] ()
33+ allImportsAvailable :: Canonicalizer [Doc] ()
34 allImportsAvailable =
34 allImportsAvailable =
35 case filter (not . found) modules of
35 case filter (not . found) modules of
36− [] -> Right ()
36+ [] -> return ()
37− missings -> Left [ P.text (missingModuleError missings) ]
37+ missings -> throwError [ P.text (missingModuleError missings) ]
38 where
38 where
39 modules = map fst imports
39 modules = map fst imports
40
40
@@ -47,7 +47,7 @@ environment interfaces modul@(Module.Module _ _ _ imports decls) =
47 , "flag to detect modules you have written." ]
47 , "flag to detect modules you have written." ]
48
48
49addImports :: Module.Interfaces -> Environment -> (String, Module.ImportMethod)
49addImports :: Module.Interfaces -> Environment -> (String, Module.ImportMethod)
50− -> Either [Doc] Environment
50+ -> Canonicalizer [Doc] Environment
51addImports interfaces environ (name,method)
51addImports interfaces environ (name,method)
52 | List.isPrefixOf "Native." name = return environ
52 | List.isPrefixOf "Native." name = return environ
53 | otherwise =
53 | otherwise =
@@ -81,12 +81,12 @@ addImports interfaces environ (name,method)
81 ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))
81 ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))
82
82
83addValue :: String -> Module.Interface -> Environment -> Var.Value
83addValue :: String -> Module.Interface -> Environment -> Var.Value
84− -> Either [Doc] Environment
84+ -> Canonicalizer [Doc] Environment
85addValue name interface env value =
85addValue name interface env value =
86 let insert' x = insert x (Var.Canonical (Var.Module name) x)
86 let insert' x = insert x (Var.Canonical (Var.Module name) x)
87 msg x = "Import Error: Could not import value '" ++ name ++ "." ++ x ++
87 msg x = "Import Error: Could not import value '" ++ name ++ "." ++ x ++
88 "'.\n It is not exported by module " ++ name ++ "."
88 "'.\n It is not exported by module " ++ name ++ "."
89− notFound x = Left [ P.text (msg x) ]
89+ notFound x = throwError [ P.text (msg x) ]
90 in
90 in
91 case value of
91 case value of
92 Var.Value x
92 Var.Value x
@@ -136,31 +136,31 @@ node name tvars alias = ((name, tvars, alias), name, edges alias)
136 Type.Record fs ext -> maybe [] edges ext ++ concatMap (edges . snd) fs
136 Type.Record fs ext -> maybe [] edges ext ++ concatMap (edges . snd) fs
137 Type.Aliased _ t -> edges t
137 Type.Aliased _ t -> edges t
138
138
139−addTypeAliases :: String -> [Node] -> Environment -> Either [Doc] Environment
139+addTypeAliases :: String -> [Node] -> Environment -> Canonicalizer [Doc] Environment
140addTypeAliases moduleName nodes environ =
140addTypeAliases moduleName nodes environ =
141 foldM addTypeAlias environ (Graph.stronglyConnComp nodes)
141 foldM addTypeAlias environ (Graph.stronglyConnComp nodes)
142 where
142 where
143 addTypeAlias :: Environment -> Graph.SCC (String, [String], Type.RawType)
143 addTypeAlias :: Environment -> Graph.SCC (String, [String], Type.RawType)
144− -> Either [Doc] Environment
144+ -> Canonicalizer [Doc] Environment
145 addTypeAlias env scc =
145 addTypeAlias env scc =
146 case Graph.flattenSCC scc of
146 case Graph.flattenSCC scc of
147 [(name, tvars, alias)] ->
147 [(name, tvars, alias)] ->
148− do alias' <- Either.either throw return (Canonicalize.tipe env alias)
148+ do alias' <- Env.onError throw (Canonicalize.tipe env alias)
149 let value = (Var.Canonical (Var.Module moduleName) name, tvars, alias')
149 let value = (Var.Canonical (Var.Module moduleName) name, tvars, alias')
150 return $ env { _aliases = insert name value (_aliases env) }
150 return $ env { _aliases = insert name value (_aliases env) }
151 where
151 where
152 throw err =
152 throw err =
153 let msg = "Problem with type alias '" ++ name ++ "':"
153 let msg = "Problem with type alias '" ++ name ++ "':"
154− in Left [ P.vcat [ P.text msg, P.text err ] ]
154+ in P.vcat [ P.text msg, P.text err ]
155
155
156 aliases ->
156 aliases ->
157− Left [ P.vcat [ P.text (eightyCharLines 0 msg1)
157+ throwError [ P.vcat [ P.text (eightyCharLines 0 msg1)
158− , indented (map typeAlias aliases)
158+ , indented (map typeAlias aliases)
159− , P.text (eightyCharLines 0 msg2)
159+ , P.text (eightyCharLines 0 msg2)
160− , indented (map datatype aliases)
160+ , indented (map datatype aliases)
161− , P.text (eightyCharLines 0 msg3)
161+ , P.text (eightyCharLines 0 msg3)
162− ]
162+ ]
163− ]
163+ ]
164
164
165 typeAlias (n,ts,t) = D.TypeAlias n ts t
165 typeAlias (n,ts,t) = D.TypeAlias n ts t
166 datatype (n,ts,t) = D.Datatype n ts [(n,[t])]
166 datatype (n,ts,t) = D.Datatype n ts [(n,[t])]
compiler/Transform/Canonicalize/Type.hs+5−5
@@ -3,7 +3,7 @@ module Transform.Canonicalize.Type (tipe) where
3
3
4import Control.Arrow (second)
4import Control.Arrow (second)
5import Control.Applicative ((<$>),(<*>))
5import Control.Applicative ((<$>),(<*>))
6−import Control.Monad (when)
6+import Control.Monad.Error
7import qualified Data.Map as Map
7import qualified Data.Map as Map
8import Data.Traversable (traverse)
8import Data.Traversable (traverse)
9
9
@@ -13,7 +13,7 @@ import qualified AST.Variable as Var
13import Transform.Canonicalize.Environment
13import Transform.Canonicalize.Environment
14import qualified Transform.Canonicalize.Variable as Canonicalize
14import qualified Transform.Canonicalize.Variable as Canonicalize
15
15
16−tipe :: Environment -> T.RawType -> Either String T.CanonicalType
16+tipe :: Environment -> T.RawType -> Canonicalizer String T.CanonicalType
17tipe env typ =
17tipe env typ =
18 let go = tipe env in
18 let go = tipe env in
19 case typ of
19 case typ of
@@ -29,7 +29,7 @@ tipe env typ =
29 in T.Record <$> mapM go' fields <*> traverse go ext
29 in T.Record <$> mapM go' fields <*> traverse go ext
30
30
31canonicalizeApp :: Environment -> T.RawType -> [T.RawType]
31canonicalizeApp :: Environment -> T.RawType -> [T.RawType]
32− -> Either String T.CanonicalType
32+ -> Canonicalizer String T.CanonicalType
33canonicalizeApp env f args =
33canonicalizeApp env f args =
34 case f of
34 case f of
35 T.Type (Var.Raw rawName) ->
35 T.Type (Var.Raw rawName) ->
@@ -44,9 +44,9 @@ canonicalizeApp env f args =
44
44
45canonicalizeAlias :: Environment -> (Var.Canonical, [String], T.CanonicalType)
45canonicalizeAlias :: Environment -> (Var.Canonical, [String], T.CanonicalType)
46 -> [T.RawType]
46 -> [T.RawType]
47− -> Either String T.CanonicalType
47+ -> Canonicalizer String T.CanonicalType
48canonicalizeAlias env (name, tvars, dealiasedTipe) tipes =
48canonicalizeAlias env (name, tvars, dealiasedTipe) tipes =
49− do when (tipesLen /= tvarsLen) (Left msg)
49+ do when (tipesLen /= tvarsLen) (throwError msg)
50 tipes' <- mapM (tipe env) tipes
50 tipes' <- mapM (tipe env) tipes
51 let tipe' = replace (Map.fromList (zip tvars tipes')) dealiasedTipe
51 let tipe' = replace (Map.fromList (zip tvars tipes')) dealiasedTipe
52 return $ T.Aliased name tipe'
52 return $ T.Aliased name tipe'
compiler/Transform/Canonicalize/Variable.hs+15−14
@@ -1,6 +1,7 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Transform.Canonicalize.Variable where
2module Transform.Canonicalize.Variable where
3
3
4+import Control.Monad.Error
4import qualified Data.List as List
5import qualified Data.List as List
5import qualified Data.Map as Map
6import qualified Data.Map as Map
6import Data.Maybe (fromMaybe)
7import Data.Maybe (fromMaybe)
@@ -8,19 +9,19 @@ import Data.Maybe (fromMaybe)
8import AST.Helpers as Help
9import AST.Helpers as Help
9import qualified AST.Type as Type
10import qualified AST.Type as Type
10import qualified AST.Variable as Var
11import qualified AST.Variable as Var
11−import Transform.Canonicalize.Environment
12+import Transform.Canonicalize.Environment as Env
12
13
13−variable :: Environment -> String -> Either String Var.Canonical
14+variable :: Environment -> String -> Canonicalizer String Var.Canonical
14variable env var =
15variable env var =
15 case modul of
16 case modul of
16 Just ms@(m:_)
17 Just ms@(m:_)
17− | m == "Native" -> return (Var.Canonical home name)
18+ | m == "Native" -> Env.using (Var.Canonical home name)
18 where
19 where
19 home = Var.Module (List.intercalate "." ms)
20 home = Var.Module (List.intercalate "." ms)
20
21
21 _ -> case Map.lookup var (_values env) of
22 _ -> case Map.lookup var (_values env) of
22− Just [v] -> return v
23+ Just [v] -> Env.using v
23− Just vs -> preferLocals "variable" vs var
24+ Just vs -> Env.using =<< preferLocals "variable" vs var
24 Nothing -> notFound "variable" (Map.keys (_values env)) var
25 Nothing -> notFound "variable" (Map.keys (_values env)) var
25 where
26 where
26 (modul, name) = case Help.splitDots var of
27 (modul, name) = case Help.splitDots var of
@@ -28,7 +29,7 @@ variable env var =
28 xs -> (Just (init xs), last xs)
29 xs -> (Just (init xs), last xs)
29
30
30tvar :: Environment -> String
31tvar :: Environment -> String
31− -> Either String (Either Var.Canonical (Var.Canonical, [String], Type.CanonicalType))
32+ -> Canonicalizer String (Either Var.Canonical (Var.Canonical, [String], Type.CanonicalType))
32tvar env var =
33tvar env var =
33 case adts ++ aliases of
34 case adts ++ aliases of
34 [] -> notFound "type" (Map.keys (_adts env) ++ Map.keys (_aliases env)) var
35 [] -> notFound "type" (Map.keys (_adts env) ++ Map.keys (_aliases env)) var
@@ -43,25 +44,25 @@ tvar env var =
43 Left v -> v
44 Left v -> v
44 Right (v,_,_) -> v
45 Right (v,_,_) -> v
45
46
46−pvar :: Environment -> String -> Either String Var.Canonical
47+pvar :: Environment -> String -> Canonicalizer String Var.Canonical
47pvar env var =
48pvar env var =
48 case Map.lookup var (_patterns env) of
49 case Map.lookup var (_patterns env) of
49− Just [v] -> return v
50+ Just [v] -> Env.using v
50− Just vs -> preferLocals "pattern" vs var
51+ Just vs -> Env.using =<< preferLocals "pattern" vs var
51 Nothing -> notFound "pattern" (Map.keys (_patterns env)) var
52 Nothing -> notFound "pattern" (Map.keys (_patterns env)) var
52
53
53−notFound :: String -> [String] -> String -> Either String a
54+notFound :: String -> [String] -> String -> Canonicalizer String a
54notFound kind possibilities var =
55notFound kind possibilities var =
55− Left $ "Could not find " ++ kind ++ " '" ++ var ++ "'." ++ msg
56+ throwError $ "Could not find " ++ kind ++ " '" ++ var ++ "'." ++ msg
56 where
57 where
57 matches = filter (List.isInfixOf var) possibilities
58 matches = filter (List.isInfixOf var) possibilities
58 msg = if null matches then "" else
59 msg = if null matches then "" else
59 "\nClose matches include: " ++ List.intercalate ", " matches
60 "\nClose matches include: " ++ List.intercalate ", " matches
60
61
61−preferLocals :: String -> [Var.Canonical] -> String -> Either String Var.Canonical
62+preferLocals :: String -> [Var.Canonical] -> String -> Canonicalizer String Var.Canonical
62preferLocals = preferLocals' id
63preferLocals = preferLocals' id
63
64
64−preferLocals' :: (a -> Var.Canonical) -> String -> [a] -> String -> Either String a
65+preferLocals' :: (a -> Var.Canonical) -> String -> [a] -> String -> Canonicalizer String a
65preferLocals' extract kind possibilities var =
66preferLocals' extract kind possibilities var =
66 case filter (isLocal . extract) possibilities of
67 case filter (isLocal . extract) possibilities of
67 [] -> ambiguous possibilities
68 [] -> ambiguous possibilities
@@ -73,7 +74,7 @@ preferLocals' extract kind possibilities var =
73 isLocal (Var.Canonical _ _) = False
74 isLocal (Var.Canonical _ _) = False
74
75
75 ambiguous possibleVars =
76 ambiguous possibleVars =
76− Left msg
77+ throwError msg
77 where
78 where
78 vars = map (Var.toString . extract) possibleVars
79 vars = map (Var.toString . extract) possibleVars
79 msg = "Ambiguous usage of " ++ kind ++ " '" ++ var ++ "'.\n" ++
80 msg = "Ambiguous usage of " ++ kind ++ " '" ++ var ++ "'.\n" ++
compiler/Type/Environment.hs−4
@@ -4,7 +4,6 @@ module Type.Environment where
4import Control.Applicative ((<$>), (<*>))
4import Control.Applicative ((<$>), (<*>))
5import Control.Exception (try, SomeException)
5import Control.Exception (try, SomeException)
6import Control.Monad
6import Control.Monad
7−import Control.Monad.Trans.Error (ErrorList(..))
8import Control.Monad.Error (ErrorT, throwError, liftIO)
7import Control.Monad.Error (ErrorT, throwError, liftIO)
9import qualified Control.Monad.State as State
8import qualified Control.Monad.State as State
10import qualified Data.Traversable as Traverse
9import qualified Data.Traversable as Traverse
@@ -115,9 +114,6 @@ get env subDict key = Map.findWithDefault (error msg) key (subDict env)
115freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
114freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
116freshDataScheme env name = get env constructor name
115freshDataScheme env name = get env constructor name
117
116
118−instance ErrorList PP.Doc where
119− listMsg str = [PP.text str]
120−
121instantiateType :: Environment -> T.CanonicalType -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)
117instantiateType :: Environment -> T.CanonicalType -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)
122instantiateType env sourceType dict =
118instantiateType env sourceType dict =
123 do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)
119 do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)