{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeSynonymInstances  #-}
{-# LANGUAGE ViewPatterns          #-}

-- | Compile expressions.

module Fay.Compiler.Exp
  (compileExp
  ,compileGuards
  ,compileLetDecl
  ,compileLit
  ) where

import           Fay.Compiler.Prelude

import           Fay.Compiler.FFI                (compileFFIExp)
import           Fay.Compiler.Misc
import           Fay.Compiler.Pattern
import           Fay.Compiler.Print
import           Fay.Compiler.QName
import           Fay.Config
import           Fay.Exts.NoAnnotation           (unAnn)
import           Fay.Exts.Scoped                 (noI)
import qualified Fay.Exts.Scoped                 as S
import           Fay.Types

import           Control.Monad.Except            (throwError)
import           Control.Monad.RWS               (asks, gets)
import qualified Data.Char                       as Char
import           Language.Haskell.Exts hiding (alt, binds, name, op)
import           Language.Haskell.Names          (NameInfo (RecExpWildcard), Scoped (Scoped))

-- | Compile Haskell expression.
compileExp :: S.Exp -> Compile JsExp
compileExp :: Exp -> Compile JsExp
compileExp Exp
e = case Exp
e of
  Var X
_ QName X
qname                        -> QName X -> Compile JsExp
compileVar QName X
qname
  Lit X
s Literal X
lit                          -> Sign -> Literal X -> Compile JsExp
compileLit (X -> Sign
forall l. l -> Sign l
Signless X
s) Literal X
lit
  App X
_ (Var X
_ (UnQual X
_ (Ident X
_ String
"ffi"))) Exp
_ -> CompileError -> Compile JsExp
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> Compile JsExp) -> CompileError -> Compile JsExp
forall a b. (a -> b) -> a -> b
$ Exp -> CompileError
FfiNeedsTypeSig Exp
e
  App X
_ Exp
exp1 Exp
exp2                    -> Exp -> Exp -> Compile JsExp
compileApp Exp
exp1 Exp
exp2
  NegApp X
_ Exp
exp                       -> Exp -> Compile JsExp
compileNegApp Exp
exp
  Let X
_ (BDecls X
_ [Decl X]
decls) Exp
exp         -> [Decl X] -> Exp -> Compile JsExp
compileLet [Decl X]
decls Exp
exp
  List X
_ []                          -> JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return JsExp
JsNull
  List X
_ [Exp]
xs                          -> [Exp] -> Compile JsExp
compileList [Exp]
xs
  Tuple X
_ Boxed
_boxed [Exp]
xs                  -> [Exp] -> Compile JsExp
compileList [Exp]
xs
  If X
_ Exp
cond Exp
conseq Exp
alt               -> Exp -> Exp -> Exp -> Compile JsExp
compileIf Exp
cond Exp
conseq Exp
alt
  Case X
_ Exp
exp [Alt X]
alts                    -> Exp -> [Alt X] -> Compile JsExp
compileCase Exp
exp [Alt X]
alts
  Con X
_ (UnQual X
_ (Ident X
_ String
"True"))  -> JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (JsExp -> Compile JsExp) -> JsExp -> Compile JsExp
forall a b. (a -> b) -> a -> b
$ JsLit -> JsExp
JsLit (Bool -> JsLit
JsBool Bool
True)
  Con X
_ (UnQual X
_ (Ident X
_ String
"False")) -> JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (JsExp -> Compile JsExp) -> JsExp -> Compile JsExp
forall a b. (a -> b) -> a -> b
$ JsLit -> JsExp
JsLit (Bool -> JsLit
JsBool Bool
False)
  Con X
_ QName X
qname                        -> QName X -> Compile JsExp
compileVar QName X
qname
  Lambda X
_ [Pat X]
pats Exp
exp                  -> [Pat X] -> Exp -> Compile JsExp
compileLambda [Pat X]
pats Exp
exp
  EnumFrom X
_ Exp
i                       -> Exp -> Compile JsExp
compileEnumFrom Exp
i
  EnumFromTo X
_ Exp
i Exp
i'                  -> Exp -> Exp -> Compile JsExp
compileEnumFromTo Exp
i Exp
i'
  EnumFromThen X
_ Exp
a Exp
b                 -> Exp -> Exp -> Compile JsExp
compileEnumFromThen Exp
a Exp
b
  EnumFromThenTo X
_ Exp
a Exp
b Exp
z             -> Exp -> Exp -> Exp -> Compile JsExp
compileEnumFromThenTo Exp
a Exp
b Exp
z
  RecConstr X
_ QName X
name [FieldUpdate X]
fieldUpdates      -> Exp -> QName X -> [FieldUpdate X] -> Compile JsExp
compileRecConstr Exp
e QName X
name [FieldUpdate X]
fieldUpdates
  RecUpdate X
_ Exp
rec  [FieldUpdate X]
fieldUpdates      -> Exp -> Exp -> [FieldUpdate X] -> Compile JsExp
compileRecUpdate Exp
e Exp
rec [FieldUpdate X]
fieldUpdates
  ExpTypeSig X
_ Exp
exp Type X
sig               -> case Exp -> Maybe String
forall a. Exp a -> Maybe String
ffiExp Exp
exp of
    Maybe String
Nothing -> Exp -> Compile JsExp
compileExp Exp
exp
    Just String
formatstr -> SrcSpanInfo
-> Maybe (Name Any) -> String -> Type X -> Compile JsExp
forall a.
SrcSpanInfo -> Maybe (Name a) -> String -> Type X -> Compile JsExp
compileFFIExp (X -> SrcSpanInfo
S.srcSpanInfo (X -> SrcSpanInfo) -> X -> SrcSpanInfo
forall a b. (a -> b) -> a -> b
$ Exp -> X
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Exp
exp) Maybe (Name Any)
forall a. Maybe a
Nothing String
formatstr Type X
sig
  ListComp {}                        -> Exp -> Compile JsExp
forall (f :: * -> *) l a.
(Functor f, Show (f ())) =>
f l -> Compile a
shouldBeDesugared Exp
e
  Do {}                              -> Exp -> Compile JsExp
forall (f :: * -> *) l a.
(Functor f, Show (f ())) =>
f l -> Compile a
shouldBeDesugared Exp
e
  LeftSection {}                     -> Exp -> Compile JsExp
forall (f :: * -> *) l a.
(Functor f, Show (f ())) =>
f l -> Compile a
shouldBeDesugared Exp
e
  RightSection {}                    -> Exp -> Compile JsExp
forall (f :: * -> *) l a.
(Functor f, Show (f ())) =>
f l -> Compile a
shouldBeDesugared Exp
e
  TupleSection {}                    -> Exp -> Compile JsExp
forall (f :: * -> *) l a.
(Functor f, Show (f ())) =>
f l -> Compile a
shouldBeDesugared Exp
e
  Paren {}                           -> Exp -> Compile JsExp
forall (f :: * -> *) l a.
(Functor f, Show (f ())) =>
f l -> Compile a
shouldBeDesugared Exp
e
  InfixApp {}                        -> Exp -> Compile JsExp
forall (f :: * -> *) l a.
(Functor f, Show (f ())) =>
f l -> Compile a
shouldBeDesugared Exp
e
  Exp
exp -> CompileError -> Compile JsExp
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> Compile JsExp) -> CompileError -> Compile JsExp
forall a b. (a -> b) -> a -> b
$ Exp -> CompileError
UnsupportedExpression Exp
exp

