module Language.PureScript.CodeGen.JS
( module AST
, module Common
, moduleToJs
) where
import Prelude.Compat
import Protolude (ordNub)
import Control.Arrow ((&&&))
import Control.Monad (forM, replicateM, void)
import Control.Monad.Except (MonadError, throwError)
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Supply.Class
import Data.List ((\\), intersect)
import qualified Data.Foldable as F
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Maybe (fromMaybe, isNothing)
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.AST.SourcePos
import Language.PureScript.CodeGen.JS.Common as Common
import Language.PureScript.CoreImp.AST (AST, everywhereTopDownM, withSourceSpan)
import qualified Language.PureScript.CoreImp.AST as AST
import Language.PureScript.CoreImp.Optimizer
import Language.PureScript.CoreFn
import Language.PureScript.Crash
import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..),
MultipleErrors(..), rethrow, errorMessage,
errorMessage', rethrowWithPosition, addHint)
import Language.PureScript.Names
import Language.PureScript.Options
import Language.PureScript.PSString (PSString, mkString)
import Language.PureScript.Traversals (sndM)
import qualified Language.PureScript.Constants as C
import System.FilePath.Posix ((</>))
moduleToJs
:: forall m
. (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
=> Module Ann
-> Maybe AST
-> m [AST]
moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
rethrow (addHint (ErrorInModule mn)) $ do
let usedNames = concatMap getNames decls
let mnLookup = renameImports usedNames imps
let decls' = renameModules mnLookup decls
jsDecls <- mapM bindToJs decls'
optimized <- traverse (traverse optimize) jsDecls
let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup
let usedModuleNames = foldMap (foldMap (findModules mnReverseLookup)) optimized
jsImports <- traverse (importToJs mnLookup)
. filter (flip S.member usedModuleNames)
. (\\ (mn : C.primModules)) $ ordNub $ map snd imps
F.traverse_ (F.traverse_ checkIntegers) optimized
comments <- not <$> asks optionsNoComments
let strict = AST.StringLiteral Nothing "use strict"
let header = if comments && not (null coms) then AST.Comment Nothing coms strict else strict
let foreign' = [AST.VariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]
let moduleBody = header : foreign' ++ jsImports ++ concat optimized
let foreignExps = exps `intersect` foreigns
let standardExps = exps \\ foreignExps
let exps' = AST.ObjectLiteral Nothing $ map (mkString . runIdent &&& AST.Var Nothing . identToJs) standardExps
++ map (mkString . runIdent &&& foreignIdent) foreignExps
return $ moduleBody ++ [AST.Assignment Nothing (accessorString "exports" (AST.Var Nothing "module")) exps']
where
getNames :: Bind Ann -> [Ident]
getNames (NonRec _ ident _) = [ident]
getNames (Rec vals) = map (snd . fst) vals
renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
renameImports = go M.empty
where
go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
go acc used ((ann, mn') : mns') =
let mni = Ident $ runModuleName mn'
in if mn' /= mn && mni `elem` used
then let newName = freshModuleName 1 mn' used
in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns'
else go (M.insert mn' (ann, mn') acc) used mns'
go acc _ [] = acc
freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName
freshModuleName i mn'@(ModuleName pns) used =
let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) <> "_" <> T.pack (show i)]
in if Ident (runModuleName newName) `elem` used
then freshModuleName (i + 1) mn' used
else newName
importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m AST
importToJs mnLookup mn' = do
let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
let moduleBody = AST.App Nothing (AST.Var Nothing "require")
[AST.StringLiteral Nothing (fromString (".." </> T.unpack (runModuleName mn') </> "index.js"))]
withPos ss $ AST.VariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)
renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann]
renameModules mnLookup binds =
let (f, _, _) = everywhereOnValues id goExpr goBinder
in map f binds
where
goExpr :: Expr a -> Expr a
goExpr (Var ann q) = Var ann (renameQual q)
goExpr e = e
goBinder :: Binder a -> Binder a
goBinder (ConstructorBinder ann q1 q2 bs) = ConstructorBinder ann (renameQual q1) (renameQual q2) bs
goBinder b = b
renameQual :: Qualified a -> Qualified a
renameQual (Qualified (Just mn') a) =
let (_,mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
in Qualified (Just mnSafe) a
renameQual q = q
findModules :: M.Map Text ModuleName -> AST -> S.Set ModuleName
findModules mnReverseLookup = AST.everything mappend go
where
go (AST.Var _ name) = foldMap S.singleton $ M.lookup name mnReverseLookup
go _ = mempty
bindToJs :: Bind Ann -> m [AST]
bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val
bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)
nonRecToJS :: Ann -> Ident -> Expr Ann -> m AST
nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
withoutComment <- asks optionsNoComments
if withoutComment
then nonRecToJS a i (modifyAnn removeComments e)
else AST.Comment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)
nonRecToJS (ss, _, _, _) ident val = do
js <- valueToJs val
withPos ss $ AST.VariableIntroduction Nothing (identToJs ident) (Just js)
withPos :: SourceSpan -> AST -> m AST
withPos ss js = do
withSM <- asks (elem JSSourceMap . optionsCodegenTargets)
return $ if withSM
then withSourceSpan ss js
else js
var :: Ident -> AST
var = AST.Var Nothing . identToJs
accessor :: Ident -> AST -> AST
accessor (Ident prop) = accessorString $ mkString prop
accessor (GenIdent _ _) = internalError "GenIdent in accessor"
accessor UnusedIdent = internalError "UnusedIdent in accessor"
accessorString :: PSString -> AST -> AST
accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)
valueToJs :: Expr Ann -> m AST
valueToJs e =
let (ss, _, _, _) = extractAnn e in
withPos ss =<< valueToJs' e
valueToJs' :: Expr Ann -> m AST
valueToJs' (Literal (pos, _, _, _) l) =
rethrowWithPosition pos $ literalToValueJS pos l
valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) =
return $ accessorString "value" $ qualifiedToJS id name
valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) =
return $ accessorString "create" $ qualifiedToJS id name
valueToJs' (Accessor _ prop val) =
accessorString prop <$> valueToJs val
valueToJs' (ObjectUpdate _ o ps) = do
obj <- valueToJs o
sts <- mapM (sndM valueToJs) ps
extendObj obj sts
valueToJs' e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
let args = unAbs e
in return $ AST.Function Nothing Nothing (map identToJs args) (AST.Block Nothing $ map assign args)
where
unAbs :: Expr Ann -> [Ident]
unAbs (Abs _ arg val) = arg : unAbs val
unAbs _ = []
assign :: Ident -> AST
assign name = AST.Assignment Nothing (accessorString (mkString $ runIdent name) (AST.Var Nothing "this"))
(var name)
valueToJs' (Abs _ arg val) = do
ret <- valueToJs val
let jsArg = case arg of
UnusedIdent -> []
_ -> [identToJs arg]
return $ AST.Function Nothing Nothing jsArg (AST.Block Nothing [AST.Return Nothing ret])
valueToJs' e@App{} = do
let (f, args) = unApp e []
args' <- mapM valueToJs args
case f of
Var (_, _, _, Just IsNewtype) _ -> return (head args')
Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
return $ AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args'
Var (_, _, _, Just IsTypeClassConstructor) name ->
return $ AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args'
_ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToJs f
where
unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
unApp (App _ val arg) args = unApp val (arg : args)
unApp other args = (other, args)
valueToJs' (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =
return $ if mn' == mn
then foreignIdent ident
else varToJs qi
valueToJs' (Var (_, _, _, Just IsForeign) ident) =
internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident)
valueToJs' (Var _ ident) = return $ varToJs ident
valueToJs' (Case (ss, _, _, _) values binders) = do
vals <- mapM valueToJs values
bindersToJs ss binders vals
valueToJs' (Let _ ds val) = do
ds' <- concat <$> mapM bindToJs ds
ret <- valueToJs val
return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (ds' ++ [AST.Return Nothing ret]))) []
valueToJs' (Constructor (_, _, _, Just IsNewtype) _ ctor _) =
return $ AST.VariableIntroduction Nothing (properToJs ctor) (Just $
AST.ObjectLiteral Nothing [("create",
AST.Function Nothing Nothing ["value"]
(AST.Block Nothing [AST.Return Nothing $ AST.Var Nothing "value"]))])
valueToJs' (Constructor _ _ ctor []) =
return $ iife (properToJs ctor) [ AST.Function Nothing (Just (properToJs ctor)) [] (AST.Block Nothing [])
, AST.Assignment Nothing (accessorString "value" (AST.Var Nothing (properToJs ctor)))
(AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing (properToJs ctor)) []) ]
valueToJs' (Constructor _ _ ctor fields) =
let constructor =
let body = [ AST.Assignment Nothing ((accessorString $ mkString $ identToJs f) (AST.Var Nothing "this")) (var f) | f <- fields ]
in AST.Function Nothing (Just (properToJs ctor)) (identToJs `map` fields) (AST.Block Nothing body)
createFn =
let body = AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing (properToJs ctor)) (var `map` fields)
in foldr (\f inner -> AST.Function Nothing Nothing [identToJs f] (AST.Block Nothing [AST.Return Nothing inner])) body fields
in return $ iife (properToJs ctor) [ constructor
, AST.Assignment Nothing (accessorString "create" (AST.Var Nothing (properToJs ctor))) createFn
]
iife :: Text -> [AST] -> AST
iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
literalToValueJS :: SourceSpan -> Literal (Expr Ann) -> m AST
literalToValueJS ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)
literalToValueJS ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n)
literalToValueJS ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s
literalToValueJS ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c])
literalToValueJS ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b
literalToValueJS ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToJs xs
literalToValueJS ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToJs) ps
extendObj :: AST -> [(PSString, AST)] -> m AST
extendObj obj sts = do
newObj <- freshName
key <- freshName
evaluatedObj <- freshName
let
jsKey = AST.Var Nothing key
jsNewObj = AST.Var Nothing newObj
jsEvaluatedObj = AST.Var Nothing evaluatedObj
block = AST.Block Nothing (evaluate:objAssign:copy:extend ++ [AST.Return Nothing jsNewObj])
evaluate = AST.VariableIntroduction Nothing evaluatedObj (Just obj)
objAssign = AST.VariableIntroduction Nothing newObj (Just $ AST.ObjectLiteral Nothing [])
copy = AST.ForIn Nothing key jsEvaluatedObj $ AST.Block Nothing [AST.IfElse Nothing cond assign Nothing]
cond = AST.App Nothing (accessorString "call" (accessorString "hasOwnProperty" (AST.ObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey]
assign = AST.Block Nothing [AST.Assignment Nothing (AST.Indexer Nothing jsKey jsNewObj) (AST.Indexer Nothing jsKey jsEvaluatedObj)]
stToAssign (s, js) = AST.Assignment Nothing (accessorString s jsNewObj) js
extend = map stToAssign sts
return $ AST.App Nothing (AST.Function Nothing Nothing [] block) []
varToJs :: Qualified Ident -> AST
varToJs (Qualified Nothing ident) = var ident
varToJs qual = qualifiedToJS id qual
qualifiedToJS :: (a -> Ident) -> Qualified a -> AST
qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = AST.Var Nothing . runIdent $ f a
qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (AST.Var Nothing (moduleNameToJs mn'))
qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToJs (f a)
foreignIdent :: Ident -> AST
foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign")
bindersToJs :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
bindersToJs ss binders vals = do
valNames <- replicateM (length vals) freshName
let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)
jss <- forM binders $ \(CaseAlternative bs result) -> do
ret <- guardsToJs result
go valNames ret bs
return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat jss ++ [AST.Throw Nothing $ failedPatternError valNames])))
[]
where
go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
go _ done [] = return done
go (v:vs) done' (b:bs) = do
done'' <- go vs done' bs
binderToJs v done'' b
go _ _ _ = internalError "Invalid arguments to bindersToJs"
failedPatternError :: [Text] -> AST
failedPatternError names = AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing "Error") [AST.Binary Nothing AST.Add (AST.StringLiteral Nothing $ mkString failedPatternMessage) (AST.ArrayLiteral Nothing $ zipWith valueError names vals)]
failedPatternMessage :: Text
failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss <> ": "
valueError :: Text -> AST -> AST
valueError _ l@(AST.NumericLiteral _ _) = l
valueError _ l@(AST.StringLiteral _ _) = l
valueError _ l@(AST.BooleanLiteral _ _) = l
valueError s _ = accessorString "name" . accessorString "constructor" $ AST.Var Nothing s
guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
guardsToJs (Left gs) = traverse genGuard gs where
genGuard (cond, val) = do
cond' <- valueToJs cond
val' <- valueToJs val
return
(AST.IfElse Nothing cond'
(AST.Block Nothing [AST.Return Nothing val']) Nothing)
guardsToJs (Right v) = return . AST.Return Nothing <$> valueToJs v
binderToJs :: Text -> [AST] -> Binder Ann -> m [AST]
binderToJs s done binder =
let (ss, _, _, _) = extractBinderAnn binder in
traverse (withPos ss) =<< binderToJs' s done binder
binderToJs' :: Text -> [AST] -> Binder Ann -> m [AST]
binderToJs' _ done NullBinder{} = return done
binderToJs' varName done (LiteralBinder _ l) =
literalToBinderJS varName done l
binderToJs' varName done (VarBinder _ ident) =
return (AST.VariableIntroduction Nothing (identToJs ident) (Just (AST.Var Nothing varName)) : done)
binderToJs' varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
binderToJs varName done b
binderToJs' varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
js <- go (zip fields bs) done
return $ case ctorType of
ProductType -> js
SumType ->
[AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (qualifiedToJS (Ident . runProperName) ctor))
(AST.Block Nothing js)
Nothing]
where
go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]
go [] done' = return done'
go ((field, binder) : remain) done' = do
argVar <- freshName
done'' <- go remain done'
js <- binderToJs argVar done'' binder
return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToJs field) $ AST.Var Nothing varName) : js)
binderToJs' _ _ ConstructorBinder{} =
internalError "binderToJs: Invalid ConstructorBinder in binderToJs"
binderToJs' varName done (NamedBinder _ ident binder) = do
js <- binderToJs varName done binder
return (AST.VariableIntroduction Nothing (identToJs ident) (Just (AST.Var Nothing varName)) : js)
literalToBinderJS :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
literalToBinderJS varName done (NumericLiteral num) =
return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]
literalToBinderJS varName done (CharLiteral c) =
return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]
literalToBinderJS varName done (StringLiteral str) =
return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]
literalToBinderJS varName done (BooleanLiteral True) =
return [AST.IfElse Nothing (AST.Var Nothing varName) (AST.Block Nothing done) Nothing]
literalToBinderJS varName done (BooleanLiteral False) =
return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]
literalToBinderJS varName done (ObjectLiteral bs) = go done bs
where
go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]
go done' [] = return done'
go done' ((prop, binder):bs') = do
propVar <- freshName
done'' <- go done' bs'
js <- binderToJs propVar done'' binder
return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : js)
literalToBinderJS varName done (ArrayLiteral bs) = do
js <- go done 0 bs
return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (accessorString "length" (AST.Var Nothing varName)) (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs)))) (AST.Block Nothing js) Nothing]
where
go :: [AST] -> Integer -> [Binder Ann] -> m [AST]
go done' _ [] = return done'
go done' index (binder:bs') = do
elVar <- freshName
done'' <- go done' (index + 1) bs'
js <- binderToJs elVar done'' binder
return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : js)
checkIntegers :: AST -> m ()
checkIntegers = void . everywhereTopDownM go
where
go :: AST -> m AST
go (AST.Unary _ AST.Negate (AST.NumericLiteral ss (Left i))) =
return $ AST.NumericLiteral ss (Left (-i))
go js@(AST.NumericLiteral ss (Left i)) =
let minInt = -2147483648
maxInt = 2147483647
in if i < minInt || i > maxInt
then throwError . maybe errorMessage errorMessage' ss $ IntOutOfRange i "JavaScript" minInt maxInt
else return js
go other = return other