5025203 · rowtype-yoga/purescript-native

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

on golang help sign in

Remove syb from code gen / fresh name generation

5025203Phil Freeman13 years ago

src/Language/PureScript/CodeGen/JS.hs+22−3

compare with golang

unifiedsplit

@@ -34,7 +34,6 @@ import Control.Monad (replicateM, forM)

34import qualified Data.Map as M

36import Language.PureScript.Names

37−import Language.PureScript.Scope

38import Language.PureScript.Declarations

37import Language.PureScript.Declarations

39import Language.PureScript.CodeGen.Monad

38import Language.PureScript.CodeGen.Monad

40import Language.PureScript.Options

39import Language.PureScript.Options

@@ -44,6 +43,8 @@ import Language.PureScript.Optimizer

44import Language.PureScript.CodeGen.Common

43import Language.PureScript.CodeGen.Common

45import Language.PureScript.Environment

44import Language.PureScript.Environment

46+import qualified Language.PureScript.Scope as S

47+

47-- |

48-- |

48-- Different types of modules which are supported

49-- Different types of modules which are supported

49--

50--

@@ -167,7 +168,8 @@ valueToJs _ _ _ _ = error "Invalid argument to valueToJs"

167extendObj :: JS -> [(String, JS)] -> JS

168extendObj :: JS -> [(String, JS)] -> JS

168extendObj obj sts = JSApp (JSFunction Nothing [] block) []

169extendObj obj sts = JSApp (JSFunction Nothing [] block) []

169 where

170 where

170− [newObj, key] = take 2 . map identToJs . unusedNames $ (obj, sts)

171+ [newObj, key] = take 2 . map identToJs . S.unusedNames $ used

172+ used = usedNamesJS obj ++ concatMap (usedNamesJS . snd) sts

171 jsKey = JSVar key

173 jsKey = JSVar key

172 jsNewObj = JSVar newObj

174 jsNewObj = JSVar newObj

173 block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])

175 block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])

@@ -247,12 +249,14 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)

247-- and guards.

249-- and guards.

248--

250--

249bindersToJs :: Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> JS

251bindersToJs :: Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> JS

250−bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders, vals))) $ do

252+bindersToJs opts m e binders vals = runGen (map identToJs (S.unusedNames usedNames)) $ do

251 valNames <- replicateM (length vals) fresh

253 valNames <- replicateM (length vals) fresh

252 jss <- forM binders $ \(CaseAlternative bs grd result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (concatMap binderNames bs) e) result)] bs grd

254 jss <- forM binders $ \(CaseAlternative bs grd result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (concatMap binderNames bs) e) result)] bs grd

253 return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))

255 return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))

254 vals

256 vals

255 where

257 where

258+ usedNames = concatMap usedNamesJS vals ++ concatMap S.usedNamesCaseAlternative binders

259+

256 go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]

260 go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]

257 go _ done [] Nothing = return done

261 go _ done [] Nothing = return done

258 go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]

262 go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]

@@ -261,6 +265,20 @@ bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders,

261 binderToJs m e v done'' b

265 binderToJs m e v done'' b

262 go _ _ _ _ = error "Invalid arguments to bindersToJs"

266 go _ _ _ _ = error "Invalid arguments to bindersToJs"

263

267

268+-- |

269+-- Gather all used names appearing inside a value

270+--

271+usedNamesJS :: JS -> [Ident]

272+usedNamesJS val = nub $ everythingOnJS (++) namesJS val

273+ where

274+ namesJS (JSVar name) = [Ident name]

275+ namesJS (JSFunction (Just name) args _) = Ident name : map Ident args

276+ namesJS (JSFunction Nothing args _) = map Ident args

277+ namesJS (JSVariableIntroduction name _) = [Ident name]

278+ namesJS (JSFor name _ _ _) = [Ident name]

279+ namesJS (JSForIn name _ _) = [Ident name]

280+ namesJS _ = []

281+

264-- |

