git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Use Either instead of error
8d4eb2bGary Burgess
src/Language/PureScript/Sugar/Names.hs+29−22
compare with golang
unifiedsplit
@@ -25,7 +25,6 @@ import Language.PureScript.Declarations
25import Language.PureScript.Names
25import Language.PureScript.Names
26import Language.PureScript.Types
26import Language.PureScript.Types
27import Language.PureScript.Values
27import Language.PureScript.Values
28−import Debug.Trace
29
28
30data ExportEnvironment = ExportEnvironment
29data ExportEnvironment = ExportEnvironment
31 { exportedTypes :: M.Map ModuleName (S.Set ProperName)
30 { exportedTypes :: M.Map ModuleName (S.Set ProperName)
@@ -41,28 +40,34 @@ data ImportEnvironment = ImportEnvironment
41
40
42nullEnv = ExportEnvironment M.empty M.empty M.empty
41nullEnv = ExportEnvironment M.empty M.empty M.empty
43
42
44−addType :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironment
43+addType :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
45−addType env mn id = env { exportedTypes = M.insertWith addExport mn (S.singleton id) (exportedTypes env) }
44+addType env mn name = do
45+ types <- addExport (exportedTypes env) mn name
46+ return $ env { exportedTypes = types }
46
47
47−addDataConstructor :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironment
48+addDataConstructor :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
48−addDataConstructor env mn id = env { exportedDataConstructors = M.insertWith addExport mn (S.singleton id) (exportedDataConstructors env) }
49+addDataConstructor env mn name = do
50+ dataConstructors <- addExport (exportedDataConstructors env) mn name
51+ return $ env { exportedDataConstructors = dataConstructors }
49
52
50−addTypeclass :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironment
53+addTypeclass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
51−addTypeclass env mn id = env { exportedTypeClasses = M.insertWith addExport mn (S.singleton id) (exportedTypeClasses env) }
54+addTypeclass env mn name = do
55+ classes <- addExport (exportedTypeClasses env) mn name
56+ return $ env { exportedTypeClasses = classes }
52
57
53−-- TODO: do this properly with Either
54−addExport :: (Ord s, Show s) => S.Set s -> S.Set s -> S.Set s
58+addExport :: (Ord s, Show s) => M.Map ModuleName (S.Set s) -> ModuleName -> s -> Either String (M.Map ModuleName (S.Set s))
55−addExport new old =
59+addExport exports mn name = case M.lookup mn exports of
56− if null overlap
60+ Just s -> if S.member name s
57− then new `S.union` old
61+ then Left $ "Module '" ++ show mn ++ "' has multiple definitions for '" ++ (show name) ++ "'"
58− else error $ show (head overlap) ++ " has already been defined"
62+ else Right $ M.insert mn (S.insert name s) exports
59− where overlap = S.toList $ S.intersection new old
63+ Nothing -> Right $ M.insert mn (S.singleton name) exports
60
64
61rename :: [Module] -> Either String [Module]
65rename :: [Module] -> Either String [Module]
66+rename modules = do
67+ exports <- findExports modules
62−rename modules = mapM renameInModule' modules
68+ mapM (renameInModule' exports) modules
63 where
69 where
64− exports = findExports modules
65− renameInModule' m = do
70+ renameInModule' exports m = do
66 imports <- resolveImports exports m
71 imports <- resolveImports exports m
67 renameInModule imports m
72 renameInModule imports m
68
73
@@ -96,15 +101,17 @@ renameInModule imports (Module mn decls) =
96 updateDataConstructorName = update "data constructor" importedDataConstructors
101 updateDataConstructorName = update "data constructor" importedDataConstructors
97 update t get nm = maybe (Left $ "Unknown " ++ t ++ " '" ++ show nm ++ "' in module '" ++ show mn ++ "'") return $ M.lookup nm (get imports)
102 update t get nm = maybe (Left $ "Unknown " ++ t ++ " '" ++ show nm ++ "' in module '" ++ show mn ++ "'") return $ M.lookup nm (get imports)
98
103
99−findExports :: [Module] -> ExportEnvironment
104+findExports :: [Module] -> Either String ExportEnvironment
100−findExports = foldl addModule nullEnv
105+findExports = foldM addModule nullEnv
101 where
106 where
102− addModule env (Module mn ds) = foldl (addDecl mn) env ds
107+ addModule env (Module mn ds) = foldM (addDecl mn) env ds
103 addDecl mn env (TypeClassDeclaration tcn _ _) = addTypeclass env mn tcn
108 addDecl mn env (TypeClassDeclaration tcn _ _) = addTypeclass env mn tcn
104− addDecl mn env (DataDeclaration tn _ dcs) = addType (foldl (`addDataConstructor` mn) env (map fst dcs)) mn tn
109+ addDecl mn env (DataDeclaration tn _ dcs) = do
110+ env' <- foldM (`addDataConstructor` mn) env (map fst dcs)
111+ addType env' mn tn
105 addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn
112 addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn
106 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn
113 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn
107− addDecl _ env _ = env
114+ addDecl _ env _ = return env
108
115
109findImports :: [Declaration] -> [ModuleName]
116findImports :: [Declaration] -> [ModuleName]
110findImports decls = [ mn | (ImportDeclaration mn Nothing) <- decls ]
117findImports decls = [ mn | (ImportDeclaration mn Nothing) <- decls ]