-- | Compile variable.
compileVar :: S.QName -> Compile JsExp
compileVar :: QName X -> Compile JsExp
compileVar (Special X
_ t :: SpecialCon X
t@TupleCon{}) = SpecialCon X -> Compile JsExp
forall (f :: * -> *) l a.
(Functor f, Show (f ())) =>
f l -> Compile a
shouldBeDesugared SpecialCon X
t
compileVar QName X
qname = do
    Maybe (Maybe QName, Type)
nc <- QName X -> Compile (Maybe (Maybe QName, Type))
lookupNewtypeConst QName X
qname
    Maybe (QName, Type)
nd <- QName X -> Compile (Maybe (QName, Type))
lookupNewtypeDest QName X
qname
    if Maybe (Maybe QName, Type) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Maybe QName, Type)
nc Bool -> Bool -> Bool
|| Maybe (QName, Type) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (QName, Type)
nd
      then -- variable is either a newtype constructor or newtype destructor,
           -- replace it with identity function
           JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return JsExp
idFun
      else JsName -> JsExp
JsName (JsName -> JsExp) -> (QName -> JsName) -> QName -> JsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> JsName
JsNameVar (QName -> JsExp) -> Compile QName -> Compile JsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName X -> Compile QName
unsafeResolveName QName X
qname
  where
    idFun :: JsExp
idFun = Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing [Integer -> JsName
JsTmp Integer
1] [] (JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just (JsName -> JsExp
JsName (JsName -> JsExp) -> JsName -> JsExp
forall a b. (a -> b) -> a -> b
$ Integer -> JsName
JsTmp Integer
1))

-- | Compile Haskell literal.
compileLit :: S.Sign -> S.Literal -> Compile JsExp
compileLit :: Sign -> Literal X -> Compile JsExp
compileLit Sign
sign Literal X
lit = case Literal X
lit of
  Char X
_ Char
ch String
_       -> JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (JsLit -> JsExp
JsLit (Char -> JsLit
JsChar Char
ch))
  Int X
_ Integer
integer String
_   -> JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (JsLit -> JsExp
JsLit (Int -> JsLit
JsInt (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Integer
forall a. Num a => a -> a
applySign Integer
integer)))) -- FIXME:
  Frac X
_ Rational
rational String
_ -> JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (JsLit -> JsExp
JsLit (Double -> JsLit
JsFloating (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Rational
forall a. Num a => a -> a
applySign Rational
rational))))
  String X
_ String
string String
_ -> do
    Bool
fromString <- (CompileState -> Bool) -> Compile Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompileState -> Bool
stateUseFromString
    JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (JsExp -> Compile JsExp) -> JsExp -> Compile JsExp
forall a b. (a -> b) -> a -> b
$ if Bool
fromString
      then JsLit -> JsExp
JsLit (String -> JsLit
JsStr String
string)
      else JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName (Name -> JsName
JsBuiltIn Name
"list")) [JsLit -> JsExp
JsLit (String -> JsLit
JsStr String
string)]
  Literal X
_                 -> CompileError -> Compile JsExp
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> Compile JsExp) -> CompileError -> Compile JsExp
forall a b. (a -> b) -> a -> b
$ Literal X -> CompileError
UnsupportedLiteral Literal X
lit
  where
    applySign :: Num a => a -> a
    applySign :: a -> a
applySign = case Sign
sign of
      Signless X
_ -> a -> a
forall a. a -> a
id
      Negative X
_ -> a -> a
forall a. Num a => a -> a
negate

-- | Compile simple application.
compileApp :: S.Exp -> S.Exp -> Compile JsExp
compileApp :: Exp -> Exp -> Compile JsExp
compileApp exp1 :: Exp
exp1@(Con X
_ QName X
q) Exp
exp2 =
  Compile JsExp -> Compile JsExp -> Compile JsExp
forall a. Compile a -> Compile a -> Compile a
ifOptimizeNewtypes
    (Compile JsExp
-> ((Maybe QName, Type) -> Compile JsExp)
-> Maybe (Maybe QName, Type)
-> Compile JsExp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Exp -> Exp -> Compile JsExp
compileApp' Exp
exp1 Exp
exp2) (Compile JsExp -> (Maybe QName, Type) -> Compile JsExp
forall a b. a -> b -> a
const (Compile JsExp -> (Maybe QName, Type) -> Compile JsExp)
-> Compile JsExp -> (Maybe QName, Type) -> Compile JsExp
forall a b. (a -> b) -> a -> b
$ Exp -> Compile JsExp
compileExp Exp
exp2) (Maybe (Maybe QName, Type) -> Compile JsExp)
-> Compile (Maybe (Maybe QName, Type)) -> Compile JsExp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< QName X -> Compile (Maybe (Maybe QName, Type))
lookupNewtypeConst QName X
q)
    (Exp -> Exp -> Compile JsExp
compileApp' Exp
exp1 Exp
exp2)
compileApp exp1 :: Exp
exp1@(Var X
_ QName X
q) Exp
exp2 =
  Compile JsExp -> Compile JsExp -> Compile JsExp
forall a. Compile a -> Compile a -> Compile a
ifOptimizeNewtypes
    (Compile JsExp
-> ((QName, Type) -> Compile JsExp)
-> Maybe (QName, Type)
-> Compile JsExp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Exp -> Exp -> Compile JsExp
compileApp' Exp
exp1 Exp
exp2) (Compile JsExp -> (QName, Type) -> Compile JsExp
forall a b. a -> b -> a
const (Compile JsExp -> (QName, Type) -> Compile JsExp)
-> Compile JsExp -> (QName, Type) -> Compile JsExp
forall a b. (a -> b) -> a -> b
$ Exp -> Compile JsExp
compileExp Exp
exp2) (Maybe (QName, Type) -> Compile JsExp)
-> Compile (Maybe (QName, Type)) -> Compile JsExp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< QName X -> Compile (Maybe (QName, Type))
lookupNewtypeDest QName X
q)
    (Exp -> Exp -> Compile JsExp
compileApp' Exp
exp1 Exp
exp2)
compileApp Exp
exp1 Exp
exp2 =
  Exp -> Exp -> Compile JsExp
