@@ -17,63 +17,84 @@ module Language.PureScript.Sugar.Names (
1717) where
1818
1919import Control.Applicative ((<$>))
20−import Control.Arrow (first)
21−import Data.Maybe (fromJust)
22−import Data.Generics (mkM, everywhereM)
20+import Data.Generics (extM, mkM, everywhereM)
2321import qualified Data.Map as M
2422import qualified Data.Set as S
25−import Data.Generics.Extras
2623import Language.PureScript.Declarations
2724import Language.PureScript.Names
2825import Language.PureScript.Types
29−import Language.PureScript.Pretty.Types
26+import Language.PureScript.Values
3027import Debug.Trace
3128
32−data ExportEnvironment = ExportEnvironment { exportedTypeClasses :: M.Map ModuleName (S.Set ProperName) } deriving (Show)
33−data ImportEnvironment = ImportEnvironment { importedTypeClasses :: M.Map ProperName (Qualified ProperName) } deriving (Show)
29+data ExportEnvironment = ExportEnvironment
30+ { exportedDataConstructors :: M.Map ModuleName (S.Set ProperName)
31+ , exportedTypeClasses :: M.Map ModuleName (S.Set ProperName)
32+ } deriving (Show)
33+
34+data ImportEnvironment = ImportEnvironment
35+ { importedDataConstructors :: M.Map ProperName (Qualified ProperName)
36+ , importedTypeClasses :: M.Map ProperName (Qualified ProperName)
37+ } deriving (Show)
3438
35−nullEnv = ExportEnvironment M.empty
39+nullEnv = ExportEnvironment M.empty M.empty
40+
41+addDataConstructor :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironment
42+addDataConstructor env mn id = env { exportedDataConstructors = M.insertWith S.union mn (S.singleton id) (exportedDataConstructors env) }
3643
3744addTypeclass :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironment
3845addTypeclass env mn id = env { exportedTypeClasses = M.insertWith S.union mn (S.singleton id) (exportedTypeClasses env) }
3946
4047rename :: [Module] -> Either String [Module]
41−rename modules = mapM (renameInModule $ findExports modules) modules
48+rename modules = trace (show $ findExports modules) $ mapM (renameInModule $ findExports modules) modules
4249
4350renameInModule :: ExportEnvironment -> Module -> Either String Module
44−renameInModule exports m@(Module mn decls) = Module mn <$> everywhereM (mkM updateDecl) decls >>= everywhereM (mkM updateType)
51+renameInModule exports m@(Module mn decls) = Module mn <$> mapM updateDecl decls >>= everywhereM (mkM updateType) >>= everywhereM (mkM updateValue) >>= everywhereM (mkM updateBinder)
4552 where
46− updateDecl (TypeInstanceDeclaration cs cn ts ds) = do
53+ updateDecl (TypeInstanceDeclaration cs (Qualified Nothing cn) ts ds) = do
4754 cn' <- updateClassName cn
4855 cs' <- updateConstraints cs
4956 return $ TypeInstanceDeclaration cs' cn' ts ds
5057 updateDecl d = return d
58+ updateValue (Constructor (Qualified Nothing nm)) = do
59+ nm' <- updateDataConstructorName nm
60+ return $ Constructor nm'
61+ updateValue v = return v
62+ updateBinder (ConstructorBinder (Qualified Nothing nm) b) = do
63+ nm' <- updateDataConstructorName nm
64+ return $ ConstructorBinder nm' b
65+ updateBinder v = return v
5166 updateType (ConstrainedType cs t) = do
5267 cs' <- updateConstraints cs
5368 return $ ConstrainedType cs' t
5469 updateType t = return t
5570 updateConstraints = mapM updateConstraint
56− updateConstraint (nm, ts) = do
71+ updateConstraint (Qualified Nothing nm, ts) = do
5772 nm' <- updateClassName nm
5873 return (nm', ts)
59− updateClassName (Qualified Nothing nm) =
60− maybe (Left $ "Unknown typeclass '" ++ show nm ++ "'") Right $ M.lookup nm (importedTypeClasses imports)
61− updateClassName q = return q
74+ updateConstraint other = return other
75+ updateClassName nm =
76+ maybe (err "typeclass" nm mn) return $ M.lookup nm (importedTypeClasses imports)
77+ updateDataConstructorName nm =
78+ maybe (err "data constructor" nm mn) return $ M.lookup nm (importedDataConstructors imports)
6279 imports = resolveImports exports m
80+ err t nm mn = Left $ "Unknown " ++ t ++ " '" ++ show nm ++ "' in module '" ++ show mn ++ "'"
6381
6482findExports :: [Module] -> ExportEnvironment
6583findExports = foldl addModule nullEnv
6684 where
6785 addModule env (Module mn ds) = foldl (addDecl mn) env ds
6886 addDecl mn env (TypeClassDeclaration tcn _ _) = addTypeclass env mn tcn
87+ addDecl mn env (DataDeclaration tcn _ dcs) = foldl (flip addDataConstructor mn) env (map fst dcs)
6988 addDecl _ env _ = env
7089
7190findImports :: [Declaration] -> [ModuleName]
7291findImports decls = [ mn | (ImportDeclaration mn Nothing) <- decls ]
7392
7493resolveImports :: ExportEnvironment -> Module -> ImportEnvironment
75−resolveImports env (Module mn decls) = ImportEnvironment $ resolve (mn : findImports decls) (exportedTypeClasses env)
94+resolveImports env (Module mn decls) = ImportEnvironment (resolve scope $ exportedDataConstructors env)
95+ (resolve scope $ exportedTypeClasses env)
7696 where
97+ scope = (mn : findImports decls)
7798 resolve imns = M.foldlWithKey (resolveDefs imns) M.empty
7899 resolveDefs imns result mn ids | mn `elem` imns = S.foldl (resolveDef mn) result ids
79100 resolveDefs imns result mn ids = result