6f1d52f · rowtype-yoga/purescript-native

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

on golang help sign in

Add rename pass to desugar

6f1d52fGary Burgess13 years ago

prelude/prelude.purs+19−17

compare with golang

unifiedsplit

@@ -42,7 +42,7 @@ module Prelude where

42 \ return n.toString();\

43 \}" :: Number -> String

45− instance Prelude.Show Number where

45+ instance Show Number where

46 show = showNumber

48 class Read a where

@@ -439,22 +439,22 @@ module Data.Maybe where

439 maybe _ f (Just a) = f a

440

441 fromMaybe :: forall a. a -> Maybe a -> a

442− fromMaybe a = maybe a (Prelude.id :: forall a. a -> a)

442+ fromMaybe a = maybe a (id :: forall a. a -> a)

443

444− instance Prelude.Monad Maybe where

444+ instance Monad Maybe where

445 return = Just

446 (>>=) m f = maybe Nothing f m

447

448− instance Prelude.Applicative Maybe where

448+ instance Applicative Maybe where

449 pure = Just

450 (<*>) (Just fn) x = fn <$> x

451 (<*>) Nothing _ = Nothing

452

453− instance Prelude.Functor Maybe where

453+ instance Functor Maybe where

454 (<$>) fn (Just x) = Just (fn x)

455 (<$>) _ _ = Nothing

456

457− instance (Show a) => Prelude.Show (Maybe a) where

457+ instance (Show a) => Show (Maybe a) where

458 show (Just x) = "Just " ++ (show x)

459 show Nothing = "Nothing"

460

@@ -468,20 +468,20 @@ module Data.Either where

468 either f _ (Left a) = f a

469 either _ g (Right b) = g b

470

471− instance Prelude.Monad (Either e) where

471+ instance Monad (Either e) where

472 return = Right

473 (>>=) = either (\e _ -> Left e) (\a f -> f a)

474

475− instance Prelude.Applicative (Either e) where

475+ instance Applicative (Either e) where

476 pure = Right

477 (<*>) (Left e) _ = Left e

478 (<*>) (Right f) r = f <$> r

479

480− instance Prelude.Functor (Either a) where

480+ instance Functor (Either a) where

481 (<$>) _ (Left x) = Left x

482 (<$>) f (Right y) = Right (f y)

483

484− instance (Show a, Show b) => Prelude.Show (Either a b) where

484+ instance (Show a, Show b) => Show (Either a b) where

485 show (Left x) = "Left " ++ (show x)

486 show (Right y) = "Right " ++ (show y)

487

@@ -651,17 +651,17 @@ module Data.Array where

651 all _ [] = true

652 all p (a:as) = p a && all p as

653

654− instance (Prelude.Show a) => Prelude.Show [a] where

654+ instance (Show a) => Show [a] where

655 show xs = "[" ++ joinWith (map show xs) "," ++ "]"

656

657− instance Prelude.Functor [] where

657+ instance Functor [] where

658 (<$>) = map

659

660− instance Prelude.Monad [] where

660+ instance Monad [] where

661 return = singleton

662 (>>=) = concatMap

663

664− instance Prelude.Alternative [] where

664+ instance Alternative [] where

665 empty = []

666 (<|>) = concat

667

@@ -680,7 +680,7 @@ module Data.Tuple where

680

681 data Tuple a b = Tuple a b

682

683− instance (Prelude.Show a, Prelude.Show b) => Prelude.Show (Tuple a b) where

683+ instance (Show a, Show b) => Show (Tuple a b) where

684 show (Tuple a b) = "Tuple(" ++ show a ++ ", " ++ show b ++ ")"

685

686 curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c

@@ -934,6 +934,8 @@ module Math where

934

935module Control.Monad.Eff where

936

937+ import Prelude

938+

937 foreign import data Eff :: # ! -> * -> *

939 foreign import data Eff :: # ! -> * -> *

938

940

939 foreign import retEff "function retEff(a) {\

941 foreign import retEff "function retEff(a) {\

@@ -956,7 +958,7 @@ module Control.Monad.Eff where

956 \ return f();\

958 \ return f();\

957 \}" :: forall a. Pure a -> a

959 \}" :: forall a. Pure a -> a

958

960

959− instance Prelude.Monad (Eff e) where

961+ instance Monad (Eff e) where

960 return = retEff

962 return = retEff