compileApp' Exp
exp1 Exp
exp2

-- | Helper for compileApp.
compileApp' :: S.Exp -> S.Exp -> Compile JsExp
compileApp' :: Exp -> Exp -> Compile JsExp
compileApp' Exp
exp1 Exp
exp2 = do
  Bool
flattenApps <- (Config -> Bool) -> Compile Bool
forall a. (Config -> a) -> Compile a
config Config -> Bool
configFlattenApps
  JsExp
jsexp1 <- Exp -> Compile JsExp
compileExp Exp
exp1
  (if Bool
flattenApps then JsExp -> Exp -> Compile JsExp
method2 else JsExp -> Exp -> Compile JsExp
method1) JsExp
jsexp1 Exp
exp2
    where
    -- Method 1:
    -- In this approach code ends up looking like this:
    -- a(a(a(a(a(a(a(a(a(a(L)(c))(b))(0))(0))(y))(t))(a(a(F)(3*a(a(d)+a(a(f)/20))))*a(a(f)/2)))(140+a(f)))(y))(t)})
    -- Which might be OK for speed, but increases the JS stack a fair bit.
    method1 :: JsExp -> S.Exp -> Compile JsExp
    method1 :: JsExp -> Exp -> Compile JsExp
method1 JsExp
e1 Exp
e2 =
      JsExp -> [JsExp] -> JsExp
JsApp (JsExp -> [JsExp] -> JsExp)
-> Compile JsExp -> Compile ([JsExp] -> JsExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JsExp -> JsExp
forceFlatName (JsExp -> JsExp) -> Compile JsExp -> Compile JsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return JsExp
e1)
            Compile ([JsExp] -> JsExp) -> Compile [JsExp] -> Compile JsExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (JsExp -> [JsExp]) -> Compile JsExp -> Compile [JsExp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JsExp -> [JsExp]
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Compile JsExp
compileExp Exp
e2)
      where
        forceFlatName :: JsExp -> JsExp
forceFlatName JsExp
name = JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName JsName
JsForce) [JsExp
name]

    -- Method 2:
    -- In this approach code ends up looking like this:
    -- d(O,a,b,0,0,B,w,e(d(I,3*e(e(c)+e(e(g)/20))))*e(e(g)/2),140+e(g),B,w)}),d(K,g,e(c)+0.05))
    -- Which should be much better for the stack and readability, but probably not great for speed.
    method2 :: JsExp -> S.Exp -> Compile JsExp
    method2 :: JsExp -> Exp -> Compile JsExp
method2 JsExp
e1 Exp
e2 = (JsExp -> JsExp) -> Compile JsExp -> Compile JsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JsExp -> JsExp
flatten (Compile JsExp -> Compile JsExp) -> Compile JsExp -> Compile JsExp
forall a b. (a -> b) -> a -> b
$
      JsExp -> [JsExp] -> JsExp
JsApp (JsExp -> [JsExp] -> JsExp)
-> Compile JsExp -> Compile ([JsExp] -> JsExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return JsExp
e1
            Compile ([JsExp] -> JsExp) -> Compile [JsExp] -> Compile JsExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (JsExp -> [JsExp]) -> Compile JsExp -> Compile [JsExp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JsExp -> [JsExp]
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Compile JsExp
compileExp Exp
e2)
      where
        flatten :: JsExp -> JsExp
flatten (JsApp JsExp
op [JsExp]
args) =
         case JsExp
op of
           JsApp JsExp
l [JsExp]
r -> JsExp -> [JsExp] -> JsExp
JsApp JsExp
l ([JsExp]
r [JsExp] -> [JsExp] -> [JsExp]
forall a. [a] -> [a] -> [a]
++ [JsExp]
args)
           JsExp
_        -> JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName JsName
JsApply) (JsExp
op JsExp -> [JsExp] -> [JsExp]
forall a. a -> [a] -> [a]
: [JsExp]
args)
        flatten JsExp
x = JsExp
x

-- | Compile a negate application
compileNegApp :: S.Exp -> Compile JsExp
compileNegApp :: Exp -> Compile JsExp
compileNegApp Exp
e = JsExp -> JsExp
JsNegApp (JsExp -> JsExp) -> (JsExp -> JsExp) -> JsExp -> JsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsExp -> JsExp
force (JsExp -> JsExp) -> Compile JsExp -> Compile JsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> Compile JsExp
compileExp Exp
e

-- | Compile a let expression.
compileLet :: [S.Decl] -> S.Exp -> Compile JsExp
compileLet :: [Decl X] -> Exp -> Compile JsExp
compileLet [Decl X]
decls Exp
exp = do
  [[JsStmt]]
