00c5303 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Rename data constructors

00c5303Gary Burgess13 years ago

src/Language/PureScript/CodeGen/JS.hs+1−2

compare with golang

unifiedsplit

@@ -43,7 +43,6 @@ import Language.PureScript.CodeGen.JS.AST as AST

43import Language.PureScript.Types

44import Language.PureScript.CodeGen.Optimize

45import Language.PureScript.CodeGen.Common

46−import Language.PureScript.TypeChecker.Monad (canonicalizeDataConstructor)

48-- |

47-- |

49-- Generate code in the simplified Javascript intermediate representation for all declarations in a

48-- Generate code in the simplified Javascript intermediate representation for all declarations in a

@@ -262,7 +261,7 @@ binderToJs m e varName done (ConstructorBinder ctor bs) = do

262 then

261 then

263 return js

262 return js

264 else

263 else

265− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ canonicalizeDataConstructor m e ctor))))

264+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ctor)))

266 (JSBlock js)

265 (JSBlock js)

267 Nothing]

266 Nothing]

268 where

267 where

src/Language/PureScript/DeadCodeElimination.hs+2−1

@@ -55,7 +55,8 @@ dependencies env moduleName = nub . everything (++) (mkQ [] values)

55 where

56 values :: Value -> [Key]

57 values (Var ident) = let (mn, name) = canonicalize moduleName env ident in [(mn, Left name)]

58− values (Constructor pn) = let (mn, name) = canonicalizeDataConstructor moduleName env pn in [(mn, Right name)]

58+ values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]

59+ values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"

59 values _ = []

60 values _ = []

61isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool

62isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool

src/Language/PureScript/Sugar/Names.hs+37−16

@@ -17,63 +17,84 @@ module Language.PureScript.Sugar.Names (

17) where

19import 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)

23import qualified Data.Map as M

21import qualified Data.Map as M

24import qualified Data.Set as S

22import qualified Data.Set as S

25−import Data.Generics.Extras

26import Language.PureScript.Declarations

23import Language.PureScript.Declarations

27import Language.PureScript.Names

24import Language.PureScript.Names

28import Language.PureScript.Types

25import Language.PureScript.Types

29−import Language.PureScript.Pretty.Types

26+import Language.PureScript.Values

30import Debug.Trace

27import Debug.Trace

29+data ExportEnvironment = ExportEnvironment

30+ { exportedDataConstructors :: M.Map ModuleName (S.Set ProperName)

32−data ExportEnvironment = ExportEnvironment { exportedTypeClasses :: M.Map ModuleName (S.Set ProperName) } deriving (Show)

31+ , exportedTypeClasses :: M.Map ModuleName (S.Set ProperName)

32+ } deriving (Show)

33+

34+data ImportEnvironment = ImportEnvironment

35+ { importedDataConstructors :: M.Map ProperName (Qualified ProperName)

33−data ImportEnvironment = ImportEnvironment { importedTypeClasses :: M.Map ProperName (Qualified ProperName) } deriving (Show)

36+ , importedTypeClasses :: M.Map ProperName (Qualified ProperName)

37+ } deriving (Show)

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) }

37addTypeclass :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironment

44addTypeclass :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironment

38addTypeclass env mn id = env { exportedTypeClasses = M.insertWith S.union mn (S.singleton id) (exportedTypeClasses env) }

45addTypeclass env mn id = env { exportedTypeClasses = M.insertWith S.union mn (S.singleton id) (exportedTypeClasses env) }

40rename :: [Module] -> Either String [Module]

47rename :: [Module] -> Either String [Module]

41−rename modules = mapM (renameInModule $ findExports modules) modules

48+rename modules = trace (show $ findExports modules) $ mapM (renameInModule $ findExports modules) modules

43renameInModule :: ExportEnvironment -> Module -> Either String Module

50renameInModule :: 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)

45 where

52 where

46− updateDecl (TypeInstanceDeclaration cs cn ts ds) = do

53+ updateDecl (TypeInstanceDeclaration cs (Qualified Nothing cn) ts ds) = do

47 cn' <- updateClassName cn

54 cn' <- updateClassName cn

48 cs' <- updateConstraints cs

