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 ((</>))
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
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
maybePure :: AST -> Maybe AST
maybePure :: AST -> Maybe AST
maybePure = Bool -> AST -> Maybe AST
maybePureGen Bool
False
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
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
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
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')
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
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")
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
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))) =
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
bindToJs :: Bind Ann -> m [AST]
bindToJs :: Bind Ann -> m [AST]
bindToJs (NonRec (SourceSpan
_, [Comment]
_, Maybe SourceType
_, Just Meta
IsTypeClassConstructor) Ident
_ Expr Ann
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
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)
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 SourceType
_, 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 SourceType
_, 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]
_, Maybe SourceType
_, 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
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
valueToJs :: Expr Ann -> m AST
valueToJs :: Expr Ann -> m AST
valueToJs Expr Ann
e =
let (SourceSpan
ss, [Comment]
_, Maybe SourceType
_, 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 SourceType
_, 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]
_, Maybe SourceType
_, 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]
_, Maybe SourceType
_, 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 Ann
_ Expr Ann
o [(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
AST -> [(PSString, AST)] -> m AST
extendObj AST
obj [(PSString, AST)]
sts
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]
_, Maybe SourceType
_, Just Meta
IsNewtype) Qualified Ident
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> a
head [AST]
args')
Var (SourceSpan
_, [Comment]
_, Maybe SourceType
_, 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]
_, Maybe SourceType
_, 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]
_, Maybe SourceType
_, 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 SourceType
_, 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]
_, Maybe SourceType
_, 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
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) []
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
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)
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 SourceType
_, 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
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]
_, Maybe SourceType
_, 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]
_, Maybe SourceType
_, 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"