binds <- (Decl X -> Compile [JsStmt]) -> [Decl X] -> Compile [[JsStmt]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl X -> Compile [JsStmt]
compileLetDecl [Decl X]
decls
  JsExp
body <- Exp -> Compile JsExp
compileExp Exp
exp
  JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (JsExp -> [JsExp] -> JsExp
JsApp (Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing [] [] (JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just (JsExp -> Maybe JsExp) -> JsExp -> Maybe JsExp
forall a b. (a -> b) -> a -> b
$ [JsStmt] -> JsExp
stmtsThunk ([JsStmt] -> JsExp) -> [JsStmt] -> JsExp
forall a b. (a -> b) -> a -> b
$ [[JsStmt]] -> [JsStmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[JsStmt]]
binds [JsStmt] -> [JsStmt] -> [JsStmt]
forall a. [a] -> [a] -> [a]
++ [JsExp -> JsStmt
JsEarlyReturn JsExp
body])) [])

-- | Compile let declaration.
compileLetDecl :: S.Decl -> Compile [JsStmt]
compileLetDecl :: Decl X -> Compile [JsStmt]
compileLetDecl Decl X
decl = do
  Bool -> [Decl X] -> Compile [JsStmt]
compileDecls <- (CompileReader -> Bool -> [Decl X] -> Compile [JsStmt])
-> Compile (Bool -> [Decl X] -> Compile [JsStmt])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompileReader -> Bool -> [Decl X] -> Compile [JsStmt]
readerCompileDecls
  case Decl X
decl of
    PatBind{} -> Bool -> [Decl X] -> Compile [JsStmt]
compileDecls Bool
False [Decl X
decl]
    FunBind{} -> Bool -> [Decl X] -> Compile [JsStmt]
compileDecls Bool
False [Decl X
decl]
    TypeSig{} -> [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Decl X
_         -> CompileError -> Compile [JsStmt]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> Compile [JsStmt])
-> CompileError -> Compile [JsStmt]
forall a b. (a -> b) -> a -> b
$ Decl X -> CompileError
UnsupportedLetBinding Decl X
decl

-- | Compile a list expression.
compileList :: [S.Exp] -> Compile JsExp
compileList :: [Exp] -> Compile JsExp
compileList [Exp]
xs = do
  [JsExp]
exps <- (Exp -> Compile JsExp) -> [Exp] -> Compile [JsExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp -> Compile JsExp
compileExp [Exp]
xs
  JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return ([JsExp] -> JsExp
makeList [JsExp]
exps)

-- | Compile an if.
compileIf :: S.Exp -> S.Exp -> S.Exp -> Compile JsExp
compileIf :: Exp -> Exp -> Exp -> Compile JsExp
compileIf Exp
cond Exp
conseq Exp
alt =
  JsExp -> JsExp -> JsExp -> JsExp
JsTernaryIf (JsExp -> JsExp -> JsExp -> JsExp)
-> Compile JsExp -> Compile (JsExp -> JsExp -> JsExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JsExp -> JsExp) -> Compile JsExp -> Compile JsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JsExp -> JsExp
force (Exp -> Compile JsExp
compileExp Exp
cond)
              Compile (JsExp -> JsExp -> JsExp)
-> Compile JsExp -> Compile (JsExp -> JsExp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> Compile JsExp
compileExp Exp
conseq
              Compile (JsExp -> JsExp) -> Compile JsExp -> Compile JsExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> Compile JsExp
compileExp Exp
alt

-- | Compile case expressions.
compileCase :: S.Exp -> [S.Alt] -> Compile JsExp
compileCase :: Exp -> [Alt X] -> Compile JsExp
compileCase Exp
e [Alt X]
alts = do
  JsExp
exp <- Exp -> Compile JsExp
compileExp Exp
e
  (JsName -> Compile JsExp) -> Compile JsExp
forall a. (JsName -> Compile a) -> Compile a
withScopedTmpJsName ((JsName -> Compile JsExp) -> Compile JsExp)
-> (JsName -> Compile JsExp) -> Compile JsExp
forall a b. (a -> b) -> a -> b
$ \JsName
tmpName -> do
    [[JsStmt]]
pats <- [[JsStmt]] -> [[JsStmt]]
optimizePatConditions ([[JsStmt]] -> [[JsStmt]])
-> Compile [[JsStmt]] -> Compile [[JsStmt]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Alt X -> Compile [JsStmt]) -> [Alt X] -> Compile [[JsStmt]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (JsExp -> Alt X -> Compile [JsStmt]
compilePatAlt (JsName -> JsExp
JsName JsName
tmpName)) [Alt X]
alts
    let ([JsStmt]
xx,Bool
flag) = [JsStmt] -> ([JsStmt], Bool)
deleteAfterReturn ([[JsStmt]] -> [JsStmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[JsStmt]]
pats)
    JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (JsExp -> Compile JsExp) -> JsExp -> Compile JsExp
forall a b. (a -> b) -> a -> b
$
      JsExp -> [JsExp] -> JsExp
JsApp (Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing
                   [JsName
tmpName]
                   [JsStmt]
xx
                   (if (Bool
flag Bool -> Bool -> Bool
|| (Alt X -> Bool) -> [Alt X] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Alt X -> Bool
isWildCardAlt [Alt X]
alts)
                       then Maybe JsExp
forall a. Maybe a
Nothing
                       else JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just (String -> JsExp -> JsExp
throwExp String
"unhandled case" (JsName -> JsExp
JsName JsName
tmpName))))
            [JsExp
exp]
  where
    deleteAfterReturn :: [JsStmt] -> ([JsStmt],Bool)
    deleteAfterReturn :: [JsStmt] -> ([JsStmt], Bool)
deleteAfterReturn [] = ([],Bool
False)
    deleteAfterReturn (x :: JsStmt
x@(JsEarlyReturn JsExp
_):[JsStmt]
_) = ([JsStmt
x],Bool
True)
    deleteAfterReturn (JsStmt
x:[JsStmt]
xs) = ((JsStmt
xJsStmt -> [JsStmt] -> [JsStmt]
forall a. a -> [a] -> [a]
:[JsStmt]
xx),Bool
flag)
      where ([JsStmt]
xx,Bool
flag) = [JsStmt] -> ([JsStmt], Bool)
deleteAfterReturn [JsStmt]
xs

-- | Compile the given pattern against the given expression.
compilePatAlt :: JsExp -> S.Alt -> Compile [JsStmt]
compilePatAlt :: JsExp -> Alt X -> Compile [JsStmt]
compilePatAlt JsExp
exp a :: Alt X
a@(Alt X
_ Pat X
pat Rhs X
rhs Maybe (Binds X)
wheres) = case Maybe (Binds X)
wheres of
  Just (BDecls  X
_ (Decl X
_ : [Decl X]
_)) -> CompileError -> Compile [JsStmt]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> Compile [JsStmt])
-> CompileError -> Compile [JsStmt]
forall a b. (a -> b) -> a -> b
$ Alt X -> CompileError
UnsupportedWhereInAlt Alt X
a
  Just (IPBinds X
_ (IPBind X
_ : [IPBind X]
_)) -> CompileError -> Compile [JsStmt]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> Compile [JsStmt])
-> CompileError -> Compile [JsStmt]
forall a b. (a -> b) -> a -> b
$ Alt X -> CompileError
UnsupportedWhereInAlt Alt X
a
  Maybe (Binds X)
_                        -> do
    JsStmt
alt <- Rhs X -> Compile JsStmt
compileGuardedAlt Rhs X
rhs
    JsExp -> Pat X -> [JsStmt] -> Compile [JsStmt]
compilePat JsExp
exp Pat X
pat [JsStmt
alt]

-- | Compile a guarded alt.
compileGuardedAlt :: S.Rhs -> Compile JsStmt
compileGuardedAlt :: Rhs X -> Compile JsStmt
compileGuardedAlt Rhs X
alt =
  case Rhs X
alt of
    UnGuardedRhs X
_ Exp
exp -> JsExp -> JsStmt
JsEarlyReturn (JsExp -> JsStmt) -> Compile JsExp -> Compile JsStmt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> Compile JsExp
compileExp Exp
exp
    GuardedRhss X
_ [GuardedRhs X]
alts -> [GuardedRhs X] -> Compile JsStmt
compileGuards [GuardedRhs X]
alts

-- | Compile guards
compileGuards :: [S.GuardedRhs] -> Compile JsStmt
compileGuards :: [GuardedRhs X] -> Compile JsStmt
compileGuards (GuardedRhs X
_ (Qualifier X
_ Exp
guard:[Stmt X]
_) Exp
exp : [GuardedRhs X]
rest) =
  JsExp -> JsExp -> [JsStmt] -> JsStmt
makeIf (JsExp -> JsExp -> [JsStmt] -> JsStmt)
-> Compile JsExp -> Compile (JsExp -> [JsStmt] -> JsStmt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JsExp -> JsExp) -> Compile JsExp -> Compile JsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JsExp -> JsExp
force (Exp -> Compile JsExp
compileExp Exp
guard)
         Compile (JsExp -> [JsStmt] -> JsStmt)
-> Compile JsExp -> Compile ([JsStmt] -> JsStmt)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> Compile JsExp
compileExp Exp
exp
         Compile ([JsStmt] -> JsStmt) -> Compile [JsStmt] -> Compile JsStmt
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> if [GuardedRhs X] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GuardedRhs X]
rest then [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [] else do
           JsStmt
gs' <- [GuardedRhs X] -> Compile JsStmt
compileGuards [GuardedRhs X]
rest
           [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsStmt
gs']
    where makeIf :: JsExp -> JsExp -> [JsStmt] -> JsStmt
makeIf JsExp
gs JsExp
e = JsExp -> [JsStmt] -> [JsStmt] -> JsStmt
JsIf JsExp
gs [JsExp -> JsStmt
JsEarlyReturn JsExp
e]

compileGuards [GuardedRhs X]
rhss = CompileError -> Compile JsStmt
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> Compile JsStmt)
-> ([GuardedRhs X] -> CompileError)
-> [GuardedRhs X]
-> Compile JsStmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rhs X -> CompileError
UnsupportedRhs (Rhs X -> CompileError)
-> ([GuardedRhs X] -> Rhs X) -> [GuardedRhs X] -> CompileError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. X -> [GuardedRhs X] -> Rhs X
forall l. l -> [GuardedRhs l] -> Rhs l
GuardedRhss X
noI ([GuardedRhs X] -> Compile JsStmt)
-> [GuardedRhs X] -> Compile JsStmt
forall a b. (a -> b) -> a -> b
$ [GuardedRhs X]
rhss

-- | Compile a lambda.
compileLambda :: [S.Pat] -> S.Exp -> Compile JsExp
compileLambda :: [Pat X] -> Exp -> Compile JsExp
compileLambda [Pat X]
pats = Exp -> Compile JsExp
compileExp (Exp -> Compile JsExp)
-> (JsExp -> Compile JsExp) -> Exp -> Compile JsExp
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \JsExp
exp -> do
  [JsStmt]
stmts <- JsExp -> Compile [JsStmt]
generateStatements JsExp
exp
  case [JsStmt]
stmts of
    [JsEarlyReturn fun :: JsExp
fun@JsFun{}] -> JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return JsExp
fun
    [JsStmt]
_ -> String -> Compile JsExp
forall a. HasCallStack => String -> a
error String
"Unexpected statements in compileLambda"

  where unhandledcase :: JsName -> JsStmt
unhandledcase = String -> JsExp -> JsStmt
throw String
"unhandled case" (JsExp -> JsStmt) -> (JsName -> JsExp) -> JsName -> JsStmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsName -> JsExp
JsName
        allfree :: Bool
allfree = (Pat X -> Bool) -> [Pat X] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Pat X -> Bool
isWildCardPat [Pat X]
pats
        generateStatements :: JsExp -> Compile [JsStmt]
generateStatements JsExp
exp =
          ([JsStmt] -> (JsName, Pat X) -> Compile [JsStmt])
-> [JsStmt] -> [(JsName, Pat X)] -> Compile [JsStmt]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\[JsStmt]
inner (JsName
param,Pat X
pat) -> do
                  [JsStmt]
stmts <- JsExp -> Pat X -> [JsStmt] -> Compile [JsStmt]
compilePat (JsName -> JsExp
JsName JsName
param) Pat X
pat [JsStmt]
inner
                  [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsExp -> JsStmt
JsEarlyReturn (Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing [JsName
param] ([JsStmt] -> [JsStmt]
deleteAfterReturn ([JsStmt] -> [JsStmt]) -> [JsStmt] -> [JsStmt]
forall a b. (a -> b) -> a -> b
$ [JsStmt]
stmts [JsStmt] -> [JsStmt] -> [JsStmt]
forall a. [a] -> [a] -> [a]
++ [JsName -> JsStmt
unhandledcase JsName
param | Bool -> Bool
not Bool
allfree]) Maybe JsExp
forall a. Maybe a
Nothing)])
                [JsExp -> JsStmt
JsEarlyReturn JsExp
exp]
                ([(JsName, Pat X)] -> [(JsName, Pat X)]
forall a. [a] -> [a]
reverse ([JsName] -> [Pat X] -> [(JsName, Pat X)]
forall a b. [a] -> [b] -> [(a, b)]
zip [JsName]
uniqueNames [Pat X]
pats))
        deleteAfterReturn :: [JsStmt] -> [JsStmt]
        deleteAfterReturn :: [JsStmt] -> [JsStmt]
deleteAfterReturn [] = []
        deleteAfterReturn (x :: JsStmt
x@(JsEarlyReturn JsExp
_):[JsStmt]
_) = [JsStmt
x]
        deleteAfterReturn (JsStmt
x:[JsStmt]
xs) = JsStmt
xJsStmt -> [JsStmt] -> [JsStmt]
forall a. a -> [a] -> [a]
:[JsStmt] -> [JsStmt]
deleteAfterReturn [JsStmt]
xs

-- | Compile [e1..] arithmetic sequences.
compileEnumFrom :: S.Exp -> Compile JsExp
compileEnumFrom :: Exp -> Compile JsExp
compileEnumFrom Exp
i = do
  JsExp
e <- Exp -> Compile JsExp
compileExp Exp
i
  JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName (QName -> JsName
JsNameVar (() -> ModuleName () -> Name -> QName
forall l. l -> ModuleName l -> Name l -> QName l
Qual () ModuleName ()
"Prelude" Name
"enumFrom"))) [JsExp
e])

