-- | This module generates code in the core imperative representation from
-- elaborated PureScript code.
module Language.PureScript.CodeGen.JS
  ( module AST
  , module Common
  , moduleToJs
  ) where

import Prelude
import Protolude (ordNub)

import Control.Applicative (liftA2)
import Control.Monad (forM, replicateM, void)
import Control.Monad.Except (MonadError, throwError)
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Supply.Class (MonadSupply, freshName)
import Control.Monad.Writer (MonadWriter, runWriterT, writer)

import Data.Bifunctor (first)
import Data.List ((\\), intersect)
import Data.List.NonEmpty qualified as NEL (nonEmpty)
import Data.Foldable qualified as F
import Data.Map qualified as M
import Data.Set qualified as S
import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
import Data.Monoid (Any(..))
import Data.String (fromString)
import Data.Text (Text)
import Data.Text qualified as T

import Language.PureScript.AST.SourcePos (SourceSpan, displayStartEndPos)
import Language.PureScript.CodeGen.JS.Common as Common
import Language.PureScript.CoreImp.AST (AST, InitializerEffects(..), everywhere, everywhereTopDownM, withSourceSpan)
import Language.PureScript.CoreImp.AST qualified as AST
import Language.PureScript.CoreImp.Module qualified as AST
import Language.PureScript.CoreImp.Optimizer (optimize)
import Language.PureScript.CoreFn (Ann, Bind(..), Binder(..), CaseAlternative(..), ConstructorType(..), Expr(..), Guard, Literal(..), Meta(..), Module(..), extractAnn, extractBinderAnn, modifyAnn, removeComments)
import Language.PureScript.CoreFn.Laziness (applyLazinessTransform)
import Language.PureScript.Crash (internalError)
import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..),
                                   MultipleErrors(..), rethrow, errorMessage,
                                   errorMessage', rethrowWithPosition, addHint)
import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), Qualified(..), QualifiedBy(..), runIdent, runModuleName, showIdent, showQualified)
import Language.PureScript.Options (CodegenTarget(..), Options(..))
import Language.PureScript.PSString (PSString, mkString)
import Language.PureScript.Traversals (sndM)
import Language.PureScript.Constants.Prim qualified as C

import System.FilePath.Posix ((</>))

-- | Generate code in the simplified JavaScript intermediate representation for all declarations in a
-- module.
moduleToJs
  :: forall m
   . (MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
  => Module Ann
  -> Maybe PSString
  -> m AST.Module
moduleToJs :: forall (m :: * -> *).
(MonadReader Options m, MonadSupply m,
 MonadError MultipleErrors m) =>
Module Ann -> Maybe PSString -> m Module
moduleToJs (Module SourceSpan
_ [Comment]
coms ModuleName
mn FilePath
_ [(Ann, ModuleName)]
imps [Ident]
exps Map ModuleName [Ident]
reExps [Ident]
foreigns [Bind Ann]
decls) Maybe PSString
foreignInclude =
  forall e (m :: * -> *) a. MonadError e m => (e -> e) -> m a -> m a
rethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ModuleName -> ErrorMessageHint
ErrorInModule ModuleName
mn)) forall a b. (a -> b) -> a -> b
$ do
    let usedNames :: [Ident]
usedNames = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Bind Ann -> [Ident]
getNames [Bind Ann]
decls
    let imps' :: [ModuleName]
imps' = forall a. Ord a => [a] -> [a]
ordNub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Ann, ModuleName)]
imps
    let mnLookup :: Map ModuleName Text
mnLookup = [Ident] -> [ModuleName] -> Map ModuleName Text
renameImports [Ident]
usedNames [ModuleName]
imps'
    ([[AST]]
jsDecls, Any Bool
needRuntimeLazy) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
(MonadReader Options m, MonadSupply m, MonadWriter Any m,
 MonadError MultipleErrors m) =>
ModuleName -> Bind Ann -> m [AST]
moduleBindToJs ModuleName
mn) [Bind Ann]
decls
    [[AST]]
optimized <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AST -> AST
annotatePure)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadSupply m =>
[Text] -> [[AST]] -> m [[AST]]
optimize (forall a b. (a -> b) -> [a] -> [b]
map Ident -> Text
identToJs [Ident]
exps) forall a b. (a -> b) -> a -> b
$ if Bool
needRuntimeLazy then [AST
runtimeLazy] forall a. a -> [a] -> [a]
: [[AST]]
jsDecls else [[AST]]
jsDecls
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
F.traverse_ (forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
F.traverse_ AST -> m ()
checkIntegers) [[AST]]
optimized
    Bool
comments <- Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Options -> Bool
optionsNoComments
    let header :: [Comment]
header = if Bool
comments then [Comment]
coms else []
    let foreign' :: [Import]
foreign' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PSString -> Import
AST.Import Text
FFINamespace) forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ident]
foreigns then forall a. Maybe a
Nothing else Maybe PSString
foreignInclude
    let moduleBody :: [AST]
moduleBody = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[AST]]
optimized
    let (forall a. Ord a => Set a -> Set a -> Set a
S.union (forall k a. Map k a -> Set k
M.keysSet Map ModuleName [Ident]
reExps) -> Set ModuleName
usedModuleNames, [AST]
renamedModuleBody) = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Map ModuleName Text -> AST -> (Set ModuleName, AST)
replaceModuleAccessors Map ModuleName Text
mnLookup) [AST]
moduleBody
    let jsImports :: [Import]
jsImports
          = forall a b. (a -> b) -> [a] -> [b]
map (Map ModuleName Text -> ModuleName -> Import
importToJs Map ModuleName Text
mnLookup)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> Set a -> Bool
S.member Set ModuleName
usedModuleNames)
          forall a b. (a -> b) -> a -> b
$ (forall a. Eq a => [a] -> [a] -> [a]
\\ (ModuleName
mn forall a. a -> [a] -> [a]
: [ModuleName]
C.primModules)) [ModuleName]
imps'
    let foreignExps :: [Ident]
foreignExps = [Ident]
exps forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Ident]
foreigns
    let standardExps :: [Ident]
standardExps = [Ident]
exps forall a. Eq a => [a] -> [a] -> [a]
\\ [Ident]
foreignExps
    let reExps' :: [(ModuleName, [Ident])]
reExps' = forall k a. Map k a -> [(k, a)]
M.toList (forall k a. Ord k => Map k a -> Set k -> Map k a
M.withoutKeys Map ModuleName [Ident]
reExps (forall a. Ord a => [a] -> Set a
S.fromList [ModuleName]
C.primModules))
    let jsExports :: [Export]
jsExports
          =  (forall a. Maybe a -> [a]
maybeToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe PSString -> [Ident] -> Maybe Export
exportsToJs Maybe PSString
foreignInclude forall a b. (a -> b) -> a -> b
$ [Ident]
foreignExps)
          forall a. [a] -> [a] -> [a]
++ (forall a. Maybe a -> [a]
maybeToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe PSString -> [Ident] -> Maybe Export
exportsToJs forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ [Ident]
standardExps)
          forall a. [a] -> [a] -> [a]
++  forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (ModuleName, [Ident]) -> Maybe Export
reExportsToJs [(ModuleName, [Ident])]
reExps'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Comment] -> [Import] -> [AST] -> [Export] -> Module
AST.Module [Comment]
header ([Import]
foreign' forall a. [a] -> [a] -> [a]
++ [Import]
jsImports) [AST]
renamedModuleBody [Export]
jsExports

  where
  -- Adds purity annotations to top-level values for bundlers.
  -- The semantics here derive from treating top-level module evaluation as pure, which lets
  -- us remove any unreferenced top-level declarations. To achieve this, we wrap any non-trivial
  -- top-level values in an IIFE marked with a pure annotation.
  annotatePure :: AST -> AST
  annotatePure :: AST -> AST
annotatePure = AST -> AST
annotateOrWrap
    where
    annotateOrWrap :: AST -> AST
