Browse files

Initial version of ghc to javascript translator

  • Loading branch information...
0 parents commit 00988d60281a64a8a17c5c7a613b2a63e880cf5a @sviperll sviperll committed Aug 15, 2010
Showing with 587 additions and 0 deletions.
  1. +29 −0 LICENSE
  2. +2 −0 Setup.hs
  3. +18 −0 package.cabal
  4. +154 −0 src/Generator/Core.hs
  5. +12 −0 src/Generator/FFI.hs
  6. +85 −0 src/Generator/Helpers.hs
  7. +10 −0 src/Generator/PrimOp.hs
  8. +76 −0 src/Generator/TopLevel.hs
  9. +142 −0 src/Javascript/Language.hs
  10. +59 −0 src/Main.hs
29 LICENSE
@@ -0,0 +1,29 @@
+Copyright 2010, Pedro Martins and Victor Nazarov
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+- Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright notice,
+this list of conditions and the following disclaimer in the documentation
+and/or other materials provided with the distribution.
+
+- Neither name of the University nor the names of its contributors may be
+used to endorse or promote products derived from this software without
+specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGE.
2 Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
18 package.cabal
@@ -0,0 +1,18 @@
+Name: GHCJS
+Version: 0.1.0
+Description: Javascript backend for GHC
+License: BSD3
+License-file: LICENSE
+Author: Pedro Martins and Victor Nazarov
+Maintainer: Pedro Martins <pedromartins.pt@gmail.com>
+Stability: Experimental
+Build-Type: Simple
+Cabal-Version: >= 1.6
+
+Executable ghcjs
+ Main-Is: Main.hs
+ Hs-Source-Dirs: src
+ Other-Modules: Javascript.Language
+ Generator.TopLevel
+ Build-Depends: base >=3 && <5, ghc, ghc-paths
+ GHC-Options: -Wall -fno-warn-name-shadowing
154 src/Generator/Core.hs
@@ -0,0 +1,154 @@
+module Generator.Core (declarations, definitions, withBindings) where
+
+import Data.List (find)
+
+import Panic (panic)
+
+import DataCon as Stg (DataCon, dataConTag)
+import Id as Stg (Id)
+import CoreSyn as Stg (AltCon (DataAlt, LitAlt, DEFAULT))
+import StgSyn as Stg
+
+import qualified Javascript.Language as Js
+
+import Generator.Helpers
+import Generator.PrimOp (primitiveOperation)
+import Generator.FFI (foreignFunctionCall, primitiveCall)
+
+binding :: StgBinding -> Js.Program
+binding = bindings . stgBindingToList
+
+bindings :: [(Id, StgRhs)] -> Js.Program
+bindings binds = Js.sequence [declarations binds, definitions binds]
+
+withBindings :: (Id -> StgRhs -> Js.Program) -> [(Id, StgRhs)] -> Js.Program
+withBindings f = Js.sequence . map (uncurry f)
+
+declarations :: [(Id, StgRhs)] -> Js.Program
+declarations = withBindings declaration
+
+definitions :: [(Id, StgRhs)] -> Js.Program
+definitions = withBindings definition
+
+declaration :: Id -> StgRhs -> Js.Program
+declaration id rhs = stgIdToJsDecl id (creation rhs)
+
+creation :: StgRhs -> Js.Expression
+creation (StgRhsCon _cc con _args) = dataCreation con
+creation rhs@(StgRhsClosure _cc _bi _fvs upd_flag _srt _args _body)
+ | isUpdatable upd_flag = Js.new (Js.property haskellRoot "Thunk") []
+ | otherwise = Js.new (Js.property haskellRoot "Func") [Js.int (stgRhsArity rhs)]
+
+definition :: Stg.Id -> StgRhs -> Js.Program
+definition id (StgRhsCon _cc _con args) = dataEvaluation (stgIdToJs id) (map stgArgToJs args)
+definition id (StgRhsClosure _cc _bi _fvs upd_flag _srt args body) =
+ Js.sequence
+ [ Js.assignProperty object "evaluated" (Js.bool $ isUpdatable upd_flag)
+ , Js.assignProperty object evalFunctionName $
+ Js.function (map stgIdToJsId args) (expression body)
+ ]
+ where object = (stgIdToJs id)
+ evalFunctionName
+ | isUpdatable upd_flag = "evaluateOnce"
+ | otherwise = "evaluate"
+
+dataCreation :: DataCon -> Js.Expression
+dataCreation con = Js.new (Js.property haskellRoot "Data") [Js.int (dataConTag con)]
+
+dataEvaluation :: Js.Expression -> [Js.Expression] -> Js.Program
+dataEvaluation object args =
+ Js.sequence
+ [ Js.assignProperty object "evaluated" Js.true
+ , Js.assignProperty object "data" (Js.list args)
+ ]
+
+expression :: StgExpr -> Js.Program
+expression (StgCase expr _liveVars _liveRhsVars bndr _srt alttype alts) =
+ caseExpression expr bndr alttype alts
+expression (StgLet bndn body) = Js.sequence [binding bndn, expression body]
+expression (StgLetNoEscape _ _ bndn body) = Js.sequence [binding bndn, expression body]
+expression (StgSCC _ expr) = expression expr
+expression (StgTick _ _ expr) = expression expr
+expression (StgApp f args) = Js.jumpToMethod (stgIdToJs f) "hscall" (map stgArgToJs args)
+expression (StgLit lit) = Js.return . stgLiteralToJs $ lit
+expression (StgConApp con args) =
+ Js.sequence
+ [ Js.declare "$res" (dataCreation con)
+ , dataEvaluation (Js.var "$res") (map stgArgToJs args)
+ , Js.return . Js.var $ "$res"
+ ]
+expression (StgOpApp (StgFCallOp f g) args _ty) = Js.return $ foreignFunctionCall f g args
+expression (StgOpApp (StgPrimOp op) args _ty) = Js.return $ primitiveOperation op args
+expression (StgOpApp (StgPrimCallOp call) args _ty) = Js.return $ primitiveCall call args
+expression (StgLam{}) = panic "unexpected StgLam" -- StgLam is used *only* during CoreToStg's work (StgSyn.lhs:196)
+
+caseExpression :: StgExpr -> Stg.Id -> Stg.AltType -> [StgAlt] -> Js.Program
+caseExpression expr bndr alttype alts =
+ Js.sequence
+ [ caseExpressionScrut bndr expr
+ , caseExpressionAlternatives bndr alttype alts
+ ]
+
+caseExpressionScrut :: Stg.Id -> StgExpr -> Js.Program
+caseExpressionScrut binder expr = go expr
+ where go (StgConApp con args) =
+ Js.sequence
+ [ stgIdToJsDecl binder (dataCreation con)
+ , dataEvaluation (stgIdToJs binder) (map stgArgToJs args)
+ ]
+ go (StgApp f args) =
+ case args
+ of [] ->
+ Js.sequence
+ [ stgIdToJsDecl binder name
+ , Js.if_ (Js.not $ Js.property name "evaluated") $
+ Js.assignMethodCallResult (stgIdToJs binder) name "hscall" []
+ ]
+ _ -> stgIdToJsDeclareMethodCallResult binder name "hscall" (map stgArgToJs args)
+ where name = stgIdToJs f
+ go (StgLit lit) = stgIdToJsDecl binder $ stgLiteralToJs $ lit
+ go (StgOpApp (StgFCallOp f g) args _ty) = stgIdToJsDecl binder $ foreignFunctionCall f g args
+ go (StgOpApp (StgPrimOp op) args _ty) = stgIdToJsDecl binder $ primitiveOperation op args
+ go (StgOpApp (StgPrimCallOp call) args _ty) = stgIdToJsDecl binder $ primitiveCall call args
+ go e = stgIdToJsDeclareFunctionCallResult binder f []
+ where f = Js.function [] (expression e)
+
+caseExpressionAlternatives :: Stg.Id -> Stg.AltType -> [(Stg.AltCon, [Stg.Id], [Bool], StgExpr)] -> Js.Program
+caseExpressionAlternatives bndr altType [(_altCon, args, useMask, expr)] =
+ case altType
+ of PolyAlt {} -> jsexpr
+ PrimAlt {} -> jsexpr
+ UbxTupAlt {} -> argsAndExpr
+ AlgAlt {} -> argsAndExpr
+ where argsAndExpr = Js.sequence [unpackData (stgIdToJs bndr) useMask args, jsexpr]
+ jsexpr = expression expr
+caseExpressionAlternatives bndr altType alts =
+ case altType
+ of PolyAlt {} -> panic "multiple case alternatives for PolyAlt"
+ UbxTupAlt {} -> panic "multiple case alternatives for UbxTupAlt"
+ PrimAlt {} -> Js.switch name defaultCase cases
+ AlgAlt {} -> Js.switch (Js.property name "tag") defaultCase cases
+ where
+ name = stgIdToJs bndr
+ defaultCase =
+ do (_, _, _, expr) <- find isDefault alts
+ return $ expression expr
+ isDefault (DEFAULT, _, _, _) = True
+ isDefault _ = False
+ cases = map alternative . filter (not . isDefault) $ alts
+ alternative alt = (alternativeConst alt, alternativeBody alt)
+ alternativeBody (alt, args, useMask, expr) =
+ case alt
+ of DataAlt _ -> Js.sequence [unpackData name useMask args, expression expr]
+ LitAlt _ -> expression expr
+ DEFAULT -> panic "Default alternative!"
+ alternativeConst (alt, _args, _useMask, _expr) =
+ case alt
+ of DataAlt con -> Js.int (dataConTag con)
+ LitAlt lit -> stgLiteralToJs lit
+ DEFAULT -> panic "Default alternative!"
+
+unpackData :: Js.Expression -> [Bool] -> [Stg.Id] -> Js.Program
+unpackData name mask args = Js.sequence [f n arg | (n, True, arg) <- zip3 [(0::Int)..] mask args]
+ where f n arg = stgIdToJsDecl arg (Js.subscript (Js.property name "data") (Js.int n))
+
12 src/Generator/FFI.hs
@@ -0,0 +1,12 @@
+module Generator.FFI where
+
+import StgSyn as Stg
+import PrimOp
+import qualified Javascript.Language as Js
+
+foreignFunctionCall :: a -> b -> c -> Js.Expression
+foreignFunctionCall _ _ _ = Js.unsafeStringToExpression "$hs.alert ('Unsupported: foreign function call')"
+
+primitiveCall :: PrimCall -> [StgArg] -> Js.Expression
+primitiveCall _ _ = Js.unsafeStringToExpression "$hs.alert ('Unsupported: primitive call')"
+
85 src/Generator/Helpers.hs
@@ -0,0 +1,85 @@
+module Generator.Helpers where
+
+import Id as Stg (Id, isExportedId)
+import Name (NamedThing (getName, getOccName), nameModule)
+import OccName (occNameString)
+import Unique (Uniquable (getUnique), getKey)
+import FastString (unpackFS)
+import Panic (panic)
+import Encoding (zEncodeString)
+
+import Module (Module, moduleName, moduleNameString, moduleNameSlashes)
+import StgSyn as Stg
+import qualified Literal as Stg
+import qualified Javascript.Language as Js
+
+haskellRoot :: Js.Expression
+haskellRoot = Js.var "$hs"
+
+modulePath :: Module -> String
+modulePath = moduleNameSlashes . moduleName
+
+stgModuleToJs :: Module -> Js.Expression
+stgModuleToJs mod = haskellRoot $. "modules" $. (zEncodeString . moduleNameString . moduleName $ mod)
+ where ($.) = Js.property
+
+stgIdToJs :: Stg.Id -> Js.Expression
+stgIdToJs id
+ | isExportedId id = Js.property (stgModuleToJs . nameModule . getName $ id) name
+ | otherwise = Js.var . stgIdToJsId $ id
+ where name = zEncodeString . occNameString . getOccName $ id
+
+stgIdToJsId :: Stg.Id -> Js.Id
+stgIdToJsId id = name ++ key
+ where name = zEncodeString . occNameString . getOccName $ id
+ key = intToBase62 . getKey . getUnique $ id
+
+stgIdToJsDecl :: Stg.Id -> Js.Expression -> Js.Program
+stgIdToJsDecl id expr
+ | isExportedId id = Js.assign (stgIdToJs id) expr
+ | otherwise = Js.declare (stgIdToJsId id) expr
+
+stgIdToJsDeclareMethodCallResult :: Stg.Id -> Js.Expression -> Js.Id -> [Js.Expression] -> Js.Program
+stgIdToJsDeclareMethodCallResult id
+ | isExportedId id = Js.assignMethodCallResult (stgIdToJs id)
+ | otherwise = Js.declareMethodCallResult (stgIdToJsId id)
+
+stgIdToJsDeclareFunctionCallResult :: Stg.Id -> Js.Expression -> [Js.Expression] -> Js.Program
+stgIdToJsDeclareFunctionCallResult id
+ | isExportedId id = Js.assignFunctionCallResult (stgIdToJs id)
+ | otherwise = Js.declareFunctionCallResult (stgIdToJsId id)
+
+stgBindingToList :: StgBinding -> [(Id, StgRhs)]
+stgBindingToList (StgNonRec id rhs) = [(id, rhs)]
+stgBindingToList (StgRec bs) = bs
+
+stgArgsToJs :: [Stg.StgArg] -> Js.Expression
+stgArgsToJs = Js.list . map stgArgToJs
+
+stgArgToJs :: Stg.StgArg -> Js.Expression
+stgArgToJs (Stg.StgVarArg id) = stgIdToJs id
+stgArgToJs (Stg.StgLitArg l) = stgLiteralToJs l
+stgArgToJs (Stg.StgTypeArg _) = panic "Compiler bug: StgTypeArg in expression"
+
+stgLiteralToJs :: Stg.Literal -> Js.Expression
+stgLiteralToJs (Stg.MachChar c) = Js.string [c]
+stgLiteralToJs (Stg.MachStr s) = Js.string (unpackFS s ++ "\0")
+stgLiteralToJs (Stg.MachInt i) = Js.int i
+stgLiteralToJs (Stg.MachInt64 i) = Js.int i
+stgLiteralToJs (Stg.MachWord i) = Js.int i
+stgLiteralToJs (Stg.MachWord64 i) = Js.int i
+stgLiteralToJs (Stg.MachFloat i) = Js.float i
+stgLiteralToJs (Stg.MachDouble i) = Js.float i
+stgLiteralToJs (Stg.MachNullAddr) = Js.null
+stgLiteralToJs (Stg.MachLabel {}) = Js.unsafeStringToExpression "$hs.alert ('Unsupported literal: MachLabel')"
+
+intToBase62 :: Int -> String
+intToBase62 n = go n ""
+ where go n cs
+ | n == 0 = cs
+ | otherwise = go q (c : cs)
+ where (q, r) = quotRem n 62
+ c = chooseChar62 r
+ chooseChar62 n = chars62 !! n
+ chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+
10 src/Generator/PrimOp.hs
@@ -0,0 +1,10 @@
+module Generator.PrimOp where
+
+import StgSyn as Stg
+import PrimOp
+import qualified Javascript.Language as Js
+
+primitiveOperation :: PrimOp -> [StgArg] -> Js.Expression
+primitiveOperation op _ = Js.unsafeStringToExpression alert
+ where alert = concat ["$hs.alert ('primitive operation ", show op, ". Not implemeted yet.')"]
+
76 src/Generator/TopLevel.hs
@@ -0,0 +1,76 @@
+module Generator.TopLevel (generate) where
+
+import Module (Module)
+import Id as Stg (Id, isExportedId)
+
+import StgSyn
+import qualified Javascript.Language as Js
+
+import Generator.Helpers (stgIdToJs, stgIdToJsId, stgModuleToJs, modulePath, stgBindingToList, haskellRoot)
+import Generator.Core (declarations, withBindings, definitions)
+
+generate :: Module -> [Module] -> [StgBinding] -> IO Js.Program
+generate thisMod importedMods binds =
+ return $ Js.sequence
+ [ Js.assign modRef $ Js.new (Js.property haskellRoot "Module") []
+ , Js.assign (Js.property modRef "dependencies") $
+ Js.list . map (Js.string . modulePath) $ importedMods
+ , Js.assign (Js.property modRef "initBeforeDependecies") $
+ Js.function [] $
+ Js.sequence
+ [ declarations exportedBindings
+ , withBindings (stubDefinition modRef) exportedBindings
+ ]
+ , Js.assign (Js.property modRef "initAfterDependecies") $
+ Js.function [] $
+ Js.sequence
+ [ declarations allBindings
+ , definitions allBindings
+ ]
+ ]
+ where modRef = stgModuleToJs thisMod
+ allBindings = joinBindings binds
+ exportedBindings = filter (isExportedId . fst) allBindings
+
+joinBindings :: [StgBinding] -> [(Id, StgRhs)]
+joinBindings = concat . map stgBindingToList
+
+stubDefinition :: Js.Expression -> Stg.Id -> StgRhs -> Js.Program
+stubDefinition mod id (StgRhsCon _cc _con _stgargs) =
+ Js.sequence
+ [ Js.assignProperty object "evaluated" Js.false
+ , Js.assignProperty object "evaluate" $
+ Js.function [] (dataStubExpression mod object)
+ ]
+ where object = stgIdToJs id
+stubDefinition mod id (StgRhsClosure _cc _bi _fvs upd_flag _srt stgargs _body) =
+ Js.sequence
+ [ Js.assignProperty object "evaluated" Js.false
+ , Js.assignProperty object method $
+ Js.function argNames (stubExpression mod object method args)
+ ]
+ where object = stgIdToJs id
+ method
+ | isUpdatable upd_flag = "evaluateOnce"
+ | otherwise = "evaluate"
+ args = map stgIdToJs stgargs
+ argNames = map stgIdToJsId stgargs
+
+stubExpression :: Js.Expression -> Js.Expression -> String -> [Js.Expression] -> Js.Program
+stubExpression mod object method args =
+ Js.sequence
+ [ Js.declareMethodCallResult "$res" mod "loadDependencies" []
+ , Js.jumpToMethod object method args
+ ]
+
+dataStubExpression :: Js.Expression -> Js.Expression -> Js.Program
+dataStubExpression mod object =
+ Js.sequence
+ [ Js.if_ (Js.not $ Js.property object "evaluated") $
+ Js.sequence
+ [ Js.declareMethodCallResult "$res" mod "loadDependencies" []
+ , Js.jumpToMethod object "evaluate" []
+ ]
+ , Js.return $ object
+ ]
+
142 src/Javascript/Language.hs
@@ -0,0 +1,142 @@
+module Javascript.Language
+ ( Id
+ , Expression
+ , Program
+ , int
+ , float
+ , string
+ , list
+ , bool
+ , true
+ , false
+ , Javascript.Language.not
+ , Javascript.Language.null
+ , if_
+ , jumpToMethod
+ , Javascript.Language.return
+ , assignMethodCallResult
+ , declareMethodCallResult
+ , assignFunctionCallResult
+ , declareFunctionCallResult
+ , function
+ , assign
+ , assignProperty
+ , property
+ , var
+ , switch
+ , declare
+ , Javascript.Language.sequence
+ , new
+ , subscript
+ , unsafeStringToExpression
+ ) where
+
+import Data.List (intercalate)
+
+newtype Expression = E { unE :: Prelude.String }
+newtype Program = P { unP :: Prelude.String }
+type Id = Prelude.String
+
+instance Show Program where
+ show = unP
+
+var :: Id -> Expression
+var = E
+
+int :: (Num a) => a -> Expression
+int = E . show
+
+float :: (Fractional a) => a -> Expression
+float = E . show
+
+string :: Prelude.String -> Expression
+string = E . show
+
+list :: [Expression] -> Expression
+list xs = E $ concat ["[", intercalate ", " . map unE $ xs, "]"]
+
+null :: Expression
+null = E "null"
+
+true :: Expression
+true = E "true"
+
+false :: Expression
+false = E "false"
+
+bool :: Bool -> Expression
+bool True = true
+bool False = false
+
+not :: Expression -> Expression
+not e = E $ "!" ++ unE e
+
+if_ :: Expression -> Program -> Program
+if_ test block =
+ P $ concat
+ [ "if (", unE test, ") {\n"
+ , unP block
+ , "}\n"
+ ]
+
+callMethodPrimitive :: Expression -> Id -> [Expression] -> Expression
+callMethodPrimitive obj method args = E $ concat [unE obj, ".", method, "(", intercalate ", " . map unE $ args, ")"]
+
+assignMethodCallResult :: Expression -> Expression -> Id -> [Expression] -> Program
+assignMethodCallResult var obj method args = assign var $ callMethodPrimitive obj method args
+
+declareMethodCallResult :: Id -> Expression -> Id -> [Expression] -> Program
+declareMethodCallResult var obj method args = declare var $ callMethodPrimitive obj method args
+
+callFunctionPrimitive :: Expression -> [Expression] -> Expression
+callFunctionPrimitive func args = E $ concat [unE func, "(", intercalate ", " . map unE $ args, ")"]
+
+assignFunctionCallResult :: Expression -> Expression -> [Expression] -> Program
+assignFunctionCallResult var func args = assign var $ callFunctionPrimitive func args
+
+declareFunctionCallResult :: Id -> Expression -> [Expression] -> Program
+declareFunctionCallResult var func args = declare var $ callFunctionPrimitive func args
+
+jumpToMethod :: Expression -> Id -> [Expression] -> Program
+jumpToMethod obj method args = Javascript.Language.return $ callMethodPrimitive obj method args
+
+return :: Expression -> Program
+return res = P $ concat ["return ", unE res, ";\n"]
+
+function :: [Id] -> Program -> Expression
+function args body = E $ concat ["function (", intercalate ", " args, ") {\n", unP body, "}"]
+
+assign :: Expression -> Expression -> Program
+assign lval val = P $ concat [unE lval, " = ", unE val, ";\n"]
+
+assignProperty :: Expression -> Id -> Expression -> Program
+assignProperty object prop value = assign (property object prop) value
+
+declare :: Id -> Expression -> Program
+declare id expr = P $ concat ["var ", id, " = ", unE expr, ";\n"]
+
+property :: Expression -> Id -> Expression
+property obj id = E $ concat [unE obj, ".", id]
+
+new :: Expression -> [Expression] -> Expression
+new conctructor args = E $ concat["new ", unE conctructor, "(", intercalate ", " . map unE $ args, ")"]
+
+switch :: Expression -> (Maybe Program) -> [(Expression, Program)] -> Program
+switch scrut def cases = P $ concat ["switch (", unE scrut, ") {\n", casesP, defP, "}\n"]
+ where defP =
+ case def
+ of Nothing -> ""
+ Just (P prog) -> "default:\n" ++ prog
+ casesP :: Prelude.String
+ casesP = concat . map caseP $ cases
+ caseP :: (Expression, Program) -> Prelude.String
+ caseP (E expr, P prog) = concat ["case ", expr, ":\n", prog]
+
+sequence :: [Program] -> Program
+sequence = P . concat . map unP
+
+subscript :: Expression -> Expression -> Expression
+subscript a i = E $ concat [unE a, "[", unE i, "]"]
+
+unsafeStringToExpression :: String -> Expression
+unsafeStringToExpression = E
59 src/Main.hs
@@ -0,0 +1,59 @@
+module Main where
+
+import GHC
+import CoreToStg
+import GHC.Paths ( libdir )
+import DynFlags ( defaultDynFlags )
+import HscTypes
+import Panic
+import CorePrep
+
+import System.Environment
+import Control.Monad
+import Data.Maybe
+import Data.List
+
+import qualified Generator.TopLevel as JsGen (generate)
+
+main :: IO ()
+main = do
+ args <- getArgs
+ when (elem "--help" args) $ ghcError (ProgramError usage)
+ cfs <- defaultErrorHandler defaultDynFlags $ do
+ runGhc (Just libdir) $ do
+ sdflags <- getSessionDynFlags
+ (dflags, fileargs', _) <- parseDynamicFlags sdflags (map noLoc args)
+ when (null fileargs') $ ghcError (UsageError "No input files.")
+ _ <- setSessionDynFlags dflags
+ let fileargs = map unLoc fileargs'
+ targets <- mapM (\x -> guessTarget x Nothing) fileargs
+ setTargets targets
+ mgraph <- depanal [] False
+ let files = filter (not . isSuffixOf "boot")
+ . map (extractPath . ms_location) $ mgraph
+ extractPath l = fromMaybe (ml_hi_file l) (ml_hs_file l)
+ setTargets []
+ cs <- mapM compileToCoreSimplified files
+ return $ zip cs (map ((++".js") . stripFileExt) files)
+ putStrLn $ "Translating STG to JS for: " ++ show (map snd cfs)
+ mapM_ (uncurry compileCore) cfs
+
+compileCore :: CoreModule -> FilePath -> IO ()
+compileCore c fp = do
+ let cmod = cm_module c
+ core' <- corePrepPgm defaultDynFlags (cm_binds c) []
+ stg <- coreToStg (modulePackageId cmod) core'
+ prog <- JsGen.generate cmod (cm_imports c) stg
+ -- Custom output paths are ignored
+ let program = show prog
+ putStrLn $ "Writing " ++ fp
+ writeFile fp program
+
+usage :: [Char]
+usage = "Haskell to Javascript compiler (via GHC)\n\n\
+ \\tUsage: ghcjs [command-line-options-and-input-files]\n"
+
+stripFileExt :: String -> String
+stripFileExt fn = let safeLast x = if (null x) then Nothing else Just (last x)
+ in maybe fn (flip take fn) (safeLast . elemIndices '.' $ fn)
+

0 comments on commit 00988d6

Please sign in to comment.