-- | Compile [e1..e3] arithmetic sequences.
compileEnumFromTo :: S.Exp -> S.Exp -> Compile JsExp
compileEnumFromTo :: Exp -> Exp -> Compile JsExp
compileEnumFromTo Exp
i Exp
i' = do
  JsExp
f <- Exp -> Compile JsExp
compileExp Exp
i
  JsExp
t <- Exp -> Compile JsExp
compileExp Exp
i'
  Config
cfg <- (Config -> Config) -> Compile Config
forall a. (Config -> a) -> Compile a
config Config -> Config
forall a. a -> a
id
  JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (JsExp -> Compile JsExp) -> JsExp -> Compile JsExp
forall a b. (a -> b) -> a -> b
$ case Config -> JsExp -> JsExp -> Maybe JsExp
optEnumFromTo Config
cfg JsExp
f JsExp
t of
    Just JsExp
s -> JsExp
s
    Maybe JsExp
_ -> JsExp -> [JsExp] -> JsExp
JsApp (JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName (QName -> JsName
JsNameVar (() -> ModuleName () -> Name -> QName
forall l. l -> ModuleName l -> Name l -> QName l
Qual () ModuleName ()
"Prelude" Name
"enumFromTo"))) [JsExp
f]) [JsExp
t]

-- | Compile [e1,e2..] arithmetic sequences.
compileEnumFromThen :: S.Exp -> S.Exp -> Compile JsExp
compileEnumFromThen :: Exp -> Exp -> Compile JsExp
compileEnumFromThen Exp
a Exp
b = do
  JsExp