961 (>>=) = bindEff

963 (>>=) = bindEff

962

964

@@ -1091,7 +1093,7 @@ module Debug.Trace where

1091 \ };\

1093 \ };\

1092 \}" :: forall r. String -> Eff (trace :: Trace | r) {}

1094 \}" :: forall r. String -> Eff (trace :: Trace | r) {}

1093

1095

1094− print :: forall a r. (Prelude.Show a) => a -> Eff (trace :: Trace | r) {}

1096+ print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) {}

1095 print o = trace (show o)

1097 print o = trace (show o)

1096

1098

1097module Control.Monad.ST where

1099module Control.Monad.ST where

purescript.cabal+1

@@ -43,6 +43,7 @@ library

43 Language.PureScript.Sugar.Operators

44 Language.PureScript.Sugar.TypeClasses

45 Language.PureScript.Sugar.Let

46+ Language.PureScript.Sugar.Names

46 Language.PureScript.CodeGen

47 Language.PureScript.CodeGen

47 Language.PureScript.CodeGen.Common

48 Language.PureScript.CodeGen.Common

48 Language.PureScript.CodeGen.Externs

49 Language.PureScript.CodeGen.Externs

src/Language/PureScript/Sugar.hs+3−1

@@ -27,6 +27,7 @@ import Language.PureScript.Sugar.TypeDeclarations as S

27import Language.PureScript.Sugar.BindingGroups as S

28import Language.PureScript.Sugar.TypeClasses as S

29import Language.PureScript.Sugar.Let as S

30+import Language.PureScript.Sugar.Names as S

31-- |

32-- |

32-- The desugaring pipeline proceeds as follows:

33-- The desugaring pipeline proceeds as follows:

@@ -46,7 +47,8 @@ import Language.PureScript.Sugar.Let as S

46-- * Group mutually recursive value and data declarations into binding groups.

47-- * Group mutually recursive value and data declarations into binding groups.

47--

48--

48desugar :: [Module] -> Either String [Module]

49desugar :: [Module] -> Either String [Module]

50+desugar = rename

49−desugar = desugarTypeClasses

51+ >=> desugarTypeClasses

50 >=> rebracket

52 >=> rebracket

51 >=> desugarDo

53 >=> desugarDo

52 >=> desugarLetBindings

54 >=> desugarLetBindings

src/Language/PureScript/Sugar/Names.hsnew file+80

@@ -0,0 +1,80 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Sugar.Names

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.Sugar.Names (

16+ rename

17+) where

18+

19+import Control.Applicative ((<$>))

20+import Control.Arrow (first)

21+import Data.Maybe (fromJust)

22+import Data.Generics (mkM, everywhereM)

23+import qualified Data.Map as M

24+import qualified Data.Set as S

25+import Data.Generics.Extras

26+import Language.PureScript.Declarations

27+import Language.PureScript.Names

28+import Language.PureScript.Types

29+import Language.PureScript.Pretty.Types

30+import Debug.Trace

31+

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)

34+

35+nullEnv = ExportEnvironment M.empty

36+

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

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

39+

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

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

42+

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

44+renameInModule exports m@(Module mn decls) = Module mn <$> everywhereM (mkM updateDecl) decls >>= everywhereM (mkM updateType)

45+ where

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

47+ cn' <- updateClassName cn

48+ cs' <- updateConstraints cs

49+ return $ TypeInstanceDeclaration cs' cn' ts ds

50+ updateDecl d = return d

51+ updateType (ConstrainedType cs t) = do

52+ cs' <- updateConstraints cs

53+ return $ ConstrainedType cs' t

54+ updateType t = return t

55+ updateConstraints = mapM updateConstraint

56+ updateConstraint (nm, ts) = do

57+ nm' <- updateClassName nm

58+ 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

62+ imports = resolveImports exports m

63+

64+findExports :: [Module] -> ExportEnvironment

65+findExports = foldl addModule nullEnv

66+ where

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

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

69+ addDecl _ env _ = env

70+

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

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

73+

74+resolveImports :: ExportEnvironment -> Module -> ImportEnvironment

75+resolveImports env (Module mn decls) = ImportEnvironment $ resolve (mn : findImports decls) (exportedTypeClasses env)

76+ where

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

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

79+ resolveDefs imns result mn ids = result

80+ resolveDef mn result id = M.insert id (Qualified (Just mn) id) result