annotateOrWrap = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. a -> Maybe a -> a
fromMaybe AST -> AST
pureIife AST -> Maybe AST
maybePure

    -- If the JS is potentially effectful (in the eyes of a bundler that
    -- doesn't know about PureScript), return Nothing. Otherwise, return Just
    -- the JS with any needed pure annotations added, and, in the case of a
    -- variable declaration, an IIFE to be annotated.
    maybePure :: AST -> Maybe AST
    maybePure :: AST -> Maybe AST
maybePure = Bool -> AST -> Maybe AST
maybePureGen Bool
False

    -- Like maybePure, but doesn't add a pure annotation to App. This exists
    -- to prevent from doubling up on annotation comments on curried
    -- applications; from experimentation, it turns out that a comment on the
    -- outermost App is sufficient for the entire curried chain to be
    -- considered effect-free.
    maybePure' :: AST -> Maybe AST
    maybePure' :: AST -> Maybe AST
maybePure' = Bool -> AST -> Maybe AST
maybePureGen Bool
True

    maybePureGen :: Bool -> AST -> Maybe AST
maybePureGen Bool
alreadyAnnotated = \case
      AST.VariableIntroduction Maybe SourceSpan
ss Text
name Maybe (InitializerEffects, AST)
j -> forall a. a -> Maybe a
Just (Maybe SourceSpan -> Text -> Maybe (InitializerEffects, AST) -> AST
AST.VariableIntroduction Maybe SourceSpan
ss Text
name (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AST -> AST
annotateOrWrap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (InitializerEffects, AST)
j))
      AST.App Maybe SourceSpan
ss AST
f [AST]
args -> (if Bool
alreadyAnnotated then Maybe SourceSpan -> AST -> [AST] -> AST
AST.App else Maybe SourceSpan -> AST -> [AST] -> AST
pureApp) Maybe SourceSpan
ss forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AST -> Maybe AST
maybePure' AST
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse AST -> Maybe AST
maybePure [AST]
args
      AST.ArrayLiteral Maybe SourceSpan
ss [AST]
jss -> Maybe SourceSpan -> [AST] -> AST
AST.ArrayLiteral Maybe SourceSpan
ss forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse AST -> Maybe AST
maybePure [AST]
jss
      AST.ObjectLiteral Maybe SourceSpan
ss [(PSString, AST)]
props -> Maybe SourceSpan -> [(PSString, AST)] -> AST
AST.ObjectLiteral Maybe SourceSpan
ss forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse AST -> Maybe AST
maybePure) [(PSString, AST)]
props
      AST.Comment CIComments
c AST
js -> CIComments -> AST -> AST
AST.Comment CIComments
c forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AST -> Maybe AST
maybePure AST
js

      js :: AST
js@(AST.Indexer Maybe SourceSpan
_ AST
_ (AST.Var Maybe SourceSpan
_ Text
FFINamespace)) -> forall a. a -> Maybe a
Just AST
js

      js :: AST
js@AST.NumericLiteral{} -> forall a. a -> Maybe a
Just AST
js
      js :: AST
js@AST.StringLiteral{}  -> forall a. a -> Maybe a
Just AST
js
      js :: AST
js@AST.BooleanLiteral{} -> forall a. a -> Maybe a
Just AST
js
      js :: AST
js@AST.Function{}       -> forall a. a -> Maybe a
Just AST
js
      js :: AST
js@AST.Var{}            -> forall a. a -> Maybe a
Just AST
js
      js :: AST
js@AST.ModuleAccessor{} -> forall a. a -> Maybe a
Just AST
js

      AST
_ -> forall a. Maybe a
Nothing

    pureIife :: AST -> AST
    pureIife :: AST -> AST
pureIife AST
val = Maybe SourceSpan -> AST -> [AST] -> AST
pureApp forall a. Maybe a
Nothing (Maybe SourceSpan -> Maybe Text -> [Text] -> AST -> AST
AST.Function forall a. Maybe a
Nothing forall a. Maybe a
Nothing [] (Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing [Maybe SourceSpan -> AST -> AST
AST.Return forall a. Maybe a
Nothing AST
val])) []

    pureApp :: Maybe SourceSpan -> AST -> [AST] -> AST
    pureApp :: Maybe SourceSpan -> AST -> [AST] -> AST
pureApp Maybe SourceSpan
ss AST
f = CIComments -> AST -> AST
AST.Comment CIComments
AST.PureAnnotation forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SourceSpan -> AST -> [AST] -> AST
AST.App Maybe SourceSpan
ss AST
f

  -- Extracts all declaration names from a binding group.
  getNames :: Bind Ann -> [Ident]
  getNames :: Bind Ann -> [Ident]
getNames (NonRec Ann
_ Ident
ident Expr Ann
_) = [Ident
ident]
  getNames (Rec [((Ann, Ident), Expr Ann)]
vals) = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [((Ann, Ident), Expr Ann)]
vals

  -- Creates alternative names for each module to ensure they don't collide
  -- with declaration names.
  renameImports :: [Ident] -> [ModuleName] -> M.Map ModuleName Text
  renameImports :: [Ident] -> [ModuleName] -> Map ModuleName Text
renameImports = Map ModuleName Text
-> [Ident] -> [ModuleName] -> Map ModuleName Text
go forall k a. Map k a
M.empty
    where
    go :: M.Map ModuleName Text -> [Ident] -> [ModuleName] -> M.Map ModuleName Text
    go :: Map ModuleName Text
-> [Ident] -> [ModuleName] -> Map ModuleName Text
go Map ModuleName Text
acc [Ident]
used (ModuleName
mn' : [ModuleName]
mns') =
      let mnj :: Text
mnj = ModuleName -> Text
moduleNameToJs ModuleName
mn'
      in if ModuleName
mn' forall a. Eq a => a -> a -> Bool
/= ModuleName
mn Bool -> Bool -> Bool
&& Text -> Ident
Ident Text
mnj forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Ident]
used
         then let newName :: Text
newName = Integer -> Text -> [Ident] -> Text
freshModuleName Integer
1 Text
mnj [Ident]
used
              in Map ModuleName Text
-> [Ident] -> [ModuleName] -> Map ModuleName Text
go (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ModuleName
mn' Text
newName Map ModuleName Text
acc) (Text -> Ident
Ident Text
newName forall a. a -> [a] -> [a]
: [Ident]
used) [ModuleName]
mns'
         else Map ModuleName Text
-> [Ident] -> [ModuleName] -> Map ModuleName Text
go (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ModuleName
mn' Text
mnj Map ModuleName Text
acc) [Ident]
used [ModuleName]
mns'
    go Map ModuleName Text
acc [Ident]
_ [] = Map ModuleName Text
acc

    freshModuleName :: Integer -> Text -> [Ident] -> Text
    freshModuleName :: Integer -> Text -> [Ident] -> Text
freshModuleName Integer
i Text
mn' [Ident]
used =
      let newName :: Text
newName = Text
mn' forall a. Semigroup a => a -> a -> a
<> Text
"_" forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Integer
i)
      in if Text -> Ident
Ident Text
newName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Ident]
used
         then Integer -> Text -> [Ident] -> Text
freshModuleName (Integer
i forall a. Num a => a -> a -> a
+ Integer
1) Text
mn' [Ident]
used
         else Text
newName

  -- Generates JavaScript code for a module import, binding the required module
  -- to the alternative
  importToJs :: M.Map ModuleName Text -> ModuleName -> AST.Import
  importToJs :: Map ModuleName Text -> ModuleName -> Import
importToJs Map ModuleName Text
mnLookup ModuleName
mn' =
    let mnSafe :: Text
mnSafe = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => FilePath -> a
internalError FilePath
"Missing value in mnLookup") forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModuleName
mn' Map ModuleName Text
mnLookup
    in Text -> PSString -> Import
AST.Import Text
mnSafe (ModuleName -> PSString
moduleImportPath ModuleName
mn')

  -- Generates JavaScript code for exporting at least one identifier,
  -- eventually from another module.
  exportsToJs :: Maybe PSString -> [Ident] -> Maybe AST.Export
  exportsToJs :: Maybe PSString -> [Ident] -> Maybe Export
exportsToJs Maybe PSString
from = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip NonEmpty Text -> Maybe PSString -> Export
AST.Export Maybe PSString
from) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ident -> Text
runIdent

  -- Generates JavaScript code for re-exporting at least one identifier from
  -- from another module.
  reExportsToJs :: (ModuleName, [Ident]) -> Maybe AST.Export
  reExportsToJs :: (ModuleName, [Ident]) -> Maybe Export
reExportsToJs = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe PSString -> [Ident] -> Maybe Export
exportsToJs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> PSString
moduleImportPath)

  moduleImportPath :: ModuleName -> PSString
  moduleImportPath :: ModuleName -> PSString