fr <- Exp -> Compile JsExp
compileExp Exp
a
  JsExp
th <- Exp -> Compile JsExp
compileExp Exp
b
  JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (JsExp -> [JsExp] -> JsExp
JsApp (JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName (QName -> JsName
JsNameVar (() -> ModuleName () -> Name -> QName
forall l. l -> ModuleName l -> Name l -> QName l
Qual () ModuleName ()
"Prelude" Name
"enumFromThen"))) [JsExp
fr]) [JsExp
th])

-- | Compile [e1,e2..e3] arithmetic sequences.
compileEnumFromThenTo :: S.Exp -> S.Exp -> S.Exp -> Compile JsExp
compileEnumFromThenTo :: Exp -> Exp -> Exp -> Compile JsExp
compileEnumFromThenTo Exp
a Exp
b Exp
z = do
  JsExp
fr <- Exp -> Compile JsExp
compileExp Exp
a
  JsExp
th <- Exp -> Compile JsExp
compileExp Exp
b
  JsExp
to <- Exp -> Compile JsExp
compileExp Exp
z
  Config
cfg <- (Config -> Config) -> Compile Config
forall a. (Config -> a) -> Compile a
config Config -> Config
forall a. a -> a
id
  JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (JsExp -> Compile JsExp) -> JsExp -> Compile JsExp
forall a b. (a -> b) -> a -> b
$ case Config -> JsExp -> JsExp -> JsExp -> Maybe JsExp
optEnumFromThenTo Config
cfg JsExp
fr JsExp
th JsExp
to of
    Just JsExp
s -> JsExp
s
    Maybe JsExp
_ -> JsExp -> [JsExp] -> JsExp
JsApp (JsExp -> [JsExp] -> JsExp
JsApp (JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName (QName -> JsName
JsNameVar (() -> ModuleName () -> Name -> QName
forall l. l -> ModuleName l -> Name l -> QName l
Qual () ModuleName ()
"Prelude" Name
"enumFromThenTo"))) [JsExp
fr]) [JsExp
th]) [JsExp
to]

-- | Compile a record construction with named fields
-- | GHC will warn on uninitialized fields, they will be undefined in JS.
compileRecConstr :: S.Exp -> S.QName -> [S.FieldUpdate] -> Compile JsExp
compileRecConstr :: Exp -> QName X -> [FieldUpdate X] -> Compile JsExp
compileRecConstr Exp
origExp QName X
name [FieldUpdate X]
fieldUpdates = do
  -- var obj = new $_Type()
  let unQualName :: QName
unQualName = (String -> String) -> QName -> QName
forall a. (String -> String) -> QName a -> QName a
withIdent String -> String
lowerFirst (QName -> QName) -> (QName -> QName) -> QName -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> QName
forall a. QName a -> QName a
unQualify (QName -> QName) -> QName -> QName
forall a b. (a -> b) -> a -> b
$ QName X -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn QName X
name
  QName
qname <- QName X -> Compile QName
unsafeResolveName QName X
name
  let record :: JsStmt
record = JsName -> JsExp -> JsStmt
JsVar (QName -> JsName
JsNameVar QName
unQualName) (JsName -> [JsExp] -> JsExp
JsNew (QName -> JsName
JsConstructor QName
qname) [])
  [JsStmt]
setFields <- [[JsStmt]] -> [JsStmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[JsStmt]] -> [JsStmt]) -> Compile [[JsStmt]] -> Compile [JsStmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldUpdate X]
-> (FieldUpdate X -> Compile [JsStmt]) -> Compile [[JsStmt]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FieldUpdate X]
fieldUpdates (QName X -> FieldUpdate X -> Compile [JsStmt]
forall a. QName a -> FieldUpdate X -> Compile [JsStmt]
updateStmt QName X
name)
  JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (JsExp -> Compile JsExp) -> JsExp -> Compile JsExp
forall a b. (a -> b) -> a -> b
$ JsExp -> [JsExp] -> JsExp
JsApp (Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing [] (JsStmt
recordJsStmt -> [JsStmt] -> [JsStmt]
forall a. a -> [a] -> [a]
:[JsStmt]
setFields) (JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just (JsExp -> Maybe JsExp) -> (QName -> JsExp) -> QName -> Maybe JsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsName -> JsExp
JsName (JsName -> JsExp) -> (QName -> JsName) -> QName -> JsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> JsName
JsNameVar (QName -> JsName) -> (QName -> QName) -> QName -> JsName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> QName -> QName
forall a. (String -> String) -> QName a -> QName a
withIdent String -> String
lowerFirst (QName -> QName) -> (QName -> QName) -> QName -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> QName
forall a. QName a -> QName a
unQualify (QName -> Maybe JsExp) -> QName -> Maybe JsExp
forall a b. (a -> b) -> a -> b
$ QName X -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn QName X
name)) []
  where
    -- updateStmt :: QName a -> S.FieldUpdate -> Compile [JsStmt]
    updateStmt :: QName a -> FieldUpdate X -> Compile [JsStmt]
updateStmt (QName a -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> QName
o) (FieldUpdate X
_ (QName X -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> QName
field) Exp
value) = do
      JsExp
