summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-01-11 01:21:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-01-11 01:21:00 (GMT)
commita09bc6d8dc8e4f8abaae75e60c5e1af321c2b250 (patch)
tree933d748f98e310565c956673c1517088f9df5a8c
parentb613dc6ec6edfc84e95fc62f4d4858153a1c8d41 (diff)
version 0.2.110.2.11
-rw-r--r--libraries/prelude/prelude.purs329
-rw-r--r--purescript.cabal3
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs41
-rw-r--r--src/Language/PureScript/CodeGen/Monad.hs21
-rw-r--r--src/Language/PureScript/CodeGen/Optimize.hs16
-rw-r--r--src/Language/PureScript/Scope.hs21
-rw-r--r--src/Language/PureScript/TypeChecker.hs15
-rw-r--r--src/Main.hs28
8 files changed, 402 insertions, 72 deletions
diff --git a/libraries/prelude/prelude.purs b/libraries/prelude/prelude.purs
new file mode 100644
index 0000000..4183cf2
--- /dev/null
+++ b/libraries/prelude/prelude.purs
@@ -0,0 +1,329 @@
+module Prelude where
+
+ id :: forall a. a -> a
+ id = \x -> x
+
+ flip :: forall a b c. (a -> b -> c) -> b -> a -> c
+ flip = \f -> \b -> \a -> f a b
+
+ konst :: forall a b. a -> b -> a
+ konst = \a -> \b -> a
+
+ (|>) :: forall a b c. (a -> b) -> (b -> c) -> a -> c
+ (|>) = \f -> \g -> \a -> g (f a)
+
+ infixr 5 |>
+
+ (<|) :: forall a b c. (b -> c) -> (a -> b) -> a -> c
+ (<|) = flip (|>)
+
+ infixr 5 <|
+
+ ($) :: forall a b. (a -> b) -> a -> b
+ ($) f x = f x
+
+ infixr 1000 $
+
+module Maybe where
+
+ data Maybe a = Nothing | Just a
+
+ maybe :: forall a b. b -> (a -> b) -> Maybe a -> b
+ maybe b _ Nothing = b
+ maybe _ f (Just a) = f a
+
+ fromMaybe :: forall a. a -> Maybe a -> a
+ fromMaybe a = maybe a Prelude.id
+
+ bindMaybe :: forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
+ bindMaybe m f = maybe Nothing f m
+
+module Either where
+
+ data Either a b = Left a | Right b
+
+ either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
+ either f _ (Left a) = f a
+ either _ g (Right b) = g b
+
+ bindEither :: forall e a b. Either e a -> (a -> Either e b) -> Either e b
+ bindEither = either (\e _ -> Left e) (\a f -> f a)
+
+module Arrays where
+
+ import Maybe
+
+ head :: forall a. [a] -> a
+ head (x : _) = x
+
+ headSafe :: forall a. [a] -> Maybe a
+ headSafe (x : _) = Just x
+ headSafe _ = Nothing
+
+ tail :: forall a. [a] -> [a]
+ tail (_ : xs) = xs
+
+ tailSafe :: forall a. [a] -> Maybe [a]
+ tailSafe (_ : xs) = Just xs
+ tailSafe _ = Nothing
+
+ map :: forall a b. (a -> b) -> [a] -> [b]
+ map _ [] = []
+ map f (x:xs) = f x : map f xs
+
+ foldr :: forall a b. (a -> b -> a) -> a -> [b] -> a
+ foldr f a (b : bs) = f (foldr f a bs) b
+ foldr _ a [] = a
+
+ foldl :: forall a b. (a -> b -> b) -> b -> [a] -> b
+ foldl _ b [] = b
+ foldl f b (a:as) = foldl f (f a b) as
+
+ foreign import length "function length(xs) { \
+ \ return xs.length; \
+ \}" :: forall a. [a] -> Number
+
+ foreign import indexOf :: forall a. [a] -> a -> Number
+
+ foreign import lastIndexOf :: forall a. [a] -> a -> Number
+
+ foreign import concat :: forall a. [a] -> [a] -> [a]
+
+ foreign import join :: [String] -> String
+
+ foreign import joinWith :: [String] -> String -> String
+
+ foreign import push :: forall a. [a] -> a -> [a]
+
+ foreign import reverse :: forall a. [a] -> [a]
+
+ foreign import shift :: forall a. [a] -> [a]
+
+ foreign import slice :: forall a. Number -> Number -> [a] -> [a]
+
+ foreign import sort :: forall a. [a] -> [a]
+
+ foreign import splice :: forall a. Number -> Number -> [a] -> [a] -> [a]
+
+ infixr 6 :
+
+ (:) :: forall a. a -> [a] -> [a]
+ (:) a = concat [a]
+
+ concatMap :: forall a b. [a] -> (a -> [b]) -> [b]
+ concatMap [] f = []
+ concatMap (a:as) f = f a `concat` concatMap as f
+
+ filter :: forall a. (a -> Boolean) -> [a] -> [a]
+ filter _ [] = []
+ filter p (x:xs) | p x = x : filter p xs
+ filter p (_:xs) = filter p xs
+
+ empty :: forall a. [a] -> Boolean
+ empty [] = true
+ empty _ = false
+
+ range :: Number -> Number -> [Number]
+ range lo hi = {
+ var ns = [];
+ for (n <- lo until hi) {
+ ns = push ns n;
+ }
+ return ns;
+ }
+
+ zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
+ zipWith f (a:as) (b:bs) = f a b : zipWith f as bs
+ zipWith _ _ _ = []
+
+ any :: forall a. (a -> Boolean) -> [a] -> Boolean
+ any _ [] = false
+ any p (a:as) = p a || any p as
+
+ all :: forall a. (a -> Boolean) -> [a] -> Boolean
+ all _ [] = true
+ all p (a:as) = p a && all p as
+
+module Tuple where
+
+ import Arrays
+
+ type Tuple a b = { fst :: a, snd :: b }
+
+ curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c
+ curry f a b = f { fst: a, snd: b }
+
+ uncurry :: forall a b c. (a -> b -> c) -> Tuple a b -> c
+ uncurry f t = f t.fst t.snd
+
+ tuple :: forall a b. a -> b -> Tuple a b
+ tuple = curry Prelude.id
+
+ zip :: forall a b. [a] -> [b] -> [Tuple a b]
+ zip = zipWith tuple
+
+ unzip :: forall a b. [Tuple a b] -> Tuple [a] [b]
+ unzip (t:ts) = case unzip ts of
+ { fst = as, snd = bs } -> tuple (t.fst : as) (t.snd : bs)
+ unzip [] = tuple [] []
+
+module String where
+
+ foreign import lengthS "function lengthS(s) {\
+ \ return s.length;\
+ \}" :: String -> Number
+
+ foreign import charAt :: Number -> String -> String
+
+ foreign import indexOfS :: String -> String -> Number
+
+ foreign import lastIndexOfS :: String -> String -> Number
+
+ foreign import localeCompare :: String -> String -> Number
+
+ foreign import replace :: String -> String -> String -> String
+
+ foreign import sliceS :: Number -> Number -> String -> String
+
+ foreign import split :: String -> String -> [String]
+
+ foreign import substr :: Number -> Number -> String -> String
+
+ foreign import substring :: Number -> Number -> String -> String
+
+ foreign import toLower :: String -> String
+
+ foreign import toUpper :: String -> String
+
+ foreign import trim :: String -> String
+
+module Regex where
+
+ foreign import data Regex :: *
+
+ foreign import regex :: String -> String -> Regex
+
+ foreign import test :: Regex -> String -> Boolean
+
+ foreign import match :: Regex -> String -> [String]
+
+ foreign import replaceR :: Regex -> String -> String -> String
+
+ foreign import search :: Regex -> String -> Number
+
+module Global where
+
+ foreign import nan :: Number
+
+ foreign import infinity :: Number
+
+ foreign import toExponential :: Number -> String
+
+ foreign import toFixed :: Number -> Number -> String
+
+ foreign import toPrecision :: Number -> Number -> String
+
+ foreign import numberToString :: Number -> String
+
+ foreign import isNaN :: Number -> Boolean
+
+ foreign import isFinite :: Number -> Boolean
+
+ foreign import parseFloat :: String -> Number
+
+ foreign import parseInt :: String -> Number
+
+ foreign import encodeURIComponent :: String -> String
+
+ foreign import decodeURIComponent :: String -> String
+
+ foreign import encodeURI :: String -> String
+
+ foreign import decodeURI :: String -> String
+
+module Math where
+
+ type Math =
+ { abs :: Number -> Number
+ , acos :: Number -> Number
+ , asin :: Number -> Number
+ , atan :: Number -> Number
+ , atan2 :: (Number, Number) -> Number
+ , aceil :: Number -> Number
+ , cos :: Number -> Number
+ , exp :: Number -> Number
+ , floor :: Number -> Number
+ , log :: Number -> Number
+ , max :: (Number, Number) -> Number
+ , pow :: (Number, Number) -> Number
+ , random :: () -> Number
+ , round :: Number -> Number
+ , sin :: Number -> Number
+ , sqrt :: Number -> Number
+ , tan :: Number -> Number
+ }
+
+ foreign import math :: Math
+
+module Eff where
+
+ foreign import data Eff :: # ! -> * -> *
+
+ foreign import retEff "function retEff(a) { return function() { return a; }; }" :: forall e a. a -> Eff e a
+
+ foreign import bindEff "function bindEff(a) { return function(f) { return function() { return f(a())(); }; }; }" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
+
+ type Pure a = forall e. Eff e a
+
+ foreign import runPure :: forall a. Pure a -> a
+
+ eff = { ret: retEff, bind: bindEff }
+
+module Errors where
+
+ import Eff
+
+ foreign import data Error :: * -> !
+
+ foreign import throwError "function throwError(e) { return function() { throw e; }; }" :: forall a e r. e -> Eff (err :: Error e | r) a
+
+ foreign import catchError "function catchError(c) { return function(t) { return function() { try { return t(); } catch(e) { return c(e)(); } }; }; }" :: forall e r a. (e -> Eff r a) -> Eff (err :: Error e | r) a -> Eff r a
+
+module IORef where
+
+ import Eff
+
+ foreign import data Ref :: !
+
+ foreign import data IORef :: * -> *
+
+ foreign import newIORef :: forall s r. s -> Eff (ref :: Ref | r) (IORef s)
+
+ foreign import readIORef :: forall s r. IORef s -> Eff (ref :: Ref | r) s
+
+ foreign import writeIORef :: forall s r. IORef s -> s -> Eff (ref :: Ref | r) {}
+
+module Trace where
+
+ import Eff
+
+ foreign import data Trace :: !
+
+ foreign import trace "function trace(s) { return function() { console.log(s); return {}; }; }" :: forall r. String -> Eff (trace :: Trace | r) {}
+
+module ST where
+
+ import Eff
+
+ foreign import data ST :: * -> !
+
+ foreign import data STRef :: * -> * -> *
+
+ foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
+
+ foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
+
+ foreign import modifySTRef :: forall a h r. (a -> a) -> STRef h a -> Eff (st :: ST h | r) {}
+
+ foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
+
diff --git a/purescript.cabal b/purescript.cabal
index 825e3d8..957a8d3 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.2.10.2
+version: 0.2.11
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -12,6 +12,7 @@ description: A small compile-to-JS language with extensible records and type-saf
category: Language
author: Phil Freeman <paf31@cantab.net>
data-dir: ""
+data-files: libraries/prelude/prelude.purs
library
build-depends: base >=4 && <5, cmdtheline -any, containers -any,
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 1765dda..225ab6c 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -86,7 +86,7 @@ valueToJs _ m e (Constructor (Qualified Nothing name)) =
_ -> JSVar . Ident . runProperName $ name
valueToJs _ _ _ (Constructor name) = qualifiedToJS runProperName name
valueToJs opts m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs opts m e) sts))) []
-valueToJs opts m e (Case values binders) = runGen (bindersToJs opts m e binders (map (valueToJs opts m e) values))
+valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values)
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) = JSAccessor prop (valueToJs opts m e val)
valueToJs opts m e (Indexer index val) = JSIndexer (valueToJs opts m e index) (valueToJs opts m e val)
@@ -144,15 +144,14 @@ qualifiedToJS :: (a -> String) -> Qualified a -> JS
qualifiedToJS f (Qualified (Just (ModuleName (ProperName m))) a) = JSAccessor (f a) (JSVar (Ident m))
qualifiedToJS f (Qualified Nothing a) = JSVar (Ident (f a))
-bindersToJs :: Options -> ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS
-bindersToJs opts m e binders vals = do
- setNextName $ firstUnusedName (binders, vals)
+bindersToJs :: Options -> ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> JS
+bindersToJs opts m e binders vals = runGen (unusedNames (binders, vals)) $ do
valNames <- replicateM (length vals) fresh
jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs opts m e result)] bs grd
- return $ JSApp (JSFunction Nothing (map Ident valNames) (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
+ return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
vals
where
- go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]
+ go :: [Ident] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]
go _ done [] Nothing = return done
go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]
go (v:vs) done' (b:bs) grd = do
@@ -160,24 +159,24 @@ bindersToJs opts m e binders vals = do
binderToJs m e v done'' b
go _ _ _ _ = error "Invalid arguments to bindersToJs"
-binderToJs :: ModuleName -> Environment -> String -> [JS] -> Binder -> Gen [JS]
+binderToJs :: ModuleName -> Environment -> Ident -> [JS] -> Binder -> Gen [JS]
binderToJs _ _ _ done NullBinder = return done
binderToJs _ _ varName done (StringBinder str) =
- return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]
+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
binderToJs _ _ varName done (NumberBinder num) =
- return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSNumericLiteral num)) (JSBlock done) Nothing]
+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
binderToJs _ _ varName done (BooleanBinder True) =
- return [JSIfElse (JSVar (Ident varName)) (JSBlock done) Nothing]
+ return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
binderToJs _ _ varName done (BooleanBinder False) =
- return [JSIfElse (JSUnary Not (JSVar (Ident varName))) (JSBlock done) Nothing]
+ return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
binderToJs _ _ varName done (VarBinder ident) =
- return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : done)
+ return (JSVariableIntroduction ident (Just (JSVar varName)) : done)
binderToJs m _ varName done (NullaryBinder ctor) =
- return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]
+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]
binderToJs m e varName done (UnaryBinder ctor b) = do
value <- fresh
js <- binderToJs m e value done b
- return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock (JSVariableIntroduction (Ident value) (Just (JSAccessor "value" (JSVar (Ident varName)))) : js)) Nothing]
+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock (JSVariableIntroduction value (Just (JSAccessor "value" (JSVar varName))) : js)) Nothing]
binderToJs m e varName done (ObjectBinder bs) = go done bs
where
go :: [JS] -> [(String, Binder)] -> Gen [JS]
@@ -186,10 +185,10 @@ binderToJs m e varName done (ObjectBinder bs) = go done bs
propVar <- fresh
done'' <- go done' bs'
js <- binderToJs m e propVar done'' binder
- return (JSVariableIntroduction (Ident propVar) (Just (JSAccessor prop (JSVar (Ident varName)))) : js)
+ return (JSVariableIntroduction propVar (Just (JSAccessor prop (JSVar varName))) : js)
binderToJs m e varName done (ArrayBinder bs) = do
js <- go done 0 bs
- return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
+ return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
where
go :: [JS] -> Integer -> [Binder] -> Gen [JS]
go done' _ [] = return done'
@@ -197,20 +196,20 @@ binderToJs m e varName done (ArrayBinder bs) = do
elVar <- fresh
done'' <- go done' (index + 1) bs'
js <- binderToJs m e elVar done'' binder
- return (JSVariableIntroduction (Ident elVar) (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName)))) : js)
+ return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
binderToJs m e varName done (ConsBinder headBinder tailBinder) = do
headVar <- fresh
tailVar <- fresh
js1 <- binderToJs m e headVar done headBinder
js2 <- binderToJs m e tailVar js1 tailBinder
- return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left 0))) (JSBlock
- ( JSVariableIntroduction (Ident headVar) (Just (JSIndexer (JSNumericLiteral (Left 0)) (JSVar (Ident varName)))) :
- JSVariableIntroduction (Ident tailVar) (Just (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left 1)])) :
+ 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 ident (Just (JSVar (Ident varName))) : js)
+ return (JSVariableIntroduction ident (Just (JSVar varName)) : js)
statementToJs :: Options -> ModuleName -> Environment -> Statement -> JS
statementToJs opts m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs opts m e value))
diff --git a/src/Language/PureScript/CodeGen/Monad.hs b/src/Language/PureScript/CodeGen/Monad.hs
index 0ea9f5d..0e8b165 100644
--- a/src/Language/PureScript/CodeGen/Monad.hs
+++ b/src/Language/PureScript/CodeGen/Monad.hs
@@ -18,20 +18,15 @@ module Language.PureScript.CodeGen.Monad where
import Control.Monad.State
import Control.Applicative
+import Language.PureScript.Names
-newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int, MonadFix)
+newtype Gen a = Gen { unGen :: State [Ident] a } deriving (Functor, Applicative, Monad, MonadState [Ident])
-runGen :: Gen a -> a
-runGen = flip evalState 0 . unGen
+runGen :: [Ident] -> Gen a -> a
+runGen names = flip evalState names . unGen
-fresh :: Gen String
+fresh :: Gen Ident
fresh = do
- n <- get
- modify (+ 1)
- return $ '_' : show n
-
-getNextName :: Gen Int
-getNextName = get
-
-setNextName :: Int -> Gen ()
-setNextName = put
+ (s:ss) <- get
+ put ss
+ return s
diff --git a/src/Language/PureScript/CodeGen/Optimize.hs b/src/Language/PureScript/CodeGen/Optimize.hs
index 4c5ca78..cf35150 100644
--- a/src/Language/PureScript/CodeGen/Optimize.hs
+++ b/src/Language/PureScript/CodeGen/Optimize.hs
@@ -49,9 +49,17 @@ isReassigned :: (Data d) => Ident -> d -> Bool
isReassigned var1 = everything (||) (mkQ False check)
where
check :: JS -> Bool
- check (JSAssignment (JSAssignVariable var2) _) | var1 == var2 = True
+ check (JSFunction _ args _) | var1 `elem` args = True
check _ = False
+isRebound :: (Data d) => JS -> d -> Bool
+isRebound (JSVar var1) = everything (||) (mkQ False check)
+ where
+ check :: JS -> Bool
+ check (JSFunction _ args _) | var1 `elem` args = True
+ check _ = False
+isRebound _ = const False
+
isUsed :: (Data d) => Ident -> d -> Bool
isUsed var1 = everything (||) (mkQ False check)
where
@@ -80,7 +88,7 @@ inlineVariables = everywhere (mkT removeFromBlock)
removeFromBlock js = js
go :: [JS] -> [JS]
go [] = []
- go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts)
+ go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) = go (replaceIdent var js sts)
go (s:sts) = s : go sts
removeUnusedVariables :: JS -> JS
@@ -98,8 +106,8 @@ etaConvert :: JS -> JS
etaConvert = everywhere (mkT convert)
where
convert :: JS -> JS
- convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents (JSBlock body)) args)])
- | all shouldInline args = JSBlock (replaceIdents (zip idents args) body)
+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
+ | all shouldInline args && not (or (map (flip isRebound block) args)) = JSBlock (replaceIdents (zip idents args) body)
convert js = js
unThunk :: JS -> JS
diff --git a/src/Language/PureScript/Scope.hs b/src/Language/PureScript/Scope.hs
index af6eaa3..6665e26 100644
--- a/src/Language/PureScript/Scope.hs
+++ b/src/Language/PureScript/Scope.hs
@@ -14,8 +14,7 @@
module Language.PureScript.Scope (
usedNames,
- unusedNames,
- firstUnusedName
+ unusedNames
) where
import Data.Data
@@ -25,7 +24,6 @@ import Data.Generics (extQ, mkQ, everything)
import Language.PureScript.Values
import Language.PureScript.Names
import Language.PureScript.CodeGen.JS.AST
-import Data.Maybe (mapMaybe)
usedNames :: (Data d) => d -> [Ident]
usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val
@@ -56,20 +54,3 @@ unusedNames val =
varNames = map (Ident . ('_' :) . show) ([1..] :: [Int])
in
varNames \\ allNames
-
-firstUnusedName :: (Data d) => d -> Int
-firstUnusedName val =
- let
- allNames = usedNames val
- varNames = mapMaybe toUnknown allNames
- in
- 1 + maximum (0 : varNames)
- where
- toUnknown :: Ident -> Maybe Int
- toUnknown (Ident ('_' : s)) = readMaybe s
- toUnknown _ = Nothing
-
-readMaybe :: String -> Maybe Int
-readMaybe s = case reads s of
- [(n, "")] -> Just n
- _ -> Nothing
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 8c979c7..d13d69c 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -155,22 +155,27 @@ typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do
moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))
shadowIdents idents' env =
forM_ idents' $ \ident -> do
- guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env
case (moduleName, ident) `M.lookup` names env of
- Just (pt, _) -> modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })
+ Just (_, Alias _ _) -> return ()
+ Just (pt, _) -> do
+ guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env
+ modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })
Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")
shadowTypes pns env =
forM_ pns $ \pn -> do
- guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env
case (moduleName, pn) `M.lookup` types env of
Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")
+ Just (_, DataAlias _ _) -> return ()
Just (k, _) -> do
+ guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env
modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })
let keys = map (snd . fst) . filter (\(_, (fn, _)) -> fn `constructs` pn) . M.toList . dataConstructors $ env
forM_ keys $ \dctor -> do
- guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env
case (moduleName, dctor) `M.lookup` dataConstructors env of
- Just (ctorTy, _) -> modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) (ctorTy, Alias moduleName (Ident (runProperName dctor))) (dataConstructors e) })
+ Just (_, Alias _ _) -> return ()
+ Just (ctorTy, _) -> do
+ guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env
+ modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) (ctorTy, Alias moduleName (Ident (runProperName dctor))) (dataConstructors e) })
Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")
constructs (TypeConstructor (Qualified (Just mn) pn')) pn
= mn == moduleName && pn' == pn
diff --git a/src/Main.hs b/src/Main.hs
index f6e4e29..1505683 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -21,6 +21,11 @@ import Control.Monad (forM)
import System.Exit (exitSuccess, exitFailure)
import qualified System.IO.UTF8 as U
import Text.Parsec (ParseError)
+import qualified Paths_purescript as Paths
+import Data.Version (showVersion)
+
+preludeFilename :: IO FilePath
+preludeFilename = Paths.getDataFileName "libraries/prelude/prelude.purs"
readInput :: Maybe [FilePath] -> IO (Either ParseError [P.Module])
readInput Nothing = getContents >>= return . P.runIndentParser P.parseModules
@@ -73,24 +78,31 @@ performRuntimeTypeChecks :: Term Bool
performRuntimeTypeChecks = value $ flag $ (optInfo [ "runtime-type-checks" ])
{ optDoc = "Generate runtime type checks" }
+noPrelude :: Term Bool
+noPrelude = value $ flag $ (optInfo [ "no-prelude" ])
+ { optDoc = "Omit the Prelude" }
+
options :: Term P.Options
options = P.Options <$> tco <*> performRuntimeTypeChecks
-stdInOrInputFiles :: Term (Maybe [FilePath])
-stdInOrInputFiles = combine <$> useStdIn <*> inputFiles
+stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])
+stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles
where
- combine False input = Just input
- combine True _ = Nothing
+ combine False True input = Just (prelude : input)
+ combine False False input = Just input
+ combine True _ _ = Nothing
-term :: Term (IO ())
-term = compile <$> options <*> stdInOrInputFiles <*> outputFile <*> externsFile
+term :: FilePath -> Term (IO ())
+term prelude = compile <$> options <*> stdInOrInputFiles prelude <*> outputFile <*> externsFile
termInfo :: TermInfo
termInfo = defTI
{ termName = "psc"
- , version = "1.0"
+ , version = showVersion $ Paths.version
, termDoc = "Compiles PureScript to Javascript"
}
main :: IO ()
-main = run (term, termInfo)
+main = do
+ prelude <- preludeFilename
+ run (term prelude, termInfo)