moduleImportPath ModuleName
mn' = forall a. IsString a => FilePath -> a
fromString (FilePath
".." FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack (ModuleName -> Text
runModuleName ModuleName
mn') FilePath -> FilePath -> FilePath
</> FilePath
"index.js")

  -- Replaces the `ModuleAccessor`s in the AST with `Indexer`s, ensuring that
  -- the generated code refers to the collision-avoiding renamed module
  -- imports. Also returns set of used module names.
  replaceModuleAccessors :: M.Map ModuleName Text -> AST -> (S.Set ModuleName, AST)
  replaceModuleAccessors :: Map ModuleName Text -> AST -> (Set ModuleName, AST)
replaceModuleAccessors Map ModuleName Text
mnLookup = forall (m :: * -> *). Monad m => (AST -> m AST) -> AST -> m AST
everywhereTopDownM forall a b. (a -> b) -> a -> b
$ \case
    AST.ModuleAccessor Maybe SourceSpan
_ ModuleName
mn' PSString
name ->
      let mnSafe :: Text
mnSafe = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => FilePath -> a
internalError FilePath
"Missing value in mnLookup") forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModuleName
mn' Map ModuleName Text
mnLookup
      in (forall a. a -> Set a
S.singleton ModuleName
mn', PSString -> AST -> AST
accessorString PSString
name forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
mnSafe)
    AST
other -> forall (f :: * -> *) a. Applicative f => a -> f a
pure AST
other

  -- Check that all integers fall within the valid int range for JavaScript.
  checkIntegers :: AST -> m ()
  checkIntegers :: AST -> m ()
checkIntegers = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Monad m => (AST -> m AST) -> AST -> m AST
everywhereTopDownM AST -> m AST
go
    where
    go :: AST -> m AST
    go :: AST -> m AST
go (AST.Unary Maybe SourceSpan
_ UnaryOperator
AST.Negate (AST.NumericLiteral Maybe SourceSpan
ss (Left Integer
i))) =
      -- Move the negation inside the literal; since this is a top-down
      -- traversal doing this replacement will stop the next case from raising
      -- the error when attempting to use -2147483648, as if left unrewritten
      -- the value is `Unary Negate (NumericLiteral (Left 2147483648))`, and
      -- 2147483648 is larger than the maximum allowed int.
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> Either Integer Double -> AST
AST.NumericLiteral Maybe SourceSpan
ss (forall a b. a -> Either a b
Left (-Integer
i))
    go js :: AST
js@(AST.NumericLiteral Maybe SourceSpan
ss (Left Integer
i)) =
      let minInt :: Integer
minInt = -Integer
2147483648
          maxInt :: Integer
maxInt = Integer
2147483647
      in if Integer
i forall a. Ord a => a -> a -> Bool
< Integer
minInt Bool -> Bool -> Bool
|| Integer
i forall a. Ord a => a -> a -> Bool
> Integer
maxInt
         then forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe SimpleErrorMessage -> MultipleErrors
errorMessage SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' Maybe SourceSpan
ss forall a b. (a -> b) -> a -> b
$ Integer -> Text -> Integer -> Integer -> SimpleErrorMessage
IntOutOfRange Integer
i Text
"JavaScript" Integer
minInt Integer
maxInt
         else forall (m :: * -> *) a. Monad m => a -> m a
return AST
js
    go AST
other = forall (m :: * -> *) a. Monad m => a -> m a
return AST
other

  runtimeLazy :: AST
  runtimeLazy :: AST
runtimeLazy =
    Maybe SourceSpan -> Text -> Maybe (InitializerEffects, AST) -> AST
AST.VariableIntroduction forall a. Maybe a
Nothing Text
"$runtime_lazy" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InitializerEffects
UnknownEffects, ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SourceSpan -> Maybe Text -> [Text] -> AST -> AST
AST.Function forall a. Maybe a
Nothing forall a. Maybe a
Nothing [Text
"name", Text
"moduleName", Text
"init"] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
      [ Maybe SourceSpan -> Text -> Maybe (InitializerEffects, AST) -> AST
AST.VariableIntroduction forall a. Maybe a
Nothing Text
"state" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InitializerEffects
UnknownEffects, ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SourceSpan -> Either Integer Double -> AST
AST.NumericLiteral forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Integer
0
      , Maybe SourceSpan -> Text -> Maybe (InitializerEffects, AST) -> AST
AST.VariableIntroduction forall a. Maybe a
Nothing Text
"val" forall a. Maybe a
Nothing
      , Maybe SourceSpan -> AST -> AST
AST.Return forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SourceSpan -> Maybe Text -> [Text] -> AST -> AST
AST.Function forall a. Maybe a
Nothing forall a. Maybe a
Nothing [Text
"lineNumber"] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
        [ Maybe SourceSpan -> AST -> AST -> Maybe AST -> AST
AST.IfElse forall a. Maybe a
Nothing (Maybe SourceSpan -> BinaryOperator -> AST -> AST -> AST
AST.Binary forall a. Maybe a
Nothing BinaryOperator
AST.EqualTo (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
"state") (Maybe SourceSpan -> Either Integer Double -> AST
AST.NumericLiteral forall a. Maybe a
Nothing (forall a b. a -> Either a b
Left Integer
2))) (Maybe SourceSpan -> AST -> AST
AST.Return forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
"val") forall a. Maybe a
Nothing
        , Maybe SourceSpan -> AST -> AST -> Maybe AST -> AST
AST.IfElse forall a. Maybe a
Nothing (Maybe SourceSpan -> BinaryOperator -> AST -> AST -> AST
AST.Binary forall a. Maybe a
Nothing BinaryOperator
AST.EqualTo (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
"state") (Maybe SourceSpan -> Either Integer Double -> AST
AST.NumericLiteral forall a. Maybe a
Nothing (forall a b. a -> Either a b
Left Integer
1))) (Maybe SourceSpan -> AST -> AST
AST.Throw forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> UnaryOperator -> AST -> AST
AST.Unary forall a. Maybe a
Nothing UnaryOperator
AST.New (Maybe SourceSpan -> AST -> [AST] -> AST
AST.App forall a. Maybe a
Nothing (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
"ReferenceError") [forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (Maybe SourceSpan -> BinaryOperator -> AST -> AST -> AST
AST.Binary forall a. Maybe a
Nothing BinaryOperator
AST.Add)
          [ Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
"name"
          , Maybe SourceSpan -> PSString -> AST
AST.StringLiteral forall a. Maybe a
Nothing PSString
" was needed before it finished initializing (module "
          , Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
"moduleName"
          , Maybe SourceSpan -> PSString -> AST
AST.StringLiteral forall a. Maybe a
Nothing PSString
", line "
          , Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
"lineNumber"
          , Maybe SourceSpan -> PSString -> AST
AST.StringLiteral forall a. Maybe a
Nothing PSString
")"
          ], Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
"moduleName", Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
"lineNumber"])) forall a. Maybe a
Nothing
        , Maybe SourceSpan -> AST -> AST -> AST
AST.Assignment forall a. Maybe a
Nothing (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
"state") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SourceSpan -> Either Integer Double -> AST
AST.NumericLiteral forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Integer
1
        , Maybe SourceSpan -> AST -> AST -> AST
AST.Assignment forall a. Maybe a
Nothing (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
"val") forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> AST -> [AST] -> AST
AST.App forall a. Maybe a
Nothing (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
"init") []
        , Maybe SourceSpan -> AST -> AST -> AST
AST.Assignment forall a. Maybe a
Nothing (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
"state") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SourceSpan -> Either Integer Double -> AST
AST.NumericLiteral forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Integer
2
        , Maybe SourceSpan -> AST -> AST
AST.Return forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
"val"
        ]
      ]


moduleBindToJs
  :: forall m
   . (MonadReader Options m, MonadSupply m, MonadWriter Any m, MonadError MultipleErrors m)
  => ModuleName
  -> Bind Ann
  -> m [AST]
moduleBindToJs :: forall (m :: * -> *).
(MonadReader Options m, MonadSupply m, MonadWriter Any m,
 MonadError MultipleErrors m) =>
ModuleName -> Bind Ann -> m [AST]
moduleBindToJs ModuleName
mn = Bind Ann -> m [AST]
bindToJs
  where
  -- Generate code in the simplified JavaScript intermediate representation for a declaration
  bindToJs :: Bind Ann -> m [AST]
  bindToJs :: Bind Ann -> m [AST]