exp <- Exp -> Compile JsExp
compileExp Exp
value
      [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [JsName -> JsName -> JsExp -> JsStmt
JsSetProp (QName -> JsName
JsNameVar (QName -> JsName) -> QName -> JsName
forall a b. (a -> b) -> a -> b
$ (String -> String) -> QName -> QName
forall a. (String -> String) -> QName a -> QName a
withIdent String -> String
lowerFirst (QName -> QName) -> QName -> QName
forall a b. (a -> b) -> a -> b
$ QName -> QName
forall a. QName a -> QName a
unQualify QName
o) (QName -> JsName
JsNameVar (QName -> JsName) -> QName -> JsName
forall a b. (a -> b) -> a -> b
$ QName -> QName
forall a. QName a -> QName a
unQualify QName
field) JsExp
exp]
    updateStmt QName a
o (FieldWildcard (X -> [QName]
forall l. Scoped l -> [QName]
wildcardFields -> [QName]
fields)) =
      [JsStmt] -> Compile [JsStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return ([JsStmt] -> Compile [JsStmt]) -> [JsStmt] -> Compile [JsStmt]
forall a b. (a -> b) -> a -> b
$ ((QName -> JsStmt) -> [QName] -> [JsStmt])
-> [QName] -> (QName -> JsStmt) -> [JsStmt]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (QName -> JsStmt) -> [QName] -> [JsStmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [QName]
fields ((QName -> JsStmt) -> [JsStmt]) -> (QName -> JsStmt) -> [JsStmt]
forall a b. (a -> b) -> a -> b
$ \QName
fieldName -> JsName -> JsName -> JsExp -> JsStmt
JsSetProp (QName -> JsName
JsNameVar (QName -> JsName) -> (QName a -> QName) -> QName a -> JsName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> QName -> QName
forall a. (String -> String) -> QName a -> QName a
withIdent String -> String
lowerFirst (QName -> QName) -> (QName a -> QName) -> QName a -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> QName
forall a. QName a -> QName a
unQualify (QName -> QName) -> (QName a -> QName) -> QName a -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName a -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn (QName a -> JsName) -> QName a -> JsName
forall a b. (a -> b) -> a -> b
$ QName a
o)
                                                    (QName -> JsName
JsNameVar QName
fieldName)
                                                    (JsName -> JsExp
JsName (JsName -> JsExp) -> JsName -> JsExp
forall a b. (a -> b) -> a -> b
$ QName -> JsName
JsNameVar QName
fieldName)
    -- I couldn't find a code that generates (FieldUpdate (FieldPun ..))
    updateStmt QName a
_ FieldUpdate X
_ = CompileError -> Compile [JsStmt]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> Compile [JsStmt])
-> CompileError -> Compile [JsStmt]
forall a b. (a -> b) -> a -> b
$ Exp -> CompileError
UnsupportedExpression Exp
origExp

    wildcardFields :: Scoped l -> [QName]
wildcardFields Scoped l
l = case Scoped l
l of
      Scoped (RecExpWildcard [(OrigName, NameInfo l)]
es) l
_ -> ((OrigName, NameInfo l) -> QName)
-> [(OrigName, NameInfo l)] -> [QName]
forall a b. (a -> b) -> [a] -> [b]
map (QName -> QName
forall a. QName a -> QName a
unQualify (QName -> QName)
-> ((OrigName, NameInfo l) -> QName)
-> (OrigName, NameInfo l)
-> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrigName -> QName
origName2QName (OrigName -> QName)
-> ((OrigName, NameInfo l) -> OrigName)
-> (OrigName, NameInfo l)
-> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OrigName, NameInfo l) -> OrigName
forall a b. (a, b) -> a
fst) [(OrigName, NameInfo l)]
es
      Scoped l
_ -> []
    lowerFirst :: String -> String
    lowerFirst :: String -> String
lowerFirst String
"" = String
""
    lowerFirst (Char
x:String
xs) = Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: Char -> Char
Char.toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs

-- | Compile a record update.
compileRecUpdate :: S.Exp -> S.Exp -> [S.FieldUpdate] -> Compile JsExp
compileRecUpdate :: Exp -> Exp -> [FieldUpdate X] -> Compile JsExp
compileRecUpdate Exp
origExp Exp
rec [FieldUpdate X]
fieldUpdates = do
  JsExp
record <- JsExp -> JsExp
force (JsExp -> JsExp) -> Compile JsExp -> Compile JsExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> Compile JsExp
compileExp Exp
rec
  let copyName :: QName
copyName = () -> Name -> QName
forall l. l -> Name l -> QName l
UnQual () (Name -> QName) -> Name -> QName
forall a b. (a -> b) -> a -> b
$ () -> String -> Name
forall l. l -> String -> Name l
Ident () String
"$_record_to_update"
      copy :: JsStmt
copy = JsName -> JsExp -> JsStmt
JsVar (QName -> JsName
JsNameVar QName
copyName)
                   (String -> JsExp
JsRawExp (String
"Object.create(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ JsExp -> String
forall a. Printable a => a -> String
printJSString JsExp
record String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"))
  [JsStmt]
setFields <- [FieldUpdate X]
-> (FieldUpdate X -> Compile JsStmt) -> Compile [JsStmt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FieldUpdate X]
fieldUpdates (QName -> FieldUpdate X -> Compile JsStmt
forall a. QName a -> FieldUpdate X -> Compile JsStmt
updateExp QName
copyName)
  JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (JsExp -> Compile JsExp) -> JsExp -> Compile JsExp
forall a b. (a -> b) -> a -> b
$ JsExp -> [JsExp] -> JsExp
JsApp (Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing [] (JsStmt
copyJsStmt -> [JsStmt] -> [JsStmt]
forall a. a -> [a] -> [a]
:[JsStmt]
setFields) (JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just (JsExp -> Maybe JsExp) -> JsExp -> Maybe JsExp
forall a b. (a -> b) -> a -> b
$ JsName -> JsExp
JsName (JsName -> JsExp) -> JsName -> JsExp
forall a b. (a -> b) -> a -> b
$ QName -> JsName
JsNameVar QName
copyName)) []
  where
    updateExp :: QName a -> S.FieldUpdate -> Compile JsStmt
    updateExp :: QName a -> FieldUpdate X -> Compile JsStmt
updateExp (QName a -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> QName
copyName) (FieldUpdate X
_ (QName -> QName
forall a. QName a -> QName a
unQualify (QName -> QName) -> (QName X -> QName) -> QName X -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName X -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> QName
field) Exp
value) =
      JsName -> JsName -> JsExp -> JsStmt
JsSetProp (QName -> JsName
JsNameVar QName
copyName) (QName -> JsName
JsNameVar QName
field) (JsExp -> JsStmt) -> Compile JsExp -> Compile JsStmt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> Compile JsExp
compileExp Exp
value
    updateExp QName a
_ f :: FieldUpdate X
f@FieldPun{} = FieldUpdate X -> Compile JsStmt
forall (f :: * -> *) l a.
(Functor f, Show (f ())) =>
f l -> Compile a
shouldBeDesugared FieldUpdate X
f
    -- I also couldn't find a code that generates (FieldUpdate FieldWildCard)
    updateExp QName a
_ FieldWildcard{} = CompileError -> Compile JsStmt
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> Compile JsStmt) -> CompileError -> Compile JsStmt
forall a b. (a -> b) -> a -> b
$ Exp -> CompileError
UnsupportedExpression Exp
origExp

-- | Make a Fay list.
makeList :: [JsExp] -> JsExp
makeList :: [JsExp] -> JsExp
makeList [JsExp]
exps = JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName (JsName -> JsExp) -> JsName -> JsExp
forall a b. (a -> b) -> a -> b
$ Name -> JsName
JsBuiltIn Name
"list") [[JsExp] -> JsExp
JsList [JsExp]
exps]

-- | Optimize short literal [e1..e3] arithmetic sequences.
optEnumFromTo :: Config -> JsExp -> JsExp -> Maybe JsExp
optEnumFromTo :: Config -> JsExp -> JsExp -> Maybe JsExp
optEnumFromTo Config
cfg (JsLit JsLit
f) (JsLit JsLit
t) =
  if Config -> Bool
configOptimize Config
cfg
  then case (JsLit
f,JsLit
t) of
    (JsInt Int
fl, JsInt Int
tl) -> (Int -> JsLit) -> Int -> Int -> Maybe JsExp
forall a.
(Enum a, Ord a, Num a) =>
(a -> JsLit) -> a -> a -> Maybe JsExp
strict Int -> JsLit
JsInt Int
fl Int
tl
    (JsFloating Double
fl, JsFloating Double
tl) -> (Double -> JsLit) -> Double -> Double -> Maybe JsExp
forall a.
(Enum a, Ord a, Num a) =>
(a -> JsLit) -> a -> a -> Maybe JsExp
strict Double -> JsLit
JsFloating Double
fl Double
tl
    (JsLit, JsLit)
_ -> Maybe JsExp
forall a. Maybe a
Nothing
  else Maybe JsExp
forall a. Maybe a
Nothing
    where strict :: (Enum a, Ord a, Num a) => (a -> JsLit) -> a -> a -> Maybe JsExp
          strict :: (a -> JsLit) -> a -> a -> Maybe JsExp
strict a -> JsLit
litfn a
fr a
to =
            if a -> Int
forall a. Enum a => a -> Int
fromEnum a
to Int -> Int -> Int
forall a. Num a => a -> a -> a
- a -> Int
forall a. Enum a => a -> Int
fromEnum a
fr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maxStrictASLen
            then JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just (JsExp -> Maybe JsExp) -> ([a] -> JsExp) -> [a] -> Maybe JsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JsExp] -> JsExp