55 cs' <- updateConstraints cs

49 return $ TypeInstanceDeclaration cs' cn' ts ds

56 return $ TypeInstanceDeclaration cs' cn' ts ds

50 updateDecl d = return d

57 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

51 updateType (ConstrainedType cs t) = do

66 updateType (ConstrainedType cs t) = do

52 cs' <- updateConstraints cs

67 cs' <- updateConstraints cs

53 return $ ConstrainedType cs' t

68 return $ ConstrainedType cs' t

54 updateType t = return t

69 updateType t = return t

55 updateConstraints = mapM updateConstraint

70 updateConstraints = mapM updateConstraint

56− updateConstraint (nm, ts) = do

71+ updateConstraint (Qualified Nothing nm, ts) = do

57 nm' <- updateClassName nm

72 nm' <- updateClassName nm

58 return (nm', ts)

73 return (nm', ts)

59− updateClassName (Qualified Nothing nm) =

74+ updateConstraint other = return other

75+ updateClassName nm =

60− maybe (Left $ "Unknown typeclass '" ++ show nm ++ "'") Right $ M.lookup nm (importedTypeClasses imports)

76+ maybe (err "typeclass" nm mn) return $ M.lookup nm (importedTypeClasses imports)

61− updateClassName q = return q

77+ updateDataConstructorName nm =

78+ maybe (err "data constructor" nm mn) return $ M.lookup nm (importedDataConstructors imports)

62 imports = resolveImports exports m

79 imports = resolveImports exports m

80+ err t nm mn = Left $ "Unknown " ++ t ++ " '" ++ show nm ++ "' in module '" ++ show mn ++ "'"

64findExports :: [Module] -> ExportEnvironment

82findExports :: [Module] -> ExportEnvironment

65findExports = foldl addModule nullEnv

83findExports = foldl addModule nullEnv

66 where

84 where

67 addModule env (Module mn ds) = foldl (addDecl mn) env ds

85 addModule env (Module mn ds) = foldl (addDecl mn) env ds

68 addDecl mn env (TypeClassDeclaration tcn _ _) = addTypeclass env mn tcn

86 addDecl mn env (TypeClassDeclaration tcn _ _) = addTypeclass env mn tcn

87+ addDecl mn env (DataDeclaration tcn _ dcs) = foldl (flip addDataConstructor mn) env (map fst dcs)

69 addDecl _ env _ = env

88 addDecl _ env _ = env

71findImports :: [Declaration] -> [ModuleName]

90findImports :: [Declaration] -> [ModuleName]

72findImports decls = [ mn | (ImportDeclaration mn Nothing) <- decls ]

91findImports decls = [ mn | (ImportDeclaration mn Nothing) <- decls ]

74resolveImports :: ExportEnvironment -> Module -> ImportEnvironment

93resolveImports :: 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)

76 where

96 where

97+ scope = (mn : findImports decls)

77 resolve imns = M.foldlWithKey (resolveDefs imns) M.empty

98 resolve imns = M.foldlWithKey (resolveDefs imns) M.empty

78 resolveDefs imns result mn ids | mn `elem` imns = S.foldl (resolveDef mn) result ids

99 resolveDefs imns result mn ids | mn `elem` imns = S.foldl (resolveDef mn) result ids

79 resolveDefs imns result mn ids = result

100 resolveDefs imns result mn ids = result

src/Language/PureScript/TypeChecker/Monad.hs−9

@@ -219,15 +219,6 @@ canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types

219 Just (_, DataAlias mn' pn') -> (mn', pn')

220 _ -> (mn, nm)

221

222−-- |

223−-- Canonicalize a data constructor by resolving any aliases introduced by module imports

224−--

225−canonicalizeDataConstructor :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)

226−canonicalizeDataConstructor _ _ (Qualified (Just mn) pn) = (mn, pn)

227−canonicalizeDataConstructor mn env (Qualified Nothing pn) = case (mn, pn) `M.lookup` dataConstructors env of

228− Just (_, Alias mn' (Ident pn')) -> (mn', ProperName pn')

229− _ -> (mn, pn)

230−

231-- |

222-- |

232-- State required for type checking:

223-- State required for type checking:

233--

224--