bindToJs (NonRec (SourceSpan
_, [Comment]
_, Just Meta
IsTypeClassConstructor) Ident
_ Expr Ann
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    -- Unlike other newtype constructors, type class constructors are only
    -- ever applied; it's not possible to use them as values. So it's safe to
    -- erase them.
  bindToJs (NonRec Ann
ann Ident
ident Expr Ann
val) = forall (m :: * -> *) a. Monad m => a -> m a
return forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ann -> Ident -> Expr Ann -> m AST
nonRecToJS Ann
ann Ident
ident Expr Ann
val
  bindToJs (Rec [((Ann, Ident), Expr Ann)]
vals) = forall w (m :: * -> *) a. MonadWriter w m => (a, w) -> m a
writer (ModuleName
-> [((Ann, Ident), Expr Ann)] -> ([((Ann, Ident), Expr Ann)], Any)
applyLazinessTransform ModuleName
mn [((Ann, Ident), Expr Ann)]
vals) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ Ann -> Ident -> Expr Ann -> m AST
nonRecToJS)

  -- Generate code in the simplified JavaScript intermediate representation for a single non-recursive
  -- declaration.
  --
  -- The main purpose of this function is to handle code generation for comments.
  nonRecToJS :: Ann -> Ident -> Expr Ann -> m AST
  nonRecToJS :: Ann -> Ident -> Expr Ann -> m AST
nonRecToJS Ann
a Ident
i e :: Expr Ann
e@(forall a. Expr a -> a
extractAnn -> (SourceSpan
_, [Comment]
com, Maybe Meta
_)) | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Comment]
com) = do
    Bool
withoutComment <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Options -> Bool
optionsNoComments
    if Bool
withoutComment
       then Ann -> Ident -> Expr Ann -> m AST
nonRecToJS Ann
a Ident
i (forall a. (a -> a) -> Expr a -> Expr a
modifyAnn Ann -> Ann
removeComments Expr Ann
e)
       else CIComments -> AST -> AST
AST.Comment ([Comment] -> CIComments
AST.SourceComments [Comment]
com) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ann -> Ident -> Expr Ann -> m AST
nonRecToJS Ann
a Ident
i (forall a. (a -> a) -> Expr a -> Expr a
modifyAnn Ann -> Ann
removeComments Expr Ann
e)
  nonRecToJS (SourceSpan
ss, [Comment]
_, Maybe Meta
_) Ident
ident Expr Ann
val = do
    AST
js <- Expr Ann -> m AST
valueToJs Expr Ann
val
    SourceSpan -> AST -> m AST
withPos SourceSpan
ss forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> Text -> Maybe (InitializerEffects, AST) -> AST
AST.VariableIntroduction forall a. Maybe a
Nothing (Ident -> Text
identToJs Ident
ident) (forall a. a -> Maybe a
Just (Expr Ann -> InitializerEffects
guessEffects Expr Ann
val, AST
js))

  guessEffects :: Expr Ann -> AST.InitializerEffects
  guessEffects :: Expr Ann -> InitializerEffects
guessEffects = \case
    Var Ann
_ (Qualified (BySourcePos SourcePos
_) Ident
_) -> InitializerEffects
NoEffects
    App (SourceSpan
_, [Comment]
_, Just Meta
IsSyntheticApp) Expr Ann
_ Expr Ann
_ -> InitializerEffects
NoEffects
    Expr Ann
_                                   -> InitializerEffects
UnknownEffects

  withPos :: SourceSpan -> AST -> m AST
  withPos :: SourceSpan -> AST -> m AST
withPos SourceSpan
ss AST
js = do
    Bool
withSM <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem CodegenTarget
JSSourceMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Set CodegenTarget
optionsCodegenTargets)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
withSM
      then SourceSpan -> AST -> AST
withSourceSpan SourceSpan
ss AST
js
      else AST
js

  -- Generate code in the simplified JavaScript intermediate representation for a variable based on a
  -- PureScript identifier.
  var :: Ident -> AST
  var :: Ident -> AST
var = Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
identToJs

  -- Generate code in the simplified JavaScript intermediate representation for a value or expression.
  valueToJs :: Expr Ann -> m AST
  valueToJs :: Expr Ann -> m AST
valueToJs Expr Ann
e =
    let (SourceSpan
ss, [Comment]
_, Maybe Meta
_) = forall a. Expr a -> a
extractAnn Expr Ann
e in
    SourceSpan -> AST -> m AST
withPos SourceSpan
ss forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr Ann -> m AST
valueToJs' Expr Ann
e

  valueToJs' :: Expr Ann -> m AST
  valueToJs' :: Expr Ann -> m AST
valueToJs' (Literal (SourceSpan
pos, [Comment]
_, Maybe Meta
_) Literal (Expr Ann)
l) =
    forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> m a -> m a
rethrowWithPosition SourceSpan
pos forall a b. (a -> b) -> a -> b
$ SourceSpan -> Literal (Expr Ann) -> m AST
literalToValueJS SourceSpan
pos Literal (Expr Ann)
l
  valueToJs' (Var (SourceSpan
_, [Comment]
_, Just (IsConstructor ConstructorType
_ [])) Qualified Ident
name) =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PSString -> AST -> AST
accessorString PSString
"value" forall a b. (a -> b) -> a -> b
$ forall a. (a -> Ident) -> Qualified a -> AST
qualifiedToJS forall a. a -> a
id Qualified Ident
name
  valueToJs' (Var (SourceSpan
_, [Comment]
_, Just (IsConstructor ConstructorType
_ [Ident]
_)) Qualified Ident
name) =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PSString -> AST -> AST
accessorString PSString
"create" forall a b. (a -> b) -> a -> b
$ forall a. (a -> Ident) -> Qualified a -> AST
qualifiedToJS forall a. a -> a
id Qualified Ident
name
  valueToJs' (Accessor Ann
_ PSString
prop Expr Ann
val) =
    PSString -> AST -> AST
accessorString PSString
prop forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Ann -> m AST
valueToJs Expr Ann
val
  valueToJs' (ObjectUpdate (SourceSpan
pos, [Comment]
_, Maybe Meta
_) Expr Ann
o Maybe [PSString]
copy [(PSString, Expr Ann)]
ps) = do
    AST
obj <- Expr Ann -> m AST
valueToJs Expr Ann
o
    [(PSString, AST)]
sts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) b c a.
Functor f =>
(b -> f c) -> (a, b) -> f (a, c)
sndM Expr Ann -> m AST
valueToJs) [(PSString, Expr Ann)]
ps
    case Maybe [PSString]
copy of
      Maybe [PSString]
Nothing -> AST -> [(PSString, AST)] -> m AST
extendObj AST
obj [(PSString, AST)]
sts
      Just [PSString]
names -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> [(PSString, AST)] -> AST
AST.ObjectLiteral (forall a. a -> Maybe a
Just SourceSpan
pos) (forall a b. (a -> b) -> [a] -> [b]
map PSString -> (PSString, AST)
f [PSString]
names forall a. [a] -> [a] -> [a]
++ [(PSString, AST)]
sts)
        where f :: PSString -> (PSString, AST)
f PSString
name = (PSString
name, PSString -> AST -> AST
accessorString PSString
name AST
obj)
  valueToJs' (Abs Ann
_ Ident
arg Expr Ann
val) = do
    AST
ret <- Expr Ann -> m AST
valueToJs Expr Ann
val
    let jsArg :: [Text]
jsArg = case Ident
arg of
                  Ident
UnusedIdent -> []
                  Ident
_           -> [Ident -> Text
identToJs Ident
arg]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> Maybe Text -> [Text] -> AST -> AST
AST.Function forall a. Maybe a
Nothing forall a. Maybe a
Nothing [Text]
jsArg (Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing [Maybe SourceSpan -> AST -> AST
AST.Return forall a. Maybe a
Nothing AST
ret])
  valueToJs' e :: Expr Ann
e@App{} = do
    let (Expr Ann
f, [Expr Ann]
args) = Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
unApp Expr Ann
e []
    [AST]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr Ann -> m AST
valueToJs [Expr Ann]
args
    case Expr Ann
f of
      Var (SourceSpan
_, [Comment]
_, Just Meta
IsNewtype) Qualified Ident
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> a
head [AST]
args')
      Var (SourceSpan
_, [Comment]
_, Just (IsConstructor ConstructorType
_ [Ident]
fields)) Qualified Ident
name | forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr Ann]
args forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ident]
fields ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> UnaryOperator -> AST -> AST
AST.Unary forall a. Maybe a
Nothing UnaryOperator
AST.New forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> AST -> [AST] -> AST
AST.App forall a. Maybe a
Nothing (forall a. (a -> Ident) -> Qualified a -> AST
qualifiedToJS forall a. a -> a
id Qualified Ident
name) [AST]
args'
      Expr Ann
