name: Purescript

version: 0.0.1

cabal-version: >=1.2

build-type: Simple

license: MIT

license-file: LICENSE

copyright: (c) Phil Freeman 2013

maintainer: Phil Freeman <paf31@cantab.net>

stability: experimental

synopsis: PureScript Programming Language Compiler

description: A small compile-to-JS language with extensible records and type-safe blocks

author: Phil Freeman <paf31@cantab.net>

data-dir: ""

build-depends: base -any, cmdtheline -any, containers -any,

mtl -any, parsec -any, utf8-string -any

exposed-modules: PureScript

exposed: True

buildable: True

hs-source-dirs: src

other-modules: Test Main PureScript.CodeGen PureScript.Kinds

PureScript.Parser PureScript.TypeChecker PureScript.Types

PureScript.Values PureScript.Parser.Common

PureScript.Parser.Declarations PureScript.Parser.Types

PureScript.Parser.Values PureScript.TypeChecker.Kinds

PureScript.TypeChecker.Monad PureScript.TypeChecker.Types

executable psc

build-depends: base -any, cmdtheline -any, containers -any,

mtl -any, parsec -any, utf8-string -any

main-is: Main.hs

buildable: True

hs-source-dirs: src

other-modules: Test

> module Main where

> import Distribution.Simple

> main :: IO ()

> main = defaultMain

-- |

module Main where

import PureScript

import Text.Parsec

import Data.Maybe (mapMaybe)

import Data.List (intercalate)

import System.Console.CmdTheLine

import Control.Applicative

import System.Exit (exitSuccess, exitFailure)

import qualified System.IO.UTF8 as U

compile :: [FilePath] -> Maybe FilePath -> IO ()

compile inputFiles outputFile = do

input <- fmap concat $ mapM U.readFile inputFiles

let ast = parse parseDeclarations "" input

case ast of

Left err -> do

U.print err

exitFailure

Right decls -> do

case check (typeCheckAll decls) of

Left typeError -> do

U.putStrLn typeError

exitFailure

Right _ -> do

let js = intercalate "\n" $ mapMaybe declToJs decls

case outputFile of

Just path -> U.writeFile path js

Nothing -> U.putStrLn js

exitSuccess

inputFiles :: Term [FilePath]

inputFiles = nonEmpty $ posAny [] $ posInfo

{ posDoc = "The input .ps files" }

outputFile :: Term (Maybe FilePath)

outputFile = value $ opt Nothing $ (optInfo [ "o", "output" ])

{ optDoc = "The output .js file" }

term :: Term (IO ())

term = compile <$> inputFiles <*> outputFile

termInfo :: TermInfo

termInfo = defTI

{ termName = "psc"

, version = "1.0"

, termDoc = "Compiles PureScript to Javascript"

}

main = run (term, termInfo)

-- |

module PureScript (

module PureScript.Values,

module PureScript.Types,

module PureScript.Kinds,

module PureScript.Declarations,

module PureScript.Parser,

module PureScript.CodeGen,

module PureScript.TypeChecker

) where

import PureScript.Values

import PureScript.Types

import PureScript.Kinds

import PureScript.Declarations

import PureScript.Parser

import PureScript.CodeGen

import PureScript.TypeChecker

-- |

module PureScript.CodeGen (

declToJs

) where

import Data.List (nub, intersperse, intercalate)

import PureScript.Values

import PureScript.Declarations

declToJs :: Declaration -> Maybe String

declToJs (ValueDeclaration name val) = Just $ "var " ++ name ++ " = " ++ valueToJs val ++ ";"

declToJs (DataDeclaration dcs@(DataConstructors { dataConstructors = ctors })) =

Just $ concatMap (\(ctor, _) -> "var " ++ ctor ++ " = function (value) { return { ctor: '" ++ ctor ++ "', value: value }; };") ctors

declToJs _ = Nothing

valueToJs :: Value -> String

valueToJs (NumericLiteral n) = show n

valueToJs (StringLiteral s) = show s

valueToJs (BooleanLiteral True) = "true"

valueToJs (BooleanLiteral False) = "false"

valueToJs (Unary op value) = unaryOperatorString op ++ "(" ++ valueToJs value ++ ")"

valueToJs (Binary op left right) = "(" ++ valueToJs left ++ ") " ++ binaryOperatorString op ++ " (" ++ valueToJs right ++ ")"

valueToJs (ArrayLiteral xs) = "[" ++ intercalate "," (map valueToJs xs) ++ "]"

valueToJs (ObjectLiteral ps) = "{" ++ intercalate "," (map objectPropertyToJs ps) ++ "}"

valueToJs (Accessor prop val) = "(" ++ valueToJs val ++ ")." ++ prop

valueToJs (Abs args value) = "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs value ++ "; }"

valueToJs (Var ident) = ident

valueToJs (App f xs) = "(" ++ valueToJs f ++ ") (" ++ intercalate "," (map valueToJs xs) ++ ")"