282-- |

265-- Generate code in the simplified Javascript intermediate representation for a pattern match

283-- Generate code in the simplified Javascript intermediate representation for a pattern match

266-- binder.

284-- binder.

@@ -342,3 +360,4 @@ isOnlyConstructor e ctor =

342 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e

360 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e

343 typeConstructor (Qualified (Just moduleName) _, (tyCtor, _)) = (moduleName, tyCtor)

361 typeConstructor (Qualified (Just moduleName) _, (tyCtor, _)) = (moduleName, tyCtor)

344 typeConstructor _ = error "Invalid argument to isOnlyConstructor"

362 typeConstructor _ = error "Invalid argument to isOnlyConstructor"

363+

src/Language/PureScript/Declarations.hs+52

@@ -510,3 +510,55 @@ everywhereOnValues f g h = (f', g', h')

510 handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v)

511 handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)

512 handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)

513+

514+everythingOnValues :: (r -> r -> r) ->

515+ (Declaration -> r) ->

516+ (Value -> r) ->

517+ (Binder -> r) ->

518+ (CaseAlternative -> r) ->

519+ (DoNotationElement -> r) ->

520+ (Declaration -> r, Value -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

521+everythingOnValues (<>) f g h i j = (f', g', h', i', j')

522+ where

523+ f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)

524+ f' d@(ValueDeclaration _ _ bs Nothing val) = foldl (<>) (f d) (map h' bs) <> g' val

525+ f' d@(ValueDeclaration _ _ bs (Just grd) val) = foldl (<>) (f d) (map h' bs) <> g' grd <> g' val

526+ f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)

527+ f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)

528+ f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)

529+ f' d@(PositionedDeclaration _ d1) = f d <> f' d1

530+ f' d = f d

531+

532+ g' v@(UnaryMinus v1) = g v <> g' v1

533+ g' v@(BinaryNoParens _ v1 v2) = g v <> g' v1 <> g' v2

534+ g' v@(Parens v1) = g v <> g' v1

535+ g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)

536+ g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)

537+ g' v@(Accessor _ v1) = g v <> g' v1

538+ g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

539+ g' v@(Abs _ v1) = g v <> g' v1

540+ g' v@(App v1 v2) = g v <> g' v1 <> g' v2

541+ g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3

542+ g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)

543+ g' v@(TypedValue _ v1 _) = g v <> g' v1

544+ g' v@(Let ds v1) = (foldl (<>) (g v) (map f' ds)) <> g' v1

545+ g' v@(Do es) = foldl (<>) (g v) (map j' es)

546+ g' v@(PositionedValue _ v1) = g v <> g' v1

547+ g' v = g v

548+

549+ h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)

550+ h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)

551+ h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)

552+ h' b@(ConsBinder b1 b2) = h b <> h' b1 <> h' b2

553+ h' b@(NamedBinder _ b1) = h b <> h' b1

554+ h' b@(PositionedBinder _ b1) = h b <> h' b1

555+ h' b = h b

556+

557+ i' ca = case caseAlternativeGuard ca of

558+ Nothing -> foldl (<>) (i ca) (map h' (caseAlternativeBinders ca)) <> g' (caseAlternativeResult ca)

559+ Just grd -> foldl (<>) (i ca) (map h' (caseAlternativeBinders ca)) <> g' grd <> g' (caseAlternativeResult ca)

560+

561+ j' e@(DoNotationValue v) = j e <> g' v

562+ j' e@(DoNotationBind b v) = j e <> h' b <> g' v

563+ j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)

564+ j' e@(PositionedDoNotationElement _ e1) = j e <> j' e1

src/Language/PureScript/Scope.hs+49−27

@@ -14,49 +14,71 @@

14-----------------------------------------------------------------------------

16module Language.PureScript.Scope (

17− usedNames,

17+ usedNamesDecl,

18+ usedNamesValue,

19+ usedNamesBinder,

20+ usedNamesCaseAlternative,

21+ usedNamesDoNotationElement,

18 unusedNames

22 unusedNames

19) where

23) where