_ -> forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\AST
fn AST
a -> Maybe SourceSpan -> AST -> [AST] -> AST
AST.App forall a. Maybe a
Nothing AST
fn [AST
a])) [AST]
args' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Ann -> m AST
valueToJs Expr Ann
f
    where
    unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
    unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
unApp (App Ann
_ Expr Ann
val Expr Ann
arg) [Expr Ann]
args = Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
unApp Expr Ann
val (Expr Ann
arg forall a. a -> [a] -> [a]
: [Expr Ann]
args)
    unApp Expr Ann
other [Expr Ann]
args = (Expr Ann
other, [Expr Ann]
args)
  valueToJs' (Var (SourceSpan
_, [Comment]
_, Just Meta
IsForeign) qi :: Qualified Ident
qi@(Qualified (ByModuleName ModuleName
mn') Ident
ident)) =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if ModuleName
mn' forall a. Eq a => a -> a -> Bool
== ModuleName
mn
             then Ident -> AST
foreignIdent Ident
ident
             else Qualified Ident -> AST
varToJs Qualified Ident
qi
  valueToJs' (Var (SourceSpan
_, [Comment]
_, Just Meta
IsForeign) Qualified Ident
ident) =
    forall a. HasCallStack => FilePath -> a
internalError forall a b. (a -> b) -> a -> b
$ FilePath
"Encountered an unqualified reference to a foreign ident " forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack (forall a. (a -> Text) -> Qualified a -> Text
showQualified Ident -> Text
showIdent Qualified Ident
ident)
  valueToJs' (Var Ann
_ Qualified Ident
ident) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Qualified Ident -> AST
varToJs Qualified Ident
ident
  valueToJs' (Case (SourceSpan
ss, [Comment]
_, Maybe Meta
_) [Expr Ann]
values [CaseAlternative Ann]
binders) = do
    [AST]
vals <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr Ann -> m AST
valueToJs [Expr Ann]
values
    SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
bindersToJs SourceSpan
ss [CaseAlternative Ann]
binders [AST]
vals
  valueToJs' (Let Ann
_ [Bind Ann]
ds Expr Ann
val) = do
    [AST]
ds' <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Bind Ann -> m [AST]
bindToJs [Bind Ann]
ds
    AST
ret <- Expr Ann -> m AST
valueToJs Expr Ann
val
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> AST -> [AST] -> AST
AST.App forall a. Maybe a
Nothing (Maybe SourceSpan -> Maybe Text -> [Text] -> AST -> AST
AST.Function forall a. Maybe a
Nothing forall a. Maybe a
Nothing [] (Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing ([AST]
ds' forall a. [a] -> [a] -> [a]
++ [Maybe SourceSpan -> AST -> AST
AST.Return forall a. Maybe a
Nothing AST
ret]))) []
  valueToJs' (Constructor (SourceSpan
_, [Comment]
_, Just Meta
IsNewtype) ProperName 'TypeName
_ ProperName 'ConstructorName
ctor [Ident]
_) =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> Text -> Maybe (InitializerEffects, AST) -> AST
AST.VariableIntroduction forall a. Maybe a
Nothing (forall (a :: ProperNameType). ProperName a -> Text
properToJs ProperName 'ConstructorName
ctor) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InitializerEffects
UnknownEffects, ) forall a b. (a -> b) -> a -> b
$
                Maybe SourceSpan -> [(PSString, AST)] -> AST
AST.ObjectLiteral forall a. Maybe a
Nothing [(PSString
"create",
                  Maybe SourceSpan -> Maybe Text -> [Text] -> AST -> AST
AST.Function forall a. Maybe a
Nothing forall a. Maybe a
Nothing [Text
"value"]
                    (Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing [Maybe SourceSpan -> AST -> AST
AST.Return forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
"value"]))])
  valueToJs' (Constructor Ann
_ ProperName 'TypeName
_ ProperName 'ConstructorName
ctor []) =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> [AST] -> AST
iife (forall (a :: ProperNameType). ProperName a -> Text
properToJs ProperName 'ConstructorName
ctor) [ Maybe SourceSpan -> Maybe Text -> [Text] -> AST -> AST
AST.Function forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just (forall (a :: ProperNameType). ProperName a -> Text
properToJs ProperName 'ConstructorName
ctor)) [] (Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing [])
           , Maybe SourceSpan -> AST -> AST -> AST
AST.Assignment forall a. Maybe a
Nothing (PSString -> AST -> AST
accessorString PSString
"value" (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing (forall (a :: ProperNameType). ProperName a -> Text
properToJs ProperName 'ConstructorName
ctor)))
                (Maybe SourceSpan -> UnaryOperator -> AST -> AST
AST.Unary forall a. Maybe a
Nothing UnaryOperator
AST.New forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> AST -> [AST] -> AST
AST.App forall a. Maybe a
Nothing (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing (forall (a :: ProperNameType). ProperName a -> Text
properToJs ProperName 'ConstructorName
ctor)) []) ]
  valueToJs' (Constructor Ann
_ ProperName 'TypeName
_ ProperName 'ConstructorName
ctor [Ident]
fields) =
    let constructor :: AST
constructor =
          let body :: [AST]
body = [ Maybe SourceSpan -> AST -> AST -> AST
AST.Assignment forall a. Maybe a
Nothing ((PSString -> AST -> AST
accessorString forall a b. (a -> b) -> a -> b
$ Text -> PSString
mkString forall a b. (a -> b) -> a -> b
$ Ident -> Text
identToJs Ident
f) (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
"this")) (Ident -> AST
var Ident
f) | Ident
f <- [Ident]
fields ]
          in Maybe SourceSpan -> Maybe Text -> [Text] -> AST -> AST
AST.Function forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just (forall (a :: ProperNameType). ProperName a -> Text
properToJs ProperName 'ConstructorName
ctor)) (Ident -> Text
identToJs forall a b. (a -> b) -> [a] -> [b]
`map` [Ident]
fields) (Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing [AST]
body)
        createFn :: AST
createFn =
          let body :: AST
body = Maybe SourceSpan -> UnaryOperator -> AST -> AST
AST.Unary forall a. Maybe a
Nothing UnaryOperator
AST.New forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> AST -> [AST] -> AST
AST.App forall a. Maybe a
Nothing (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing (forall (a :: ProperNameType). ProperName a -> Text
properToJs ProperName 'ConstructorName
ctor)) (Ident -> AST
var forall a b. (a -> b) -> [a] -> [b]
`map` [Ident]
fields)
          in forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Ident
f AST
inner -> Maybe SourceSpan -> Maybe Text -> [Text] -> AST -> AST
AST.Function forall a. Maybe a
Nothing forall a. Maybe a
Nothing [Ident -> Text
identToJs Ident
f] (Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing [Maybe SourceSpan -> AST -> AST
AST.Return forall a. Maybe a
Nothing AST
inner])) AST
body [Ident]
fields
    in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> [AST] -> AST
iife (forall (a :: ProperNameType). ProperName a -> Text
properToJs ProperName 'ConstructorName
ctor) [ AST
constructor
                          , Maybe SourceSpan -> AST -> AST -> AST
AST.Assignment forall a. Maybe a
Nothing (PSString -> AST -> AST
accessorString PSString
"create" (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing (forall (a :: ProperNameType). ProperName a -> Text
properToJs ProperName 'ConstructorName
ctor))) AST
createFn
                          ]

  iife :: Text -> [AST] -> AST
  iife :: Text -> [AST] -> AST
iife Text
v [AST]
exprs = Maybe SourceSpan -> AST -> [AST] -> AST
AST.App forall a. Maybe a
Nothing (Maybe SourceSpan -> Maybe Text -> [Text] -> AST -> AST
AST.Function forall a. Maybe a
Nothing forall a. Maybe a
Nothing [] (Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ [AST]
exprs forall a. [a] -> [a] -> [a]
++ [Maybe SourceSpan -> AST -> AST
AST.Return forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
v])) []

  literalToValueJS :: SourceSpan -> Literal (Expr Ann) -> m AST
  literalToValueJS :: SourceSpan -> Literal (Expr Ann) -> m AST
literalToValueJS SourceSpan
ss (NumericLiteral (Left Integer
i)) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> Either Integer Double -> AST
AST.NumericLiteral (forall a. a -> Maybe a
Just SourceSpan
ss) (forall a b. a -> Either a b
Left Integer
i)
  literalToValueJS SourceSpan