makeList ([JsExp] -> JsExp) -> ([a] -> [JsExp]) -> [a] -> JsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> JsExp) -> [a] -> [JsExp]
forall a b. (a -> b) -> [a] -> [b]
map (JsLit -> JsExp
JsLit (JsLit -> JsExp) -> (a -> JsLit) -> a -> JsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> JsLit
litfn) ([a] -> Maybe JsExp) -> [a] -> Maybe JsExp
forall a b. (a -> b) -> a -> b
$ a -> a -> [a]
forall a. Enum a => a -> a -> [a]
enumFromTo a
fr a
to
            else Maybe JsExp
forall a. Maybe a
Nothing
optEnumFromTo Config
_ JsExp
_ JsExp
_ = Maybe JsExp
forall a. Maybe a
Nothing

-- | Optimize short literal [e1,e2..e3] arithmetic sequences.
optEnumFromThenTo :: Config -> JsExp -> JsExp -> JsExp -> Maybe JsExp
optEnumFromThenTo :: Config -> JsExp -> JsExp -> JsExp -> Maybe JsExp
optEnumFromThenTo Config
cfg (JsLit JsLit
fr) (JsLit JsLit
th) (JsLit JsLit
to) =
  if Config -> Bool
configOptimize Config
cfg
  then case (JsLit
fr,JsLit
th,JsLit
to) of
    (JsInt Int
frl, JsInt Int
thl, JsInt Int
tol) -> (Int -> JsLit) -> Int -> Int -> Int -> Maybe JsExp
forall a.
(Enum a, Ord a, Num a) =>
(a -> JsLit) -> a -> a -> a -> Maybe JsExp
strict Int -> JsLit
JsInt Int
frl Int
thl Int
tol
    (JsFloating Double
frl, JsFloating Double
thl, JsFloating Double
tol) -> (Double -> JsLit) -> Double -> Double -> Double -> Maybe JsExp
forall a.
(Enum a, Ord a, Num a) =>
(a -> JsLit) -> a -> a -> a -> Maybe JsExp
strict Double -> JsLit
JsFloating Double
frl Double
thl Double
tol
    (JsLit, JsLit, JsLit)
_ -> Maybe JsExp
forall a. Maybe a
Nothing
  else Maybe JsExp
forall a. Maybe a
Nothing
    where strict :: (Enum a, Ord a, Num a) => (a -> JsLit) -> a -> a -> a -> Maybe JsExp
          strict :: (a -> JsLit) -> a -> a -> a -> Maybe JsExp
strict a -> JsLit
litfn a
fr' a
th' a
to' =
            if (a -> Int
forall a. Enum a => a -> Int
fromEnum a
to' Int -> Int -> Int
forall a. Num a => a -> a -> a
- a -> Int
forall a. Enum a => a -> Int
fromEnum a
fr') Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div`
               (a -> Int
forall a. Enum a => a -> Int
fromEnum a
th' Int -> Int -> Int
forall a. Num a => a -> a -> a
- a -> Int
forall a. Enum a => a -> Int
fromEnum a
fr') Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maxStrictASLen
            then JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just (JsExp -> Maybe JsExp) -> ([a] -> JsExp) -> [a] -> Maybe JsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JsExp] -> JsExp
makeList ([JsExp] -> JsExp) -> ([a] -> [JsExp]) -> [a] -> JsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> JsExp) -> [a] -> [JsExp]
forall a b. (a -> b) -> [a] -> [b]
map (JsLit -> JsExp
JsLit (JsLit -> JsExp) -> (a -> JsLit) -> a -> JsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> JsLit
litfn) ([a] -> Maybe JsExp) -> [a] -> Maybe JsExp
forall a b. (a -> b) -> a -> b
$ a -> a -> a -> [a]
forall a. Enum a => a -> a -> a -> [a]
enumFromThenTo a
fr' a
th' a
to'
            else Maybe JsExp
forall a. Maybe a
Nothing
optEnumFromThenTo Config
_ JsExp
_ JsExp
_ JsExp
_ = Maybe JsExp
forall a. Maybe a
Nothing

-- | Maximum number of elements to allow in strict list representation
-- of arithmetic sequences.
maxStrictASLen :: Int
maxStrictASLen :: Int
maxStrictASLen = Int
10