valueToJs (Block sts) = "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()"

valueToJs (Constructor name) = name

valueToJs (Case value binders) =

"(function (_0) {"

++ concatMap (\(b, val) -> fst $ binderToJs 0 0 b $ "return " ++ valueToJs val ++ ";") binders

++ "throw \"Failed pattern match\";"

++ "})(" ++ valueToJs value ++ ")"

valueToJs (TypedValue value _) = valueToJs value

unaryOperatorString :: UnaryOperator -> String

unaryOperatorString Negate = "-"

unaryOperatorString Not = "!"

unaryOperatorString BitwiseNot = "~"

binaryOperatorString :: BinaryOperator -> String

binaryOperatorString Add = "+"

binaryOperatorString Subtract = "-"

binaryOperatorString Multiply = "*"

binaryOperatorString Divide = "/"

binaryOperatorString Modulus = "%"

binaryOperatorString LessThan = "<"

binaryOperatorString LessThanOrEqualTo = "<="

binaryOperatorString GreaterThan = ">"

binaryOperatorString GreaterThanOrEqualTo = ">="

binaryOperatorString BitwiseAnd = "&"

binaryOperatorString BitwiseOr = "|"

binaryOperatorString BitwiseXor = "^"

binaryOperatorString ShiftLeft = "<<"

binaryOperatorString ShiftRight = ">>"

binaryOperatorString ZeroFillShiftRight = ">>>"

binaryOperatorString EqualTo = "==="

binaryOperatorString NotEqualTo = "!=="

binaryOperatorString And = "&&"

binaryOperatorString Or = "||"

binaryOperatorString Concat = "+"

binderToJs :: Int -> Int -> Binder -> String -> (String, Int)

binderToJs varName fresh (VarBinder s) done = ("var " ++ s ++ " = _" ++ show varName ++ "; " ++ done, fresh)

binderToJs varName fresh (ConstructorBinder ctor b) done =

("if (_" ++ show varName ++ ".ctor === \"" ++ ctor ++ "\") {"

++ "var _" ++ show fresh' ++ " = _" ++ show varName ++ ".value;"

++ js

++ "}", fresh'')

where

fresh' = succ fresh

(js, fresh'') = binderToJs fresh' fresh' b done

binderToJs varName fresh (ObjectBinder bs) done = go fresh bs done

where

go fresh [] done = (done, fresh)

go fresh ((prop, binder):bs') done =

( "var _" ++ show fresh' ++ " = _" ++ show varName ++ "." ++ prop ++ ";"

++ js

, fresh''')

where

fresh' = succ fresh

(done', fresh'') = go fresh' bs' done

(js, fresh''') = binderToJs fresh' fresh'' binder done'

objectPropertyToJs :: (String, Value) -> String

objectPropertyToJs (key, value) = key ++ ":" ++ valueToJs value

statementToJs :: Statement -> String

statementToJs (VariableIntroduction name value) = "var " ++ name ++ " = " ++ valueToJs value

statementToJs (Assignment target value) = target ++ " = " ++ valueToJs value

statementToJs (While cond sts) = "while ("

++ valueToJs cond ++ ") {"

++ intercalate ";" (map statementToJs sts) ++ "}"

statementToJs (For (init, cond, done) sts) = "for (" ++

statementToJs init

++ "; " ++ valueToJs cond

++ "; " ++ statementToJs done

++ ") {" ++ intercalate ";" (map statementToJs sts) ++ "}"

statementToJs (IfThenElse cond thens elses) = "if ("

++ valueToJs cond ++ ") {"

++ intercalate ";" (map statementToJs thens) ++ "}"

++ flip (maybe "") elses (\sts ->

" else {" ++ intercalate ";" (map statementToJs sts) ++ "}")

statementToJs (Return value) = "return " ++ valueToJs value

-- |

module PureScript.Declarations (

Declaration (..),

DataConstructors (..)

) where

import PureScript.Values

import PureScript.Types

data Declaration

= DataDeclaration DataConstructors

| TypeDeclaration String Type

| ValueDeclaration String Value deriving Show

data DataConstructors = DataConstructors

{ typeConstructorName :: String

, typeArguments :: [String]

, dataConstructors :: [(String, Type)]

} deriving Show

-- |

module PureScript.Kinds (

Kind (..)

) where

data Kind

= KUnknown Int

| Star

| Row

| FunKind Kind Kind deriving Eq

instance Show Kind where

show (KUnknown _) = "?"

show Star = "*"

show Row = "R"

show (FunKind k1 k2) = "(" ++ show k1 ++ ") -> (" ++ show k2 ++ ")"

-- |

module PureScript.Parser (

module PureScript.Parser.Types,

module PureScript.Parser.Values,

module PureScript.Parser.Declarations

) where

import PureScript.Parser.Types

import PureScript.Parser.Values

import PureScript.Parser.Declarations