ss (NumericLiteral (Right Double
n)) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> Either Integer Double -> AST
AST.NumericLiteral (forall a. a -> Maybe a
Just SourceSpan
ss) (forall a b. b -> Either a b
Right Double
n)
  literalToValueJS SourceSpan
ss (StringLiteral PSString
s) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> PSString -> AST
AST.StringLiteral (forall a. a -> Maybe a
Just SourceSpan
ss) PSString
s
  literalToValueJS SourceSpan
ss (CharLiteral Char
c) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> PSString -> AST
AST.StringLiteral (forall a. a -> Maybe a
Just SourceSpan
ss) (forall a. IsString a => FilePath -> a
fromString [Char
c])
  literalToValueJS SourceSpan
ss (BooleanLiteral Bool
b) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> Bool -> AST
AST.BooleanLiteral (forall a. a -> Maybe a
Just SourceSpan
ss) Bool
b
  literalToValueJS SourceSpan
ss (ArrayLiteral [Expr Ann]
xs) = Maybe SourceSpan -> [AST] -> AST
AST.ArrayLiteral (forall a. a -> Maybe a
Just SourceSpan
ss) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr Ann -> m AST
valueToJs [Expr Ann]
xs
  literalToValueJS SourceSpan
ss (ObjectLiteral [(PSString, Expr Ann)]
ps) = Maybe SourceSpan -> [(PSString, AST)] -> AST
AST.ObjectLiteral (forall a. a -> Maybe a
Just SourceSpan
ss) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) b c a.
Functor f =>
(b -> f c) -> (a, b) -> f (a, c)
sndM Expr Ann -> m AST
valueToJs) [(PSString, Expr Ann)]
ps

  -- Shallow copy an object.
  extendObj :: AST -> [(PSString, AST)] -> m AST
  extendObj :: AST -> [(PSString, AST)] -> m AST
extendObj AST
obj [(PSString, AST)]
sts = do
    Text
newObj <- forall (m :: * -> *). MonadSupply m => m Text
freshName
    Text
key <- forall (m :: * -> *). MonadSupply m => m Text
freshName
    Text
evaluatedObj <- forall (m :: * -> *). MonadSupply m => m Text
freshName
    let
      jsKey :: AST
jsKey = Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
key
      jsNewObj :: AST
jsNewObj = Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
newObj
      jsEvaluatedObj :: AST
jsEvaluatedObj = Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
evaluatedObj
      block :: AST
block = Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing (AST
evaluateforall a. a -> [a] -> [a]
:AST
objAssignforall a. a -> [a] -> [a]
:AST
copyforall a. a -> [a] -> [a]
:[AST]
extend forall a. [a] -> [a] -> [a]
++ [Maybe SourceSpan -> AST -> AST
AST.Return forall a. Maybe a
Nothing AST
jsNewObj])
      evaluate :: AST
evaluate = Maybe SourceSpan -> Text -> Maybe (InitializerEffects, AST) -> AST
AST.VariableIntroduction forall a. Maybe a
Nothing Text
evaluatedObj (forall a. a -> Maybe a
Just (InitializerEffects
UnknownEffects, AST
obj))
      objAssign :: AST
objAssign = Maybe SourceSpan -> Text -> Maybe (InitializerEffects, AST) -> AST
AST.VariableIntroduction forall a. Maybe a
Nothing Text
newObj (forall a. a -> Maybe a
Just (InitializerEffects
NoEffects, Maybe SourceSpan -> [(PSString, AST)] -> AST
AST.ObjectLiteral forall a. Maybe a
Nothing []))
      copy :: AST
copy = Maybe SourceSpan -> Text -> AST -> AST -> AST
AST.ForIn forall a. Maybe a
Nothing Text
key AST
jsEvaluatedObj forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing [Maybe SourceSpan -> AST -> AST -> Maybe AST -> AST
AST.IfElse forall a. Maybe a
Nothing AST
cond AST
assign forall a. Maybe a
Nothing]
      cond :: AST
cond = Maybe SourceSpan -> AST -> [AST] -> AST
AST.App forall a. Maybe a
Nothing (PSString -> AST -> AST
accessorString PSString
"call" (PSString -> AST -> AST
accessorString PSString
"hasOwnProperty" (Maybe SourceSpan -> [(PSString, AST)] -> AST
AST.ObjectLiteral forall a. Maybe a
Nothing []))) [AST
jsEvaluatedObj, AST
jsKey]
      assign :: AST
assign = Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing [Maybe SourceSpan -> AST -> AST -> AST
AST.Assignment forall a. Maybe a
Nothing (Maybe SourceSpan -> AST -> AST -> AST
AST.Indexer forall a. Maybe a
Nothing AST
jsKey AST
jsNewObj) (Maybe SourceSpan -> AST -> AST -> AST
AST.Indexer forall a. Maybe a
Nothing AST
jsKey AST
jsEvaluatedObj)]
      stToAssign :: (PSString, AST) -> AST
stToAssign (PSString
s, AST
js) = Maybe SourceSpan -> AST -> AST -> AST
AST.Assignment forall a. Maybe a
Nothing (PSString -> AST -> AST
accessorString PSString
s AST
jsNewObj) AST
js
      extend :: [AST]
extend = forall a b. (a -> b) -> [a] -> [b]
map (PSString, AST) -> AST
stToAssign [(PSString, AST)]
sts
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> AST -> [AST] -> AST
AST.App forall a. Maybe a
Nothing (Maybe SourceSpan -> Maybe Text -> [Text] -> AST -> AST
AST.Function forall a. Maybe a
Nothing forall a. Maybe a
Nothing [] AST
block) []

  -- Generate code in the simplified JavaScript intermediate representation for a reference to a
  -- variable.
  varToJs :: Qualified Ident -> AST
  varToJs :: Qualified Ident -> AST
varToJs (Qualified (BySourcePos SourcePos
_) Ident
ident) = Ident -> AST
var Ident
ident
  varToJs Qualified Ident
qual = forall a. (a -> Ident) -> Qualified a -> AST
qualifiedToJS forall a. a -> a
id Qualified Ident
qual

  -- Generate code in the simplified JavaScript intermediate representation for a reference to a
  -- variable that may have a qualified name.
  qualifiedToJS :: (a -> Ident) -> Qualified a -> AST
  qualifiedToJS :: forall a. (a -> Ident) -> Qualified a -> AST
qualifiedToJS a -> Ident
f (Qualified (ByModuleName ModuleName
C.M_Prim) a
a) = Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
runIdent forall a b. (a -> b) -> a -> b
$ a -> Ident
f a
a
  qualifiedToJS a -> Ident
f (Qualified (ByModuleName ModuleName
mn') a
a) | ModuleName
mn forall a. Eq a => a -> a -> Bool
/= ModuleName
mn' = Maybe SourceSpan -> ModuleName -> PSString -> AST
AST.ModuleAccessor forall a. Maybe a
Nothing ModuleName
mn' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PSString
mkString forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
identCharToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
runIdent forall a b. (a -> b) -> a -> b
$ a -> Ident
f a
a
  qualifiedToJS a -> Ident
f (Qualified QualifiedBy
_ a
a) = Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ Ident -> Text
identToJs (a -> Ident
f a
a)

  foreignIdent :: Ident -> AST
  foreignIdent :: Ident -> AST
foreignIdent Ident
ident = PSString -> AST -> AST
accessorString (Text -> PSString
mkString forall a b. (a -> b) -> a -> b
$ Ident -> Text
runIdent Ident
ident) (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
FFINamespace)

  -- Generate code in the simplified JavaScript intermediate representation for pattern match binders
  -- and guards.
  bindersToJs :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
  bindersToJs :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
bindersToJs SourceSpan
ss [CaseAlternative Ann]
binders [AST]
vals = do
    [Text]
valNames <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [AST]
vals) forall (m :: * -> *). MonadSupply m => m Text
freshName
    let assignments :: [AST]
assignments = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Maybe SourceSpan -> Text -> Maybe (InitializerEffects, AST) -> AST
AST.VariableIntroduction forall a. Maybe a
Nothing) [Text]
valNames (forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InitializerEffects
UnknownEffects, )) [AST]
vals)
    [[AST]]
jss <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CaseAlternative Ann]
binders forall a b. (a -> b) -> a -> b
$ \(CaseAlternative [Binder Ann]
bs Either [(Expr Ann, Expr Ann)] (Expr Ann)
result) -> do
      [AST]
