5025203 · rowtype-yoga/purescript-native

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

Remove syb from code gen / fresh name generation

commit502520303210f8123abfc603e2494118948e629e authorPhil Freeman <paf31@cantab.net> dateTue 15 Apr 2014, 15:21 (13 years ago) parent6dc0441

6 files changed+131−36

compare with golang

unifiedsplit

src/Language/PureScript/CodeGen/JS.hs+22−3 src/Language/PureScript/Declarations.hs+52 src/Language/PureScript/Scope.hs+49−27 src/Language/PureScript/Sugar/BindingGroups.hs+2−3 src/Language/PureScript/Sugar/CaseDeclarations.hs+4−2 src/Language/PureScript/Sugar/DoNotation.hs+2−1

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

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

3434import qualified Data.Map as M

3535

3636import Language.PureScript.Names

37−import Language.PureScript.Scope

3837import Language.PureScript.Declarations

3938import Language.PureScript.CodeGen.Monad

4039import Language.PureScript.Options

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

4443import Language.PureScript.CodeGen.Common

4544import Language.PureScript.Environment

4645

46+import qualified Language.PureScript.Scope as S

47+

4748-- |

4849-- Different types of modules which are supported

4950--

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

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

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

169170 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

171173 jsKey = JSVar key

172174 jsNewObj = JSVar newObj

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

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

247249-- and guards.

248250--

249251bindersToJs :: 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

251253 valNames <- replicateM (length vals) fresh

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

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

254256 vals

255257 where

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

259+

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

257261 go _ done [] Nothing = return done

258262 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,

261265 binderToJs m e v done'' b

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

263267

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+

264282-- |

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

266284-- binder.

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

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

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

344362 typeConstructor _ = error "Invalid argument to isOnlyConstructor"

363+

src/Language/PureScript/Declarations.hs+52

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

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

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

512512 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 @@

1414-----------------------------------------------------------------------------

1515

1616module Language.PureScript.Scope (

17− usedNames,

17+ usedNamesDecl,

18+ usedNamesValue,

19+ usedNamesBinder,

20+ usedNamesCaseAlternative,

21+ usedNamesDoNotationElement,

1822 unusedNames

1923) where

2024

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

22−

23−import Data.Data

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

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

2626

2727import Language.PureScript.Declarations

2828import 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

3051

3152-- |

3253-- Gather all used names appearing inside a value

3354--

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

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

36− where

37− namesV :: Value -> [Ident]

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

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

40− namesV _ = []

41− namesB :: Binder -> [Ident]

42− namesB (VarBinder name) = [name]

43− namesB _ = []

44− namesJS :: JS -> [Ident]

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

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

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

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

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

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

51− namesJS _ = []

55+usedNamesValue :: Value -> [Ident]

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

57+

58+-- |

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

60+--

61+usedNamesBinder :: Binder -> [Ident]

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

63+

64+-- |

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

66+--

67+usedNamesCaseAlternative :: CaseAlternative -> [Ident]

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

69+

70+-- |

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

72+--

73+usedNamesDoNotationElement :: DoNotationElement -> [Ident]

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

5275

5376-- |

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

5578--

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

57−unusedNames val =

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

80+unusedNames allNames =

5881 let

59− allNames = usedNames val

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

6183 in

6284 varNames \\ allNames

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

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

2121 collapseBindingGroupsModule

2222) where

2323

24−import Data.Data

2524import Data.Graph

2625import Data.Generics

2726import Data.Generics.Extras

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

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

9190collapseBindingGroupsForValue other = other

9291

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

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

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

9594 where

9695 usedNames :: Value -> [Ident]

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

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

9998 usedNames _ = []

10099

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

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

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

103102 where

104103 usedNames :: Type -> [ProperName]

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

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

4949

5050 replace (Abs (Right binder) val) =

5151 let

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

52+ used = usedNamesBinder binder ++ usedNamesValue val

53+ ident = head $ unusedNames used

5354 in

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

5556 replace other = other

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

108109makeCaseDeclaration ident alternatives =

109110 let

110111 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

112114 vars = map (Var . Qualified Nothing) args

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

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

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

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

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

5858 go (DoNotationBind binder val : rest) = do

5959 rest' <- go rest

60− let ident = head $ unusedNames rest'

60+ let used = concatMap usedNamesDoNotationElement rest

61+ ident = head $ unusedNames used

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

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

6364 go (DoNotationLet ds : rest) = do