21−import Control.Applicative ((<$>))

22−

23−import Data.Data

24import Data.List ((\\), nub)

25import Data.List ((\\), nub)

25−import Data.Generics (extQ, mkQ, everything)

27import Language.PureScript.Declarations

28import Language.PureScript.Names

29−import Language.PureScript.CodeGen.JS.AST

29+

30+usedNames :: (Declaration -> [Ident], Value -> [Ident], Binder -> [Ident], CaseAlternative -> [Ident], DoNotationElement -> [Ident])

31+usedNames = everythingOnValues (++) f g h (const []) (const [])

32+ where

33+ f :: Declaration -> [Ident]

34+ f (ValueDeclaration name _ _ _ _) = [name]

35+ f _ = []

36+

37+ g :: Value -> [Ident]

38+ g (Abs (Left arg) _) = [arg]

39+ g (Var (Qualified Nothing name)) = [name]

40+ g _ = []

41+

42+ h :: Binder -> [Ident]

43+ h (VarBinder name) = [name]

44+ h _ = []

45+

46+-- |

47+-- Gather all used names appearing inside a declaration

48+--

49+usedNamesDecl :: Declaration -> [Ident]

50+usedNamesDecl = let (f, _, _, _, _) = usedNames in nub . f

31-- |

52-- |

32-- Gather all used names appearing inside a value

53-- Gather all used names appearing inside a value

33--

54--

34−usedNames :: (Data d) => d -> [Ident]

35−usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesB `extQ` namesJS) val

36− where

37− namesV :: Value -> [Ident]

55+usedNamesValue :: Value -> [Ident]

38− namesV (Abs (Left arg) _) = [arg]

56+usedNamesValue = let (_, f, _, _, _) = usedNames in nub . f

39− namesV (Var (Qualified Nothing name)) = [name]

57+

40− namesV _ = []

58+-- |

59+-- Gather all used names appearing inside a binder

60+--

41− namesB :: Binder -> [Ident]

61+usedNamesBinder :: Binder -> [Ident]

42− namesB (VarBinder name) = [name]

62+usedNamesBinder = let (_, _, f, _, _) = usedNames in nub . f

43− namesB _ = []

63+

44− namesJS :: JS -> [Ident]

64+-- |

45− namesJS (JSVar name) = [Ident name]

65+-- Gather all used names appearing inside a case alternative

46− namesJS (JSFunction (Just name) args _) = Ident name : (Ident <$> args)

66+--

47− namesJS (JSFunction Nothing args _) = Ident <$> args

67+usedNamesCaseAlternative :: CaseAlternative -> [Ident]

48− namesJS (JSVariableIntroduction name _) = [Ident name]

68+usedNamesCaseAlternative = let (_, _, _, f, _) = usedNames in nub . f

49− namesJS (JSFor name _ _ _) = [Ident name]

69+

50− namesJS (JSForIn name _ _) = [Ident name]

70+-- |

51− namesJS _ = []

71+-- Gather all used names appearing inside a do notation element

72+--

73+usedNamesDoNotationElement :: DoNotationElement -> [Ident]

74+usedNamesDoNotationElement = let (_, _, _, _, f) = usedNames in nub . f

53-- |

76-- |

54-- Generate a set of names which are unused inside a value, of the form @_{n}@ for an integer @n@

77-- Generate a set of names which are unused inside a value, of the form @_{n}@ for an integer @n@

55--

78--

56−unusedNames :: (Data d) => d -> [Ident]

79+unusedNames :: [Ident] -> [Ident]

57−unusedNames val =

80+unusedNames allNames =

58 let

81 let

59− allNames = usedNames val

60 varNames = map (Ident . ('_' :) . show) ([1..] :: [Int])

82 varNames = map (Ident . ('_' :) . show) ([1..] :: [Int])