ret <- Either [(Expr Ann, Expr Ann)] (Expr Ann) -> m [AST]
guardsToJs Either [(Expr Ann, Expr Ann)] (Expr Ann)
result
      [Text] -> [AST] -> [Binder Ann] -> m [AST]
go [Text]
valNames [AST]
ret [Binder Ann]
bs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> AST -> [AST] -> AST
AST.App forall a. Maybe a
Nothing (Maybe SourceSpan -> Maybe Text -> [Text] -> AST -> AST
AST.Function forall a. Maybe a
Nothing forall a. Maybe a
Nothing [] (Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing ([AST]
assignments forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[AST]]
jss forall a. [a] -> [a] -> [a]
++ [Maybe SourceSpan -> AST -> AST
AST.Throw forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ [Text] -> AST
failedPatternError [Text]
valNames])))
                   []
    where
      go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
      go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
go [Text]
_ [AST]
done [] = forall (m :: * -> *) a. Monad m => a -> m a
return [AST]
done
      go (Text
v:[Text]
vs) [AST]
done' (Binder Ann
b:[Binder Ann]
bs) = do
        [AST]
done'' <- [Text] -> [AST] -> [Binder Ann] -> m [AST]
go [Text]
vs [AST]
done' [Binder Ann]
bs
        Text -> [AST] -> Binder Ann -> m [AST]
binderToJs Text
v [AST]
done'' Binder Ann
b
      go [Text]
_ [AST]
_ [Binder Ann]
_ = forall a. HasCallStack => FilePath -> a
internalError FilePath
"Invalid arguments to bindersToJs"

      failedPatternError :: [Text] -> AST
      failedPatternError :: [Text] -> AST
failedPatternError [Text]
names = Maybe SourceSpan -> UnaryOperator -> AST -> AST
AST.Unary forall a. Maybe a
Nothing UnaryOperator
AST.New forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> AST -> [AST] -> AST
AST.App forall a. Maybe a
Nothing (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
"Error") [Maybe SourceSpan -> BinaryOperator -> AST -> AST -> AST
AST.Binary forall a. Maybe a
Nothing BinaryOperator
AST.Add (Maybe SourceSpan -> PSString -> AST
AST.StringLiteral forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ Text -> PSString
mkString Text
failedPatternMessage) (Maybe SourceSpan -> [AST] -> AST
AST.ArrayLiteral forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> AST -> AST
valueError [Text]
names [AST]
vals)]

      failedPatternMessage :: Text
      failedPatternMessage :: Text
failedPatternMessage = Text
"Failed pattern match at " forall a. Semigroup a => a -> a -> a
<> ModuleName -> Text
runModuleName ModuleName
mn forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> SourceSpan -> Text
displayStartEndPos SourceSpan
ss forall a. Semigroup a => a -> a -> a
<> Text
": "

      valueError :: Text -> AST -> AST
      valueError :: Text -> AST -> AST
valueError Text
_ l :: AST
l@(AST.NumericLiteral Maybe SourceSpan
_ Either Integer Double
_) = AST
l
      valueError Text
_ l :: AST
l@(AST.StringLiteral Maybe SourceSpan
_ PSString
_)  = AST
l
      valueError Text
_ l :: AST
l@(AST.BooleanLiteral Maybe SourceSpan
_ Bool
_) = AST
l
      valueError Text
s AST
_                        = PSString -> AST -> AST
accessorString PSString
"name" forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSString -> AST -> AST
accessorString PSString
"constructor" forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
s

      guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
      guardsToJs :: Either [(Expr Ann, Expr Ann)] (Expr Ann) -> m [AST]
guardsToJs (Left [(Expr Ann, Expr Ann)]
gs) = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Expr Ann, Expr Ann) -> m AST
genGuard [(Expr Ann, Expr Ann)]
gs where
        genGuard :: (Expr Ann, Expr Ann) -> m AST
genGuard (Expr Ann
cond, Expr Ann
val) = do
          AST
cond' <- Expr Ann -> m AST
valueToJs Expr Ann
cond
          AST
val'   <- Expr Ann -> m AST
valueToJs Expr Ann
val
          forall (m :: * -> *) a. Monad m => a -> m a
return
            (Maybe SourceSpan -> AST -> AST -> Maybe AST -> AST
AST.IfElse forall a. Maybe a
Nothing AST
cond'
              (Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing [Maybe SourceSpan -> AST -> AST
AST.Return forall a. Maybe a
Nothing AST
val']) forall a. Maybe a
Nothing)

      guardsToJs (Right Expr Ann
v) = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SourceSpan -> AST -> AST
AST.Return forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Ann -> m AST
valueToJs Expr Ann
v

  binderToJs :: Text -> [AST] -> Binder Ann -> m [AST]
  binderToJs :: Text -> [AST] -> Binder Ann -> m [AST]
binderToJs Text
s [AST]
done Binder Ann
binder =
    let (SourceSpan
ss, [Comment]
_, Maybe Meta
_) = forall a. Binder a -> a
extractBinderAnn Binder Ann
binder in
    forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SourceSpan -> AST -> m AST
withPos SourceSpan
ss) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [AST] -> Binder Ann -> m [AST]
binderToJs' Text
s [AST]
done Binder Ann
binder

  -- Generate code in the simplified JavaScript intermediate representation for a pattern match
  -- binder.
  binderToJs' :: Text -> [AST] -> Binder Ann -> m [AST]
  binderToJs' :: Text -> [AST] -> Binder Ann -> m [AST]
binderToJs' Text
_ [AST]
done NullBinder{} = forall (m :: * -> *) a. Monad m => a -> m a
return [AST]
done
  binderToJs' Text
varName [AST]
done (LiteralBinder Ann
_ Literal (Binder Ann)
l) =
    Text -> [AST] -> Literal (Binder Ann) -> m [AST]
literalToBinderJS Text
varName [AST]
done Literal (Binder Ann)
l
  binderToJs' Text
varName [AST]
done (VarBinder Ann
_ Ident
ident) =
    forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SourceSpan -> Text -> Maybe (InitializerEffects, AST) -> AST
AST.VariableIntroduction forall a. Maybe a
Nothing (Ident -> Text
identToJs Ident
ident) (forall a. a -> Maybe a
Just (InitializerEffects
NoEffects, Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
varName)) forall a. a -> [a] -> [a]
: [AST]
done)
  binderToJs' Text
varName [AST]
done (ConstructorBinder (SourceSpan
_, [Comment]
_, Just Meta
IsNewtype) Qualified (ProperName 'TypeName)
_ Qualified (ProperName 'ConstructorName)
_ [Binder Ann
b]) =
    Text -> [AST] -> Binder Ann -> m [AST]
binderToJs Text
varName [AST]
done Binder Ann
b
  binderToJs' Text
varName [AST]
done (ConstructorBinder (SourceSpan
_, [Comment]
_, Just (IsConstructor ConstructorType
ctorType [Ident]
fields)) Qualified (ProperName 'TypeName)
_ Qualified (ProperName 'ConstructorName)
ctor [Binder Ann]
bs) = do
    [AST]
js <- [(Ident, Binder Ann)] -> [AST] -> m [AST]
go (forall a b. [a] -> [b] -> [(a, b)]
zip [Ident]
fields [Binder Ann]
bs) [AST]
done
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case ConstructorType
ctorType of
      ConstructorType
ProductType -> [AST]
js
      ConstructorType
SumType ->
        [Maybe SourceSpan -> AST -> AST -> Maybe AST -> AST
AST.IfElse forall a. Maybe a
Nothing (Maybe SourceSpan -> AST -> AST -> AST
AST.InstanceOf forall a. Maybe a
Nothing (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
varName) (forall a. (a -> Ident) -> Qualified a -> AST
qualifiedToJS (Text -> Ident
Ident forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: ProperNameType). ProperName a -> Text
runProperName) Qualified (ProperName 'ConstructorName)
ctor))
                  (Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing [AST]
js)
                  forall a. Maybe a
Nothing]
    where
    go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]
    go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]
go [] [AST]
done' = forall (m :: * -> *) a. Monad m => a -> m a
return [AST]
done'
    go ((Ident
field, Binder Ann
binder) : [(Ident, Binder Ann)]
remain) [AST]
done' = do
      Text
argVar <- forall (m :: * -> *). MonadSupply m => m Text
freshName
      [AST]
done'' <- [(Ident, Binder Ann)] -> [AST] -> m [AST]
go [(Ident, Binder Ann)]
remain [AST]
done'
      [AST]
js <- Text -> [AST] -> Binder Ann -> m [AST]
binderToJs Text
argVar [AST]
done'' Binder Ann
binder
      forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SourceSpan -> Text -> Maybe (InitializerEffects, AST) -> AST
AST.VariableIntroduction forall a. Maybe a
Nothing Text
argVar (forall a. a -> Maybe a
Just (InitializerEffects
UnknownEffects, PSString -> AST -> AST
accessorString (Text -> PSString
mkString forall a b. (a -> b) -> a -> b
$ Ident -> Text
identToJs Ident
field) forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
varName)) forall a. a -> [a] -> [a]
: [AST]
js)
  binderToJs' Text
_ [AST]
_ ConstructorBinder{} =
    forall a. HasCallStack => FilePath -> a
internalError FilePath
"binderToJs: Invalid ConstructorBinder in binderToJs"
  binderToJs' Text
varName [AST]
done (NamedBinder Ann
_ Ident
ident Binder Ann
binder) = do
    [AST]
js <- Text -> [AST] -> Binder Ann -> m [AST]
binderToJs Text
varName [AST]
done Binder Ann
binder
    forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SourceSpan -> Text -> Maybe (InitializerEffects, AST) -> AST
AST.VariableIntroduction forall a. Maybe a
Nothing (Ident -> Text
identToJs Ident
ident) (forall a. a -> Maybe a
Just (InitializerEffects
NoEffects, Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
varName)) forall a. a -> [a] -> [a]
: [AST]
js)

  literalToBinderJS :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
  literalToBinderJS :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
