{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards     #-}
{-# LANGUAGE TupleSections     #-}

-- | Optimizing the outputted JavaScript(-ish) AST.

module Fay.Compiler.Optimizer where

import           Fay.Compiler.Prelude

import           Fay.Compiler.Misc
import           Fay.Types

import           Control.Monad.State             (State, modify, runState)
import           Control.Monad.Writer            (runWriter, tell)
import qualified Fay.Exts.NoAnnotation           as N
import           Language.Haskell.Exts hiding (app, name, op)

-- | The arity of a function. Arity here is defined to be the number
-- of arguments that can be directly uncurried from a curried lambda
-- abstraction. So \x y z -> if x then (\a -> a) else (\a -> a) has an
-- arity of 3, not 4.
type FuncArity = (N.QName,Int)

-- | Optimize monad.
type Optimize = State OptState

-- | State.
data OptState = OptState
  { OptState -> [JsStmt]
optStmts   :: [JsStmt]
  , OptState -> [QName]
optUncurry :: [N.QName]
  }

-- | Run an optimizer, which may output additional statements.
runOptimizer :: ([JsStmt] -> Optimize [JsStmt]) -> [JsStmt] -> [JsStmt]
runOptimizer :: ([JsStmt] -> Optimize [JsStmt]) -> [JsStmt] -> [JsStmt]
runOptimizer optimizer :: [JsStmt] -> Optimize [JsStmt]
optimizer stmts :: [JsStmt]
stmts =
  let (newstmts :: [JsStmt]
newstmts,OptState _ uncurried :: [QName]
uncurried) = (Optimize [JsStmt] -> OptState -> ([JsStmt], OptState))
-> OptState -> Optimize [JsStmt] -> ([JsStmt], OptState)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Optimize [JsStmt] -> OptState -> ([JsStmt], OptState)
forall s a. State s a -> s -> (a, s)
runState OptState
st (Optimize [JsStmt] -> ([JsStmt], OptState))
-> Optimize [JsStmt] -> ([JsStmt], OptState)
forall a b. (a -> b) -> a -> b
$ [JsStmt] -> Optimize [JsStmt]
optimizer [JsStmt]
stmts
  in [JsStmt]
newstmts [JsStmt] -> [JsStmt] -> [JsStmt]
forall a. [a] -> [a] -> [a]
++ ([JsStmt] -> [JsStmt]
tco ([JsStmt] -> [JsStmt])
-> ([QName] -> [JsStmt]) -> [QName] -> [JsStmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QName -> Maybe JsStmt) -> [QName] -> [JsStmt]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([JsStmt] -> QName -> Maybe JsStmt
uncurryBinding [JsStmt]
newstmts) ([QName] -> [JsStmt]) -> [QName] -> [JsStmt]
forall a b. (a -> b) -> a -> b
$ [QName] -> [QName]
forall a. Eq a => [a] -> [a]
nub [QName]
uncurried)
  where st :: OptState
st = [JsStmt] -> [QName] -> OptState
OptState [JsStmt]
stmts []

-- | Inline x >> y to x;y in the JS output.
inlineMonad :: [JsStmt] -> [JsStmt]
inlineMonad :: [JsStmt] -> [JsStmt]
inlineMonad = (JsStmt -> JsStmt) -> [JsStmt] -> [JsStmt]
forall a b. (a -> b) -> [a] -> [b]
map JsStmt -> JsStmt
go where
  go :: JsStmt -> JsStmt
go stmt :: JsStmt
stmt = case JsStmt
stmt of
    JsVar name :: JsName
name exp :: JsExp
exp          -> JsName -> JsExp -> JsStmt
JsVar JsName
name (JsExp -> JsExp
inline JsExp
exp)
    JsIf exp :: JsExp
exp stmts :: [JsStmt]
stmts stmts' :: [JsStmt]
stmts'   -> JsExp -> [JsStmt] -> [JsStmt] -> JsStmt
JsIf (JsExp -> JsExp
inline JsExp
exp) ((JsStmt -> JsStmt) -> [JsStmt] -> [JsStmt]
forall a b. (a -> b) -> [a] -> [b]
map JsStmt -> JsStmt
go [JsStmt]
stmts) ((JsStmt -> JsStmt) -> [JsStmt] -> [JsStmt]
forall a b. (a -> b) -> [a] -> [b]
map JsStmt -> JsStmt
go [JsStmt]
stmts')
    JsEarlyReturn exp :: JsExp
exp       -> JsExp -> JsStmt
JsEarlyReturn (JsExp -> JsExp
inline JsExp
exp)
    JsThrow exp :: JsExp
exp             -> JsExp -> JsStmt
JsThrow (JsExp -> JsExp
inline JsExp
exp)
    JsWhile exp :: JsExp
exp stmts :: [JsStmt]
stmts       -> JsExp -> [JsStmt] -> JsStmt
JsWhile (JsExp -> JsExp
inline JsExp
exp) ((JsStmt -> JsStmt) -> [JsStmt] -> [JsStmt]
forall a b. (a -> b) -> [a] -> [b]
map JsStmt -> JsStmt
go [JsStmt]
stmts)
    JsUpdate name :: JsName
name exp :: JsExp
exp       -> JsName -> JsExp -> JsStmt
JsUpdate JsName
name (JsExp -> JsExp
inline JsExp
exp)
    JsSetProp a :: JsName
a b :: JsName
b exp :: JsExp
exp       -> JsName -> JsName -> JsExp -> JsStmt
JsSetProp JsName
a JsName
b (JsExp -> JsExp
inline JsExp
exp)
    JsSetQName s :: Maybe SrcSpan
s a :: QName
a exp :: JsExp
exp      -> Maybe SrcSpan -> QName -> JsExp -> JsStmt
JsSetQName Maybe SrcSpan
s QName
a (JsExp -> JsExp
inline JsExp
exp)
    JsSetModule a :: ModulePath
a exp :: JsExp
exp       -> ModulePath -> JsExp -> JsStmt
JsSetModule ModulePath
a (JsExp -> JsExp
inline JsExp
exp)
    JsSetConstructor a :: QName
a exp :: JsExp
exp  -> QName -> JsExp -> JsStmt
JsSetConstructor QName
a (JsExp -> JsExp
inline JsExp
exp)
    JsSetPropExtern a :: JsName
a b :: JsName
b exp :: JsExp
exp -> JsName -> JsName -> JsExp -> JsStmt
JsSetPropExtern JsName
a JsName
b (JsExp -> JsExp
inline JsExp
exp)
    JsContinue              -> JsStmt
JsContinue
    JsBlock stmts :: [JsStmt]
stmts           -> [JsStmt] -> JsStmt
JsBlock ((JsStmt -> JsStmt) -> [JsStmt] -> [JsStmt]
forall a b. (a -> b) -> [a] -> [b]
map JsStmt -> JsStmt
go [JsStmt]
stmts)
    JsExpStmt exp :: JsExp
exp           -> JsExp -> JsStmt
JsExpStmt (JsExp -> JsExp
inline JsExp
exp)

  inline :: JsExp -> JsExp
inline expr :: JsExp
expr = case JsExp
expr of
    -- Optimizations
    JsApp op :: JsExp
op args :: [JsExp]
args -> JsExp -> Maybe JsExp -> JsExp
forall a. a -> Maybe a -> a
fromMaybe (JsExp -> [JsExp] -> JsExp
JsApp (JsExp -> JsExp
inline JsExp
op) ([JsExp] -> JsExp) -> [JsExp] -> JsExp
forall a b. (a -> b) -> a -> b
$ (JsExp -> JsExp) -> [JsExp] -> [JsExp]
forall a b. (a -> b) -> [a] -> [b]
map JsExp -> JsExp
inline [JsExp]
args) (JsExp -> Maybe JsExp
flatten JsExp
expr)

    -- Plumbing
    JsFun nm :: Maybe JsName
nm names :: [JsName]
names stmts :: [JsStmt]
stmts mexp :: Maybe JsExp
mexp        -> Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
nm [JsName]
names ((JsStmt -> JsStmt) -> [JsStmt] -> [JsStmt]
forall a b. (a -> b) -> [a] -> [b]
map JsStmt -> JsStmt
go [JsStmt]
stmts) ((JsExp -> JsExp) -> Maybe JsExp -> Maybe JsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JsExp -> JsExp
inline Maybe JsExp
mexp)

    JsNegApp exp :: JsExp
exp                     -> JsExp -> JsExp
JsNegApp (JsExp -> JsExp
inline JsExp
exp)
    JsTernaryIf exp1 :: JsExp
exp1 exp2 :: JsExp
exp2 exp3 :: JsExp
exp3       -> JsExp -> JsExp -> JsExp -> JsExp
JsTernaryIf (JsExp -> JsExp
inline JsExp
exp1) (JsExp -> JsExp
inline JsExp
exp2) (JsExp -> JsExp
inline JsExp
exp3)
    JsParen exp :: JsExp
exp                      -> JsExp -> JsExp
JsParen (JsExp -> JsExp
inline JsExp
exp)
    JsGetProp exp :: JsExp
exp name :: JsName
name               -> JsExp -> JsName -> JsExp
JsGetProp (JsExp -> JsExp
inline JsExp
exp) JsName
name
    JsLookup exp :: JsExp
exp exp2 :: JsExp
exp2                -> JsExp -> JsExp -> JsExp
JsLookup (JsExp -> JsExp
inline JsExp
exp) (JsExp -> JsExp
inline JsExp
exp2)
    JsUpdateProp exp :: JsExp
exp name :: JsName
name exp2 :: JsExp
exp2       -> JsExp -> JsName -> JsExp -> JsExp
JsUpdateProp (JsExp -> JsExp
inline JsExp
exp) JsName
name (JsExp -> JsExp
inline JsExp
exp2)
    JsGetPropExtern exp :: JsExp
exp string :: String
string       -> JsExp -> String -> JsExp
JsGetPropExtern (JsExp -> JsExp
inline JsExp
exp) String
string
    JsUpdatePropExtern exp :: JsExp
exp name :: JsName
name exp2 :: JsExp
exp2 -> JsExp -> JsName -> JsExp -> JsExp
JsUpdatePropExtern (JsExp -> JsExp
inline JsExp
exp) JsName
name (JsExp -> JsExp
inline JsExp
exp2)
    JsList exps :: [JsExp]
exps                      -> [JsExp] -> JsExp
JsList ((JsExp -> JsExp) -> [JsExp] -> [JsExp]
forall a b. (a -> b) -> [a] -> [b]
map JsExp -> JsExp
inline [JsExp]
exps)
    JsNew name :: JsName
name exps :: [JsExp]
exps                  -> JsName -> [JsExp] -> JsExp
JsNew JsName
name ((JsExp -> JsExp) -> [JsExp] -> [JsExp]
forall a b. (a -> b) -> [a] -> [b]
map JsExp -> JsExp
inline [JsExp]
exps)
    JsThrowExp exp :: JsExp
exp                   -> JsExp -> JsExp
JsThrowExp (JsExp -> JsExp
inline JsExp
exp)
    JsInstanceOf exp :: JsExp
exp name :: JsName
name            -> JsExp -> JsName -> JsExp
JsInstanceOf (JsExp -> JsExp
inline JsExp
exp) JsName
name
    JsIndex i :: Int
i exp :: JsExp
exp                    -> Int -> JsExp -> JsExp
JsIndex Int
i (JsExp -> JsExp
inline JsExp
exp)
    JsEq exp :: JsExp
exp exp2 :: JsExp
exp2                    -> JsExp -> JsExp -> JsExp
JsEq (JsExp -> JsExp
inline JsExp
exp) (JsExp -> JsExp
inline JsExp
exp2)
    JsNeq exp :: JsExp
exp exp2 :: JsExp
exp2                   -> JsExp -> JsExp -> JsExp
JsNeq (JsExp -> JsExp
inline JsExp
exp) (JsExp -> JsExp
inline JsExp
exp2)
    JsInfix string :: String
string exp :: JsExp
exp exp2 :: JsExp
exp2          -> String -> JsExp -> JsExp -> JsExp
JsInfix String
string (JsExp -> JsExp
inline JsExp
exp) (JsExp -> JsExp
inline JsExp
exp2)
    JsObj keyvals :: [(String, JsExp)]
keyvals                    -> [(String, JsExp)] -> JsExp
JsObj [(String, JsExp)]
keyvals
    rest :: JsExp
rest                             -> JsExp
rest

-- | Flatten a a>>(b>>c) to [a,b,c].
flatten :: JsExp -> Maybe JsExp
flatten :: JsExp -> Maybe JsExp
flatten exp :: JsExp
exp = case JsExp -> Maybe [JsExp]
collect JsExp
exp of
  Just (stmts :: [JsExp]
stmts@(_:_:_)) -> let s :: [JsExp]
s = [JsExp] -> [JsExp]
forall a. [a] -> [a]
reverse [JsExp]
stmts
                          in JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just (JsExp -> Maybe JsExp) -> JsExp -> Maybe JsExp
forall a b. (a -> b) -> a -> b
$ JsExp -> JsExp
thunk ([JsExp] -> JsExp
JsSeq ((JsExp -> JsExp) -> [JsExp] -> [JsExp]
forall a b. (a -> b) -> [a] -> [b]
map JsExp -> JsExp
force ([JsExp] -> [JsExp]
forall a. [a] -> [a]
init [JsExp]
s) [JsExp] -> [JsExp] -> [JsExp]
forall a. [a] -> [a] -> [a]
++ [[JsExp] -> JsExp
forall a. [a] -> a
last [JsExp]
s]))
  _ -> Maybe JsExp
forall a. Maybe a
Nothing

-- | Try to collect nested a>>(b>>c).
collect :: JsExp -> Maybe [JsExp]
collect :: JsExp -> Maybe [JsExp]
collect exp :: JsExp
exp = case JsExp
exp of
  JsApp op :: JsExp
op args :: [JsExp]
args | JsExp -> Bool
isThen JsExp
op ->
    case [JsExp]
args of
      [rest :: JsExp
rest,x :: JsExp
x] -> (JsExp
x JsExp -> [JsExp] -> [JsExp]
forall a. a -> [a] -> [a]
:) ([JsExp] -> [JsExp]) -> Maybe [JsExp] -> Maybe [JsExp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsExp -> Maybe [JsExp]
collect JsExp
rest
      [x :: JsExp
x]  -> [JsExp] -> Maybe [JsExp]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsExp
x]
      _ -> Maybe [JsExp]
forall a. Maybe a
Nothing
  _ -> [JsExp] -> Maybe [JsExp]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsExp
exp]

  where
    isThen :: JsExp -> Bool
isThen (JsName (JsNameVar (Qual _ (ModuleName _ m :: String
m) (Ident _ n :: String
n)))) = String
m String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "Fay$" Bool -> Bool -> Bool
&& String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "then$uncurried"
    isThen _ = Bool
False


-- | Perform any top-level cross-module optimizations and GO DEEP to
-- optimize further.
optimizeToplevel :: [JsStmt] -> Optimize [JsStmt]
optimizeToplevel :: [JsStmt] -> Optimize [JsStmt]
optimizeToplevel = [JsStmt] -> Optimize [JsStmt]
stripAndUncurry

-- | Perform tail-call optimization.
tco :: [JsStmt] -> [JsStmt]
tco :: [JsStmt] -> [JsStmt]
tco = (JsStmt -> JsStmt) -> [JsStmt] -> [JsStmt]
forall a b. (a -> b) -> [a] -> [b]
map JsStmt -> JsStmt
inStmt where
  inStmt :: JsStmt -> JsStmt
inStmt stmt :: JsStmt
stmt = case JsStmt
stmt of
    JsVar name :: JsName
name exp :: JsExp
exp -> JsName -> JsExp -> JsStmt
JsVar JsName
name (JsName -> JsExp -> JsExp
inject JsName
name JsExp
exp)
    JsSetQName l :: Maybe SrcSpan
l name :: QName
name exp :: JsExp
exp -> Maybe SrcSpan -> QName -> JsExp -> JsStmt
JsSetQName Maybe SrcSpan
l QName
name (JsName -> JsExp -> JsExp
inject (QName -> JsName
JsNameVar QName
name) JsExp
exp)
    e :: JsStmt
e -> JsStmt
e
  inject :: JsName -> JsExp -> JsExp
inject name :: JsName
name exp :: JsExp
exp = case JsExp
exp of
    JsFun nm :: Maybe JsName
nm params :: [JsName]
params [] (Just (JsNew JsThunk [JsFun _ [] stmts :: [JsStmt]
stmts ret :: Maybe JsExp
ret])) ->
      Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
nm [JsName]
params
            []
            (JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just
              (JsName -> [JsExp] -> JsExp
JsNew JsName
JsThunk
                     [Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing []
                            ([JsName] -> JsName -> [JsStmt] -> [JsStmt]
optimize [JsName]
params JsName
name ([JsStmt]
stmts [JsStmt] -> [JsStmt] -> [JsStmt]
forall a. [a] -> [a] -> [a]
++ [ JsExp -> JsStmt
JsEarlyReturn JsExp
e | Just e :: JsExp
e <- [Maybe JsExp
ret] ]))
                            Maybe JsExp
forall a. Maybe a
Nothing]))
    _ -> JsExp
exp
  optimize :: [JsName] -> JsName -> [JsStmt] -> [JsStmt]
optimize params :: [JsName]
params name :: JsName
name stmts :: [JsStmt]
stmts = [JsStmt]
result where
    result :: [JsStmt]
result = let (newstmts :: [JsStmt]
newstmts,w :: [()]
w) = Writer [()] [JsStmt] -> ([JsStmt], [()])
forall w a. Writer w a -> (a, w)
runWriter Writer [()] [JsStmt]
makeWhile
             in if [()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [()]
w
                   then [JsStmt]
stmts
                   else [JsStmt]
newstmts
    makeWhile :: Writer [()] [JsStmt]
makeWhile = do
      [JsStmt]
newstmts <- ([[JsStmt]] -> [JsStmt])
-> WriterT [()] Identity [[JsStmt]] -> Writer [()] [JsStmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[JsStmt]] -> [JsStmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((JsStmt -> Writer [()] [JsStmt])
-> [JsStmt] -> WriterT [()] Identity [[JsStmt]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM JsStmt -> Writer [()] [JsStmt]
forall (f :: * -> *). MonadWriter [()] f => JsStmt -> f [JsStmt]
swap [JsStmt]
stmts)
      [JsStmt] -> Writer [()] [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsExp -> [JsStmt] -> JsStmt
JsWhile (JsLit -> JsExp
JsLit (Bool -> JsLit
JsBool Bool
True)) [JsStmt]
newstmts]
    swap :: JsStmt -> f [JsStmt]
swap stmt :: JsStmt
stmt = case JsStmt
stmt of
      JsEarlyReturn e :: JsExp
e
        | JsExp -> Bool
tailCall JsExp
e -> do [()] -> f ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [()]
                           [JsStmt] -> f [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return (JsExp -> [JsStmt]
rebind JsExp
e [JsStmt] -> [JsStmt] -> [JsStmt]
forall a. [a] -> [a] -> [a]
++ [JsStmt
JsContinue])
        | Bool
otherwise  -> [JsStmt] -> f [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsStmt
stmt]
      JsIf p :: JsExp
p ithen :: [JsStmt]
ithen ielse :: [JsStmt]
ielse -> do
        [JsStmt]
newithen <- ([[JsStmt]] -> [JsStmt]) -> f [[JsStmt]] -> f [JsStmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[JsStmt]] -> [JsStmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((JsStmt -> f [JsStmt]) -> [JsStmt] -> f [[JsStmt]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM JsStmt -> f [JsStmt]
swap [JsStmt]
ithen)
        [JsStmt]
newielse <- ([[JsStmt]] -> [JsStmt]) -> f [[JsStmt]] -> f [JsStmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[JsStmt]] -> [JsStmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((JsStmt -> f [JsStmt]) -> [JsStmt] -> f [[JsStmt]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM JsStmt -> f [JsStmt]
swap [JsStmt]
ielse)
        [JsStmt] -> f [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsExp -> [JsStmt] -> [JsStmt] -> JsStmt
JsIf JsExp
p [JsStmt]
newithen [JsStmt]
newielse]
      e :: JsStmt
e -> [JsStmt] -> f [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsStmt
e]
    tailCall :: JsExp -> Bool
tailCall (JsApp (JsName cname :: JsName
cname) _) = JsName
cname JsName -> JsName -> Bool
forall a. Eq a => a -> a -> Bool
== JsName
name
    tailCall _ = Bool
False
    rebind :: JsExp -> [JsStmt]
rebind (JsApp _ args :: [JsExp]
args) = (JsExp -> JsName -> JsStmt) -> [JsExp] -> [JsName] -> [JsStmt]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith JsExp -> JsName -> JsStmt
go [JsExp]
args [JsName]
params where
      go :: JsExp -> JsName -> JsStmt
go arg :: JsExp
arg param :: JsName
param = JsName -> JsExp -> JsStmt
JsUpdate JsName
param JsExp
arg
    rebind e :: JsExp
e = String -> [JsStmt]
forall a. HasCallStack => String -> a
error (String -> [JsStmt]) -> (JsExp -> String) -> JsExp -> [JsStmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsExp -> String
forall a. Show a => a -> String
show (JsExp -> [JsStmt]) -> JsExp -> [JsStmt]
forall a b. (a -> b) -> a -> b
$ JsExp
e

-- | Strip redundant forcing from the whole generated code.
stripAndUncurry :: [JsStmt] -> Optimize [JsStmt]
stripAndUncurry :: [JsStmt] -> Optimize [JsStmt]
stripAndUncurry = ([FuncArity] -> JsExp -> Optimize JsExp)
-> [JsStmt] -> Optimize [JsStmt]
applyToExpsInStmts [FuncArity] -> JsExp -> Optimize JsExp
stripFuncForces where
  stripFuncForces :: [FuncArity] -> JsExp -> Optimize JsExp
stripFuncForces arities :: [FuncArity]
arities exp :: JsExp
exp = case JsExp
exp of
    JsApp (JsName JsForce) [JsName (JsNameVar f :: QName
f)]
      | Just _ <- QName -> [FuncArity] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup QName
f [FuncArity]
arities -> JsExp -> Optimize JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (JsName -> JsExp
JsName (QName -> JsName
JsNameVar QName
f))
    JsFun nm :: Maybe JsName
nm ps :: [JsName]
ps stmts :: [JsStmt]
stmts body :: Maybe JsExp
body         -> do [JsStmt]
substmts <- (JsStmt -> StateT OptState Identity JsStmt)
-> [JsStmt] -> Optimize [JsStmt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM JsStmt -> StateT OptState Identity JsStmt
stripInStmt [JsStmt]
stmts
                                         Maybe JsExp
sbody <- StateT OptState Identity (Maybe JsExp)
-> (JsExp -> StateT OptState Identity (Maybe JsExp))
-> Maybe JsExp
-> StateT OptState Identity (Maybe JsExp)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe JsExp -> StateT OptState Identity (Maybe JsExp)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe JsExp
forall a. Maybe a
Nothing) ((JsExp -> Maybe JsExp)
-> Optimize JsExp -> StateT OptState Identity (Maybe JsExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just (Optimize JsExp -> StateT OptState Identity (Maybe JsExp))
-> (JsExp -> Optimize JsExp)
-> JsExp
-> StateT OptState Identity (Maybe JsExp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsExp -> Optimize JsExp
go) Maybe JsExp
body
                                         JsExp -> Optimize JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
nm [JsName]
ps [JsStmt]
substmts Maybe JsExp
sbody)
    JsApp a :: JsExp
a b :: [JsExp]
b                      -> do
      Maybe JsExp
result <- [FuncArity] -> JsExp -> StateT OptState Identity (Maybe JsExp)
walkAndStripForces [FuncArity]
arities JsExp
exp
      case Maybe JsExp
result of
        Just strippedExp :: JsExp
strippedExp           -> JsExp -> Optimize JsExp
go JsExp
strippedExp
        Nothing                    -> JsExp -> [JsExp] -> JsExp
JsApp (JsExp -> [JsExp] -> JsExp)
-> Optimize JsExp -> StateT OptState Identity ([JsExp] -> JsExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsExp -> Optimize JsExp
go JsExp
a StateT OptState Identity ([JsExp] -> JsExp)
-> StateT OptState Identity [JsExp] -> Optimize JsExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (JsExp -> Optimize JsExp)
-> [JsExp] -> StateT OptState Identity [JsExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM JsExp -> Optimize JsExp
go [JsExp]
b
    JsNegApp e :: JsExp
e                     -> JsExp -> JsExp
JsNegApp (JsExp -> JsExp) -> Optimize JsExp -> Optimize JsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsExp -> Optimize JsExp
go JsExp
e
    JsTernaryIf a :: JsExp
a b :: JsExp
b c :: JsExp
c              -> JsExp -> JsExp -> JsExp -> JsExp
JsTernaryIf (JsExp -> JsExp -> JsExp -> JsExp)
-> Optimize JsExp
-> StateT OptState Identity (JsExp -> JsExp -> JsExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsExp -> Optimize JsExp
go JsExp
a StateT OptState Identity (JsExp -> JsExp -> JsExp)
-> Optimize JsExp -> StateT OptState Identity (JsExp -> JsExp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JsExp -> Optimize JsExp
go JsExp
b StateT OptState Identity (JsExp -> JsExp)
-> Optimize JsExp -> Optimize JsExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JsExp -> Optimize JsExp
go JsExp
c
    JsParen e :: JsExp
e                      -> JsExp -> JsExp
JsParen (JsExp -> JsExp) -> Optimize JsExp -> Optimize JsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsExp -> Optimize JsExp
go JsExp
e
    JsUpdateProp e :: JsExp
e n :: JsName
n a :: JsExp
a             -> JsExp -> JsName -> JsExp -> JsExp
JsUpdateProp (JsExp -> JsName -> JsExp -> JsExp)
-> Optimize JsExp
-> StateT OptState Identity (JsName -> JsExp -> JsExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsExp -> Optimize JsExp
go JsExp
e StateT OptState Identity (JsName -> JsExp -> JsExp)
-> StateT OptState Identity JsName
-> StateT OptState Identity (JsExp -> JsExp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JsName -> StateT OptState Identity JsName
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsName
n StateT OptState Identity (JsExp -> JsExp)
-> Optimize JsExp -> Optimize JsExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JsExp -> Optimize JsExp
go JsExp
a
    JsList xs :: [JsExp]
xs                      -> [JsExp] -> JsExp
JsList ([JsExp] -> JsExp)
-> StateT OptState Identity [JsExp] -> Optimize JsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JsExp -> Optimize JsExp)
-> [JsExp] -> StateT OptState Identity [JsExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM JsExp -> Optimize JsExp
go [JsExp]
xs
    JsEq a :: JsExp
a b :: JsExp
b                       -> JsExp -> JsExp -> JsExp
JsEq (JsExp -> JsExp -> JsExp)
-> Optimize JsExp -> StateT OptState Identity (JsExp -> JsExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsExp -> Optimize JsExp
go JsExp
a StateT OptState Identity (JsExp -> JsExp)
-> Optimize JsExp -> Optimize JsExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JsExp -> Optimize JsExp
go JsExp
b
    JsInfix op :: String
op a :: JsExp
a b :: JsExp
b                 -> String -> JsExp -> JsExp -> JsExp
JsInfix String
op (JsExp -> JsExp -> JsExp)
-> Optimize JsExp -> StateT OptState Identity (JsExp -> JsExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsExp -> Optimize JsExp
go JsExp
a StateT OptState Identity (JsExp -> JsExp)
-> Optimize JsExp -> Optimize JsExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JsExp -> Optimize JsExp
go JsExp
b
    JsObj xs :: [(String, JsExp)]
xs                       -> [(String, JsExp)] -> JsExp
JsObj ([(String, JsExp)] -> JsExp)
-> StateT OptState Identity [(String, JsExp)] -> Optimize JsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String, JsExp) -> StateT OptState Identity (String, JsExp))
-> [(String, JsExp)] -> StateT OptState Identity [(String, JsExp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(x :: String
x,y :: JsExp
y) -> (String
x,) (JsExp -> (String, JsExp))
-> Optimize JsExp -> StateT OptState Identity (String, JsExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsExp -> Optimize JsExp
go JsExp
y) [(String, JsExp)]
xs
    JsNew name :: JsName
name xs :: [JsExp]
xs                  -> JsName -> [JsExp] -> JsExp
JsNew JsName
name ([JsExp] -> JsExp)
-> StateT OptState Identity [JsExp] -> Optimize JsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JsExp -> Optimize JsExp)
-> [JsExp] -> StateT OptState Identity [JsExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM JsExp -> Optimize JsExp
go [JsExp]
xs
    e :: JsExp
e                              -> JsExp -> Optimize JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return JsExp
e

    where
      go :: JsExp -> Optimize JsExp
go = [FuncArity] -> JsExp -> Optimize JsExp
stripFuncForces [FuncArity]
arities
      stripInStmt :: JsStmt -> StateT OptState Identity JsStmt
stripInStmt = [FuncArity]
-> ([FuncArity] -> JsExp -> Optimize JsExp)
-> JsStmt
-> StateT OptState Identity JsStmt
applyToExpsInStmt [FuncArity]
arities [FuncArity] -> JsExp -> Optimize JsExp
stripFuncForces

-- | Strip redundant forcing from an application if possible.
walkAndStripForces :: [FuncArity] -> JsExp -> Optimize (Maybe JsExp)
walkAndStripForces :: [FuncArity] -> JsExp -> StateT OptState Identity (Maybe JsExp)
walkAndStripForces arities :: [FuncArity]
arities = Bool -> [JsExp] -> JsExp -> StateT OptState Identity (Maybe JsExp)
forall (m :: * -> *).
MonadState OptState m =>
Bool -> [JsExp] -> JsExp -> m (Maybe JsExp)
go Bool
True [] where
  go :: Bool -> [JsExp] -> JsExp -> m (Maybe JsExp)
go frst :: Bool
frst args :: [JsExp]
args app :: JsExp
app = case JsExp
app of
    JsApp (JsName JsForce) [e :: JsExp
e] ->
      if Bool
frst
        then do
          Maybe JsExp
result <- Bool -> [JsExp] -> JsExp -> m (Maybe JsExp)
go Bool
False [JsExp]
args JsExp
e
          case Maybe JsExp
result of
            Nothing -> Maybe JsExp -> m (Maybe JsExp)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe JsExp
forall a. Maybe a
Nothing
            Just ex :: JsExp
ex -> Maybe JsExp -> m (Maybe JsExp)
forall (m :: * -> *) a. Monad m => a -> m a
return (JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just (JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName JsName
JsForce) [JsExp
ex]))
        else Bool -> [JsExp] -> JsExp -> m (Maybe JsExp)
go Bool
False [JsExp]
args JsExp
e
    JsApp op :: JsExp
op [arg :: JsExp
arg] -> Bool -> [JsExp] -> JsExp -> m (Maybe JsExp)
go Bool
False (JsExp
argJsExp -> [JsExp] -> [JsExp]
forall a. a -> [a] -> [a]
:[JsExp]
args) JsExp
op
    JsName (JsNameVar f :: QName
f)
      | Just arity :: Int
arity <- QName -> [FuncArity] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup QName
f [FuncArity]
arities, [JsExp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JsExp]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
arity -> do
        (OptState -> OptState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((OptState -> OptState) -> m ()) -> (OptState -> OptState) -> m ()
forall a b. (a -> b) -> a -> b
$ \s :: OptState
s -> OptState
s { optUncurry :: [QName]
optUncurry = QName
f QName -> [QName] -> [QName]
forall a. a -> [a] -> [a]
: OptState -> [QName]
optUncurry OptState
s }
        Maybe JsExp -> m (Maybe JsExp)
forall (m :: * -> *) a. Monad m => a -> m a
return (JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just (JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName (QName -> JsName
JsNameVar (QName -> QName
renameUncurried QName
f))) [JsExp]
args))
    _ -> Maybe JsExp -> m (Maybe JsExp)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe JsExp
forall a. Maybe a
Nothing

-- | Apply the given function to the top-level expressions in the
-- given statements.
applyToExpsInStmts :: ([FuncArity] -> JsExp -> Optimize JsExp) -> [JsStmt] -> Optimize [JsStmt]
applyToExpsInStmts :: ([FuncArity] -> JsExp -> Optimize JsExp)
-> [JsStmt] -> Optimize [JsStmt]
applyToExpsInStmts f :: [FuncArity] -> JsExp -> Optimize JsExp
f stmts :: [JsStmt]
stmts = (JsStmt -> StateT OptState Identity JsStmt)
-> [JsStmt] -> Optimize [JsStmt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([FuncArity]
-> ([FuncArity] -> JsExp -> Optimize JsExp)
-> JsStmt
-> StateT OptState Identity JsStmt
applyToExpsInStmt ([JsStmt] -> [FuncArity]
collectFuncs [JsStmt]
stmts) [FuncArity] -> JsExp -> Optimize JsExp
f) [JsStmt]
stmts

-- | Apply the given function to the top-level expressions in the
-- given statement.
applyToExpsInStmt :: [FuncArity] -> ([FuncArity] -> JsExp -> Optimize JsExp) -> JsStmt -> Optimize JsStmt
applyToExpsInStmt :: [FuncArity]
-> ([FuncArity] -> JsExp -> Optimize JsExp)
-> JsStmt
-> StateT OptState Identity JsStmt
applyToExpsInStmt funcs :: [FuncArity]
funcs f :: [FuncArity] -> JsExp -> Optimize JsExp
f = JsStmt -> StateT OptState Identity JsStmt
uncurryInStmt where
  transform :: JsExp -> Optimize JsExp
transform = [FuncArity] -> JsExp -> Optimize JsExp
f [FuncArity]
funcs
  uncurryInStmt :: JsStmt -> StateT OptState Identity JsStmt
uncurryInStmt stmt :: JsStmt
stmt = case JsStmt
stmt of
    JsVar name :: JsName
name exp :: JsExp
exp              -> JsName -> JsExp -> JsStmt
JsVar JsName
name (JsExp -> JsStmt)
-> Optimize JsExp -> StateT OptState Identity JsStmt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsExp -> Optimize JsExp
transform JsExp
exp
    JsSetQName l :: Maybe SrcSpan
l name :: QName
name exp :: JsExp
exp       -> Maybe SrcSpan -> QName -> JsExp -> JsStmt
JsSetQName Maybe SrcSpan
l QName
name (JsExp -> JsStmt)
-> Optimize JsExp -> StateT OptState Identity JsStmt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsExp -> Optimize JsExp
transform JsExp
exp
    JsEarlyReturn exp :: JsExp
exp           -> JsExp -> JsStmt
JsEarlyReturn (JsExp -> JsStmt)
-> Optimize JsExp -> StateT OptState Identity JsStmt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsExp -> Optimize JsExp
transform JsExp
exp
    JsIf op :: JsExp
op ithen :: [JsStmt]
ithen ielse :: [JsStmt]
ielse         -> JsExp -> [JsStmt] -> [JsStmt] -> JsStmt
JsIf (JsExp -> [JsStmt] -> [JsStmt] -> JsStmt)
-> Optimize JsExp
-> StateT OptState Identity ([JsStmt] -> [JsStmt] -> JsStmt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsExp -> Optimize JsExp
transform JsExp
op
                                        StateT OptState Identity ([JsStmt] -> [JsStmt] -> JsStmt)
-> Optimize [JsStmt]
-> StateT OptState Identity ([JsStmt] -> JsStmt)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (JsStmt -> StateT OptState Identity JsStmt)
-> [JsStmt] -> Optimize [JsStmt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM JsStmt -> StateT OptState Identity JsStmt
uncurryInStmt [JsStmt]
ithen
                                        StateT OptState Identity ([JsStmt] -> JsStmt)
-> Optimize [JsStmt] -> StateT OptState Identity JsStmt
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (JsStmt -> StateT OptState Identity JsStmt)
-> [JsStmt] -> Optimize [JsStmt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM JsStmt -> StateT OptState Identity JsStmt
uncurryInStmt [JsStmt]
ielse
    s :: JsStmt
s -> JsStmt -> StateT OptState Identity JsStmt
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsStmt
s

-- | Collect functions and their arity from the whole codeset.
collectFuncs :: [JsStmt] -> [FuncArity]
collectFuncs :: [JsStmt] -> [FuncArity]
collectFuncs = ([FuncArity] -> [FuncArity] -> [FuncArity]
forall a. [a] -> [a] -> [a]
++ [FuncArity]
prim) ([FuncArity] -> [FuncArity])
-> ([JsStmt] -> [FuncArity]) -> [JsStmt] -> [FuncArity]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (JsStmt -> [FuncArity]) -> [JsStmt] -> [FuncArity]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap JsStmt -> [FuncArity]
collectFunc where
  collectFunc :: JsStmt -> [FuncArity]
collectFunc (JsSetQName _ name :: QName
name exp :: JsExp
exp) | Int
arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = [(QName
name,Int
arity)]
    where arity :: Int
arity = JsExp -> Int
expArity JsExp
exp
  collectFunc _ = []
  prim :: [FuncArity]
prim = ((Name (), Int) -> FuncArity) -> [(Name (), Int)] -> [FuncArity]
forall a b. (a -> b) -> [a] -> [b]
map ((Name () -> QName) -> (Name (), Int) -> FuncArity
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (() -> ModuleName () -> Name () -> QName
forall l. l -> ModuleName l -> Name l -> QName l
Qual () (() -> String -> ModuleName ()
forall l. l -> String -> ModuleName l
ModuleName () "Fay$"))) ([(Name (), Int)]
unary [(Name (), Int)] -> [(Name (), Int)] -> [(Name (), Int)]
forall a. [a] -> [a] -> [a]
++ [(Name (), Int)]
binary)
  unary :: [(Name (), Int)]
unary = (Name () -> (Name (), Int)) -> [Name ()] -> [(Name (), Int)]
forall a b. (a -> b) -> [a] -> [b]
map (,1) [() -> String -> Name ()
forall l. l -> String -> Name l
Ident () "return"]
  binary :: [(Name (), Int)]
binary = (String -> (Name (), Int)) -> [String] -> [(Name (), Int)]
forall a b. (a -> b) -> [a] -> [b]
map ((,2) (Name () -> (Name (), Int))
-> (String -> Name ()) -> String -> (Name (), Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> String -> Name ()
forall l. l -> String -> Name l
Ident ())
               ["then","bind","mult","mult","add","sub","div"
               ,"eq","neq","gt","lt","gte","lte","and","or"]

-- | Get the arity of an expression.
expArity :: JsExp -> Int
expArity :: JsExp -> Int
expArity (JsFun _ _ _ mexp :: Maybe JsExp
mexp) = 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> (JsExp -> Int) -> Maybe JsExp -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 0 JsExp -> Int
expArity Maybe JsExp
mexp
expArity _ = 0

-- | Change foo(x)(y) to foo$uncurried(x,y).
uncurryBinding :: [JsStmt] -> N.QName -> Maybe JsStmt
uncurryBinding :: [JsStmt] -> QName -> Maybe JsStmt
uncurryBinding stmts :: [JsStmt]
stmts qname :: QName
qname = [JsStmt] -> Maybe JsStmt
forall a. [a] -> Maybe a
listToMaybe ((JsStmt -> Maybe JsStmt) -> [JsStmt] -> [JsStmt]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe JsStmt -> Maybe JsStmt
funBinding [JsStmt]
stmts)
  where
    funBinding :: JsStmt -> Maybe JsStmt
funBinding stmt :: JsStmt
stmt = case JsStmt
stmt of
      JsVar (JsNameVar name :: QName
name) body :: JsExp
body
        | QName
name QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
qname -> JsName -> JsExp -> JsStmt
JsVar (QName -> JsName
JsNameVar (QName -> QName
renameUncurried QName
name)) (JsExp -> JsStmt) -> Maybe JsExp -> Maybe JsStmt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsExp -> Maybe JsExp
uncurryIt JsExp
body
      JsSetQName l :: Maybe SrcSpan
l name :: QName
name body :: JsExp
body
        | QName
name QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
qname -> Maybe SrcSpan -> QName -> JsExp -> JsStmt
JsSetQName Maybe SrcSpan
l (QName -> QName
renameUncurried QName
name) (JsExp -> JsStmt) -> Maybe JsExp -> Maybe JsStmt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsExp -> Maybe JsExp
uncurryIt JsExp
body
      _ -> Maybe JsStmt
forall a. Maybe a
Nothing

    uncurryIt :: JsExp -> Maybe JsExp
uncurryIt = JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just (JsExp -> Maybe JsExp) -> (JsExp -> JsExp) -> JsExp -> Maybe JsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JsName] -> JsExp -> JsExp
go [] where
      go :: [JsName] -> JsExp -> JsExp
go args :: [JsName]
args exp :: JsExp
exp = case JsExp
exp of
        JsFun _ [arg :: JsName
arg] [] (Just body :: JsExp
body) -> [JsName] -> JsExp -> JsExp
go (JsName
arg JsName -> [JsName] -> [JsName]
forall a. a -> [a] -> [a]
: [JsName]
args) JsExp
body
        inner :: JsExp
inner -> Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing ([JsName] -> [JsName]
forall a. [a] -> [a]
reverse [JsName]
args) [] (JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just JsExp
inner)

-- | Rename an uncurried copy of a curried function.
renameUncurried :: N.QName -> N.QName
renameUncurried :: QName -> QName
renameUncurried q :: QName
q = case QName
q of
  Qual _ m :: ModuleName ()
m n :: Name ()
n -> () -> ModuleName () -> Name () -> QName
forall l. l -> ModuleName l -> Name l -> QName l
Qual () ModuleName ()
m (Name () -> Name ()
forall l. Name l -> Name ()
renameUnQual Name ()
n)
  UnQual _ n :: Name ()
n -> () -> Name () -> QName
forall l. l -> Name l -> QName l
UnQual () (Name () -> Name ()
forall l. Name l -> Name ()
renameUnQual Name ()
n)
  s :: QName
s -> QName
s
  where
    renameUnQual :: Name l -> Name ()
renameUnQual n :: Name l
n = case Name l
n of
      Ident _ nom :: String
nom -> () -> String -> Name ()
forall l. l -> String -> Name l
Ident () (String
nom String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
postfix)
      Symbol _ nom :: String
nom -> () -> String -> Name ()
forall l. l -> String -> Name l
Symbol () (String
nom String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
postfix)
    postfix :: String
postfix = "$uncurried"