61 in

83 in

62 varNames \\ allNames

84 varNames \\ allNames

src/Language/PureScript/Sugar/BindingGroups.hs+2−3

@@ -21,7 +21,6 @@ module Language.PureScript.Sugar.BindingGroups (

21 collapseBindingGroupsModule

22) where

24−import Data.Data

25import Data.Graph

24import Data.Graph

26import Data.Generics

25import Data.Generics

27import Data.Generics.Extras

26import Data.Generics.Extras

@@ -90,7 +89,7 @@ collapseBindingGroupsForValue :: Value -> Value

90collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val

89collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val

91collapseBindingGroupsForValue other = other

90collapseBindingGroupsForValue other = other

93−usedIdents :: (Data d) => ModuleName -> d -> [Ident]

92+usedIdents :: ModuleName -> Declaration -> [Ident]

94usedIdents moduleName = nub . everything (++) (mkQ [] usedNames)

93usedIdents moduleName = nub . everything (++) (mkQ [] usedNames)

95 where

94 where

96 usedNames :: Value -> [Ident]

95 usedNames :: Value -> [Ident]

@@ -98,7 +97,7 @@ usedIdents moduleName = nub . everything (++) (mkQ [] usedNames)

98 usedNames (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]

97 usedNames (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]

99 usedNames _ = []

98 usedNames _ = []

100

101−usedProperNames :: (Data d) => ModuleName -> d -> [ProperName]

100+usedProperNames :: ModuleName -> Declaration -> [ProperName]

102usedProperNames moduleName = nub . everything (++) (mkQ [] usedNames)

101usedProperNames moduleName = nub . everything (++) (mkQ [] usedNames)

103 where

102 where

104 usedNames :: Type -> [ProperName]

103 usedNames :: Type -> [ProperName]

src/Language/PureScript/Sugar/CaseDeclarations.hs+4−2

@@ -49,7 +49,8 @@ desugarAbs = map f

50 replace (Abs (Right binder) val) =

51 let

52+ used = usedNamesBinder binder ++ usedNamesValue val

52− ident = head $ unusedNames (binder, val)

53+ ident = head $ unusedNames used

53 in

54 in

54 Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]

55 Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]

55 replace other = other

56 replace other = other

@@ -108,7 +109,8 @@ makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> Declaratio

108makeCaseDeclaration ident alternatives =

109makeCaseDeclaration ident alternatives =

109 let

110 let

110 argPattern = length . fst . head $ alternatives

111 argPattern = length . fst . head $ alternatives

111− args = take argPattern $ unusedNames (ident, alternatives)

112+ args = take argPattern $ unusedNames used

113+ used = concatMap (\(bs, (grd, val)) -> concatMap usedNamesBinder bs ++ maybe [] usedNamesValue grd ++ usedNamesValue val) alternatives

112 vars = map (Var . Qualified Nothing) args

114 vars = map (Var . Qualified Nothing) args

113 binders = [ CaseAlternative bs g val | (bs, (g, val)) <- alternatives ]

115 binders = [ CaseAlternative bs g val | (bs, (g, val)) <- alternatives ]

114 value = foldr (Abs . Left) (Case vars binders) args

116 value = foldr (Abs . Left) (Case vars binders) args

src/Language/PureScript/Sugar/DoNotation.hs+2−1

@@ -57,7 +57,8 @@ desugarDo = everywhereM (mkM replace)

57 return $ App (App bind val) (Abs (Left ident) rest')

58 go (DoNotationBind binder val : rest) = do

59 rest' <- go rest

60+ let used = concatMap usedNamesDoNotationElement rest

60− let ident = head $ unusedNames rest'

61+ ident = head $ unusedNames used

61 return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing rest']))

62 return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing rest']))

62 go [DoNotationLet _] = Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing

63 go [DoNotationLet _] = Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing

63 go (DoNotationLet ds : rest) = do

64 go (DoNotationLet ds : rest) = do