literalToBinderJS Text
varName [AST]
done (NumericLiteral Either Integer Double
num) =
    forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe SourceSpan -> AST -> AST -> Maybe AST -> AST
AST.IfElse forall a. Maybe a
Nothing (Maybe SourceSpan -> BinaryOperator -> AST -> AST -> AST
AST.Binary forall a. Maybe a
Nothing BinaryOperator
AST.EqualTo (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
varName) (Maybe SourceSpan -> Either Integer Double -> AST
AST.NumericLiteral forall a. Maybe a
Nothing Either Integer Double
num)) (Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing [AST]
done) forall a. Maybe a
Nothing]
  literalToBinderJS Text
varName [AST]
done (CharLiteral Char
c) =
    forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe SourceSpan -> AST -> AST -> Maybe AST -> AST
AST.IfElse forall a. Maybe a
Nothing (Maybe SourceSpan -> BinaryOperator -> AST -> AST -> AST
AST.Binary forall a. Maybe a
Nothing BinaryOperator
AST.EqualTo (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
varName) (Maybe SourceSpan -> PSString -> AST
AST.StringLiteral forall a. Maybe a
Nothing (forall a. IsString a => FilePath -> a
fromString [Char
c]))) (Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing [AST]
done) forall a. Maybe a
Nothing]
  literalToBinderJS Text
varName [AST]
done (StringLiteral PSString
str) =
    forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe SourceSpan -> AST -> AST -> Maybe AST -> AST
AST.IfElse forall a. Maybe a
Nothing (Maybe SourceSpan -> BinaryOperator -> AST -> AST -> AST
AST.Binary forall a. Maybe a
Nothing BinaryOperator
AST.EqualTo (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
varName) (Maybe SourceSpan -> PSString -> AST
AST.StringLiteral forall a. Maybe a
Nothing PSString
str)) (Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing [AST]
done) forall a. Maybe a
Nothing]
  literalToBinderJS Text
varName [AST]
done (BooleanLiteral Bool
True) =
    forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe SourceSpan -> AST -> AST -> Maybe AST -> AST
AST.IfElse forall a. Maybe a
Nothing (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
varName) (Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing [AST]
done) forall a. Maybe a
Nothing]
  literalToBinderJS Text
varName [AST]
done (BooleanLiteral Bool
False) =
    forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe SourceSpan -> AST -> AST -> Maybe AST -> AST
AST.IfElse forall a. Maybe a
Nothing (Maybe SourceSpan -> UnaryOperator -> AST -> AST
AST.Unary forall a. Maybe a
Nothing UnaryOperator
AST.Not (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
varName)) (Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing [AST]
done) forall a. Maybe a
Nothing]
  literalToBinderJS Text
varName [AST]
done (ObjectLiteral [(PSString, Binder Ann)]
bs) = [AST] -> [(PSString, Binder Ann)] -> m [AST]
go [AST]
done [(PSString, Binder Ann)]
bs
    where
    go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]
    go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]
go [AST]
done' [] = forall (m :: * -> *) a. Monad m => a -> m a
return [AST]
done'
    go [AST]
done' ((PSString
prop, Binder Ann
binder):[(PSString, Binder Ann)]
bs') = do
      Text
propVar <- forall (m :: * -> *). MonadSupply m => m Text
freshName
      [AST]
done'' <- [AST] -> [(PSString, Binder Ann)] -> m [AST]
go [AST]
done' [(PSString, Binder Ann)]
bs'
      [AST]
js <- Text -> [AST] -> Binder Ann -> m [AST]
binderToJs Text
propVar [AST]
done'' Binder Ann
binder
      forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SourceSpan -> Text -> Maybe (InitializerEffects, AST) -> AST
AST.VariableIntroduction forall a. Maybe a
Nothing Text
propVar (forall a. a -> Maybe a
Just (InitializerEffects
UnknownEffects, PSString -> AST -> AST
accessorString PSString
prop (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
varName))) forall a. a -> [a] -> [a]
: [AST]
js)
  literalToBinderJS Text
varName [AST]
done (ArrayLiteral [Binder Ann]
bs) = do
    [AST]
js <- [AST] -> Integer -> [Binder Ann] -> m [AST]
go [AST]
done Integer
0 [Binder Ann]
bs
    forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe SourceSpan -> AST -> AST -> Maybe AST -> AST
AST.IfElse forall a. Maybe a
Nothing (Maybe SourceSpan -> BinaryOperator -> AST -> AST -> AST
AST.Binary forall a. Maybe a
Nothing BinaryOperator
AST.EqualTo (PSString -> AST -> AST
accessorString PSString
"length" (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
varName)) (Maybe SourceSpan -> Either Integer Double -> AST
AST.NumericLiteral forall a. Maybe a
Nothing (forall a b. a -> Either a b
Left (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Binder Ann]
bs)))) (Maybe SourceSpan -> [AST] -> AST
AST.Block forall a. Maybe a
Nothing [AST]
js) forall a. Maybe a
Nothing]
    where
    go :: [AST] -> Integer -> [Binder Ann] -> m [AST]
    go :: [AST] -> Integer -> [Binder Ann] -> m [AST]
go [AST]
done' Integer
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return [AST]
done'
    go [AST]
done' Integer
index (Binder Ann
binder:[Binder Ann]
bs') = do
      Text
elVar <- forall (m :: * -> *). MonadSupply m => m Text
freshName
      [AST]
done'' <- [AST] -> Integer -> [Binder Ann] -> m [AST]
go [AST]
done' (Integer
index forall a. Num a => a -> a -> a
+ Integer
1) [Binder Ann]
bs'
      [AST]
js <- Text -> [AST] -> Binder Ann -> m [AST]
binderToJs Text
elVar [AST]
done'' Binder Ann
binder
      forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SourceSpan -> Text -> Maybe (InitializerEffects, AST) -> AST
AST.VariableIntroduction forall a. Maybe a
Nothing Text
elVar (forall a. a -> Maybe a
Just (InitializerEffects
UnknownEffects, Maybe SourceSpan -> AST -> AST -> AST
AST.Indexer forall a. Maybe a
Nothing (Maybe SourceSpan -> Either Integer Double -> AST
AST.NumericLiteral forall a. Maybe a
Nothing (forall a b. a -> Either a b
Left Integer
index)) (Maybe SourceSpan -> Text -> AST
AST.Var forall a. Maybe a
Nothing Text
varName))) forall a. a -> [a] -> [a]
: [AST]
js)

accessorString :: PSString -> AST -> AST
accessorString :: PSString -> AST -> AST
accessorString PSString
prop = Maybe SourceSpan -> AST -> AST -> AST
AST.Indexer forall a. Maybe a
Nothing (Maybe SourceSpan -> PSString -> AST
AST.StringLiteral forall a. Maybe a
Nothing PSString
prop)

pattern FFINamespace :: Text
pattern $bFFINamespace :: Text
$mFFINamespace :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
FFINamespace = "$foreign"