module Language.PureScript.CodeGen.JS (
module AST,
ModuleType(..),
declToJs,
moduleToJs,
isIdent
) where
import Data.Maybe (catMaybes, fromJust, fromMaybe)
import Data.Function (on)
import Data.List (nub, (\\))
import Control.Monad (replicateM, forM)
import Control.Applicative
import qualified Data.Map as M
import Language.PureScript.Names
import Language.PureScript.Declarations
import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST as AST
import Language.PureScript.Types
import Language.PureScript.Optimizer
import Language.PureScript.CodeGen.Common
import Language.PureScript.Environment
import Language.PureScript.Supply
import Language.PureScript.Traversals (sndM)
data ModuleType = CommonJS | Globals
moduleToJs :: (Functor m, Applicative m, Monad m) => ModuleType -> Options -> Module -> Environment -> SupplyT m [JS]
moduleToJs mt opts (Module name decls (Just exps)) env = do
let jsImports = map (importToJs mt opts) . (\\ [name]) . nub $ concatMap imports decls
jsDecls <- mapM (\decl -> declToJs opts name decl env) decls
let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls
let isModuleEmpty = null optimized
let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized
let moduleExports = JSObjectLiteral $ concatMap exportToJs exps
return $ case mt of
CommonJS -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]
Globals | not isModuleEmpty ->
[ JSVariableIntroduction (fromJust (optionsBrowserNamespace opts))
(Just (JSBinary Or (JSVar (fromJust (optionsBrowserNamespace opts))) (JSObjectLiteral [])) )
, JSAssignment (JSAccessor (moduleNameToJs name) (JSVar (fromJust (optionsBrowserNamespace opts))))
(JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])
]
_ -> []
moduleToJs _ _ _ _ = error "Exports should have been elaborated in name desugaring"
importToJs :: ModuleType -> Options -> ModuleName -> JS
importToJs mt opts mn = JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
where
moduleBody = case mt of
CommonJS -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
Globals -> JSAccessor (moduleNameToJs mn) (JSVar (fromJust (optionsBrowserNamespace opts)))
imports :: Declaration -> [ModuleName]
imports =
let (f, _, _, _, _) = everythingOnValues (++) (const []) collect (const []) (const []) (const [])
in f
where
collect :: Value -> [ModuleName]
collect (Var (Qualified (Just mn) _)) = [mn]
collect (Constructor (Qualified (Just mn) _)) = [mn]
collect _ = []
declToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])
declToJs opts mp (ValueDeclaration ident _ _ _ val) e = do
js <- valueToJs opts mp e val
return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]
declToJs opts mp (BindingGroupDeclaration vals) e = do
jss <- flip mapM vals $ \(ident, _, val) -> do
js <- valueToJs opts mp e val
return $ JSVariableIntroduction (identToJs ident) (Just js)
return $ Just jss
declToJs _ mp (DataDeclaration _ _ ctors) _ = do
return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->
[JSVariableIntroduction ctor (Just (go pn 0 tys []))]
where
go :: ProperName -> Integer -> [Type] -> [JS] -> JS
go pn _ [] values =
JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))), ("values", JSArrayLiteral $ reverse values) ]
go pn index (_ : tys') values =
JSFunction Nothing ["value" ++ show index]
(JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])
declToJs opts mp (DataBindingGroupDeclaration ds) e = do
jss <- mapM (\decl -> declToJs opts mp decl e) ds
return $ Just $ concat $ catMaybes jss
declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = return $ Just [js]
declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e
declToJs _ _ _ _ = return Nothing
exportToJs :: DeclarationRef -> [(String, JS)]
exportToJs (TypeRef _ (Just dctors)) = map ((\n -> (n, var (Ident n))) . runProperName) dctors
exportToJs (ValueRef name) = [(runIdent name, var name)]
exportToJs (TypeInstanceRef name) = [(runIdent name, var name)]
exportToJs _ = []
var :: Ident -> JS
var = JSVar . identToJs
accessor :: Ident -> JS -> JS
accessor (Ident prop) = accessorString prop
accessor (Op op) = JSIndexer (JSStringLiteral op)
accessorString :: String -> JS -> JS
accessorString prop | isIdent prop = JSAccessor prop
| otherwise = JSIndexer (JSStringLiteral prop)
valueToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> Value -> SupplyT m JS
valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n
valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s
valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b
valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs opts m e) xs
valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs opts m e)) ps
valueToJs opts m e (ObjectUpdate o ps) = do
obj <- valueToJs opts m e o
sts <- mapM (sndM (valueToJs opts m e)) ps
extendObj obj sts
valueToJs _ m _ (Constructor name) = return $ qualifiedToJS m (Ident . runProperName) name
valueToJs opts m e (Case values binders) = do
vals <- mapM (valueToJs opts m e) values
bindersToJs opts m e binders vals
valueToJs opts m e (IfThenElse cond th el) = JSConditional <$> valueToJs opts m e cond <*> valueToJs opts m e th <*> valueToJs opts m e el
valueToJs opts m e (Accessor prop val) = accessorString prop <$> valueToJs opts m e val
valueToJs opts m e (App val arg) = JSApp <$> valueToJs opts m e val <*> (return <$> valueToJs opts m e arg)
valueToJs opts m e (Let ds val) = do
decls <- concat . catMaybes <$> mapM (flip (declToJs opts m) e) ds
ret <- valueToJs opts m e val
return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []
valueToJs opts m e (Abs (Left arg) val) = do
ret <- valueToJs opts m (bindName m arg e) val
return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = do
let arg' = identToJs arg
ret <- valueToJs opts m e val
return $ JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn ret])
valueToJs _ m _ (Var ident) = return $ varToJs m ident
valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val
valueToJs _ _ _ (TypeClassDictionary _ _ _) = error "Type class dictionary was not replaced"
valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
extendObj :: (Functor m, Applicative m, Monad m) => JS -> [(String, JS)] -> SupplyT m JS
extendObj obj sts = do
newObj <- freshName
key <- freshName
let
jsKey = JSVar key
jsNewObj = JSVar newObj
block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
extend = map stToAssign sts
return $ JSApp (JSFunction Nothing [] block) []
where
bindName :: ModuleName -> Ident -> Environment -> Environment
bindName m ident = bindNames m [ident]
bindNames :: ModuleName -> [Ident] -> Environment -> Environment
bindNames m idents env = env { names = M.fromList [ ((m, ident), (noType, LocalVariable)) | ident <- idents ] `M.union` names env }
where
noType = error "Temporary lambda variable type was read"
runtimeTypeChecks :: String -> Type -> [JS]
runtimeTypeChecks arg ty =
let
argTy = getFunctionArgumentType ty
in
maybe [] (argumentCheck (JSVar arg)) argTy
where
getFunctionArgumentType :: Type -> Maybe Type
getFunctionArgumentType (TypeApp (TypeApp t funArg) _) | t == tyFunction = Just funArg
getFunctionArgumentType (ForAll _ ty' _) = getFunctionArgumentType ty'
getFunctionArgumentType _ = Nothing
argumentCheck :: JS -> Type -> [JS]
argumentCheck val t | t == tyNumber = [typeCheck val "number"]
argumentCheck val t | t == tyString = [typeCheck val "string"]
argumentCheck val t | t == tyBoolean = [typeCheck val "boolean"]
argumentCheck val (TypeApp t _) | t == tyArray = [arrayCheck val]
argumentCheck val (TypeApp t row) | t == tyObject =
let
(pairs, _) = rowToList row
in
typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (accessorString prop val) ty') pairs
argumentCheck val (TypeApp (TypeApp t _) _) | t == tyFunction = [typeCheck val "function"]
argumentCheck val (ForAll _ ty' _) = argumentCheck val ty'
argumentCheck _ _ = []
typeCheck :: JS -> String -> JS
typeCheck js ty' = JSIfElse (JSBinary NotEqualTo (JSTypeOf js) (JSStringLiteral ty')) (JSBlock [JSThrow (JSStringLiteral $ ty' ++ " expected")]) Nothing
arrayCheck :: JS -> JS
arrayCheck js = JSIfElse (JSUnary Not (JSApp (JSAccessor "isArray" (JSVar "Array")) [js])) (JSBlock [JSThrow (JSStringLiteral "Array expected")]) Nothing
varToJs :: ModuleName -> Qualified Ident -> JS
varToJs _ (Qualified Nothing ident) = var ident
varToJs m qual = qualifiedToJS m id qual
qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS
qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSVar (moduleNameToJs m'))
qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
bindersToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS
bindersToJs opts m e binders vals = do
valNames <- replicateM (length vals) freshName
jss <- forM binders $ \(CaseAlternative bs grd result) -> do
ret <- valueToJs opts m (bindNames m (concatMap binderNames bs) e) result
go valNames [JSReturn ret] bs grd
return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
vals
where
go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> Maybe Guard -> SupplyT m [JS]
go _ done [] Nothing = return done
go _ done [] (Just cond) = do
cond' <- valueToJs opts m e cond
return [JSIfElse cond' (JSBlock done) Nothing]
go (v:vs) done' (b:bs) grd = do
done'' <- go vs done' bs grd
binderToJs m e v done'' b
go _ _ _ _ = error "Invalid arguments to bindersToJs"
binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Environment -> String -> [JS] -> Binder -> SupplyT m [JS]
binderToJs _ _ _ done NullBinder = return done
binderToJs _ _ varName done (StringBinder str) =
return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
binderToJs _ _ varName done (NumberBinder num) =
return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
binderToJs _ _ varName done (BooleanBinder True) =
return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
binderToJs _ _ varName done (BooleanBinder False) =
return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
binderToJs _ _ varName done (VarBinder ident) =
return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
binderToJs m e varName done (ConstructorBinder ctor bs) = do
js <- go 0 done bs
if isOnlyConstructor e ctor
then
return js
else
return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ctor)))
(JSBlock js)
Nothing]
where
go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder] -> SupplyT m [JS]
go _ done' [] = return done'
go index done' (binder:bs') = do
argVar <- freshName
done'' <- go (index + 1) done' bs'
js <- binderToJs m e argVar done'' binder
return (JSVariableIntroduction argVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSAccessor "values" (JSVar varName)))) : js)
binderToJs m e varName done (ObjectBinder bs) = go done bs
where
go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder)] -> SupplyT m [JS]
go done' [] = return done'
go done' ((prop, binder):bs') = do
propVar <- freshName
done'' <- go done' bs'
js <- binderToJs m e propVar done'' binder
return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
binderToJs m e varName done (ArrayBinder bs) = do
js <- go done 0 bs
return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
where
go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder] -> SupplyT m [JS]
go done' _ [] = return done'
go done' index (binder:bs') = do
elVar <- freshName
done'' <- go done' (index + 1) bs'
js <- binderToJs m e elVar done'' binder
return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
binderToJs m e varName done (ConsBinder headBinder tailBinder) = do
headVar <- freshName
tailVar <- freshName
js1 <- binderToJs m e headVar done headBinder
js2 <- binderToJs m e tailVar js1 tailBinder
return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left 0))) (JSBlock
( JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left 0)) (JSVar varName))) :
JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left 1)])) :
js2
)) Nothing]
binderToJs m e varName done (NamedBinder ident binder) = do
js <- binderToJs m e varName done binder
return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
binderToJs m e varName done (PositionedBinder _ binder) =
binderToJs m e varName done binder
isOnlyConstructor :: Environment -> Qualified ProperName -> Bool
isOnlyConstructor e ctor =
let ty = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e
in numConstructors (ctor, ty) == 1
where
numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e
typeConstructor (Qualified (Just moduleName) _, (tyCtor, _)) = (moduleName, tyCtor)
typeConstructor _ = error "Invalid argument to isOnlyConstructor"