d3d9684 · rowtype-yoga/purescript-native

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

on golang help sign in

Optimise fully saturated constructors

d3d9684Gary Burgess12 years ago

src/Language/PureScript/CodeGen/JS.hs+39−13

compare with golang

unifiedsplit

@@ -207,7 +207,19 @@ valueToJs opts m e (Case values binders) = do

207 bindersToJs opts m e binders vals

208valueToJs opts m e (IfThenElse cond th el) = JSConditional <$> valueToJs opts m e cond <*> valueToJs opts m e th <*> valueToJs opts m e el

209valueToJs opts m e (Accessor prop val) = accessorString prop <$> valueToJs opts m e val

210−valueToJs opts m e (App val arg) = JSApp <$> valueToJs opts m e val <*> (return <$> valueToJs opts m e arg)

210+valueToJs opts m e v@App{} = do

211+ let (f, args) = unApp v []

212+ args' <- mapM (valueToJs opts m e) args

213+ case f of

214+ Constructor name | getConstructorArity e name == length args ->

215+ return $ JSUnary JSNew $ JSApp (qualifiedToJS m (Ident . runProperName) name) args'

216+ _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs opts m e f

217+ where

218+ unApp :: Value -> [Value] -> (Value, [Value])

219+ unApp (App val arg) args = unApp val (arg : args)

220+ unApp (PositionedValue _ val) args = unApp val args

221+ unApp (TypedValue _ val _) args = unApp val args

222+ unApp other args = (other, args)

211valueToJs opts m e (Let ds val) = do

223valueToJs opts m e (Let ds val) = do

212 decls <- concat . catMaybes <$> mapM (flip (declToJs opts m) e) ds

224 decls <- concat . catMaybes <$> mapM (flip (declToJs opts m) e) ds

213 ret <- valueToJs opts m e val

225 ret <- valueToJs opts m e val

@@ -385,23 +397,37 @@ binderToJs m e varName done (PositionedBinder _ binder) =

385 binderToJs m e varName done binder

397 binderToJs m e varName done binder

386

398

387-- |

399-- |

400+-- Finds the value stored for a data constructor in the current environment.

401+-- This is a partial function, but if an invalid type has reached this far then

402+-- something has gone wrong in typechecking.

403+--

404+lookupConstructor :: Environment -> Qualified ProperName -> (ProperName, Type)

405+lookupConstructor e ctor = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e

406+

407+-- |

388−-- Checks whether a data constructor is the only constructor for that type, used to simplify the

408+-- Checks whether a data constructor is the only constructor for that type, used

389−-- check when generating code for binders.

409+-- to simplify the check when generating code for binders.

390--

410--

391isOnlyConstructor :: Environment -> Qualified ProperName -> Bool

411isOnlyConstructor :: Environment -> Qualified ProperName -> Bool

392−isOnlyConstructor e ctor =

412+isOnlyConstructor e ctor = numConstructors (ctor, lookupConstructor e ctor) == 1

393− let ty = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e

394− in numConstructors (ctor, ty) == 1

395 where

413 where

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

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

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

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

398 typeConstructor _ = error "Invalid argument to isOnlyConstructor"

416 typeConstructor _ = error "Invalid argument to isOnlyConstructor"

399

417

418+-- |

419+-- Checks the number of arguments a data constructor accepts.

420+--

400−isNullaryConstructor :: Environment -> Qualified ProperName -> Bool

421+getConstructorArity :: Environment -> Qualified ProperName -> Int

401−isNullaryConstructor e ctor =

422+getConstructorArity e = go . snd . lookupConstructor e

402− not . isFunction . snd . fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e

403 where

423 where

404− isFunction :: Type -> Bool

424+ go :: Type -> Int

405− isFunction (ForAll _ t _) = isFunction t

425+ go (TypeApp (TypeApp f _) t) | f == tyFunction = go t + 1

406− isFunction (TypeApp t _) = isFunction t

426+ go (ForAll _ ty _) = go ty

407− isFunction t = t == tyFunction

427+ go _ = 0

428+

429+-- |

430+-- Checks whether a data constructor has no arguments, for example, `Nothing`.

431+--

432+isNullaryConstructor :: Environment -> Qualified ProperName -> Bool

433+isNullaryConstructor e = (== 0) . getConstructorArity e