summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-07-15 02:05:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-07-15 02:05:00 (GMT)
commit6399ed506130f3f5df01289cda17f7b3b90bc9f3 (patch)
treec82ee2b91c9fdb84dd74b88f032c9ef1be7fe97d
parent3345c3dda7db1f188af95405d6464594f2df901f (diff)
version 0.5.30.5.3
-rw-r--r--prelude/prelude.purs11
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs20
-rw-r--r--src/Language/PureScript/Optimizer/TCO.hs2
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs7
5 files changed, 16 insertions, 26 deletions
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index 0900929..2284412 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -604,6 +604,9 @@ module Data.Eq where
(==) = liftRef refEq
(/=) = liftRef refIneq
+ instance functorRef :: Functor Ref where
+ (<$>) f (Ref x) = Ref (f x)
+
module Prelude.Unsafe where
foreign import unsafeIndex
@@ -684,9 +687,11 @@ module Control.Monad.Eff where
foreign import foreachE "function foreachE(as) {\
\ return function(f) {\
- \ for (var i = 0; i < as.length; i++) {\
- \ f(as[i])();\
- \ }\
+ \ return function() {\
+ \ for (var i = 0; i < as.length; i++) {\
+ \ f(as[i])();\
+ \ }\
+ \ };\
\ };\
\}" :: forall e a. [a] -> (a -> Eff e Unit) -> Eff e Unit
diff --git a/purescript.cabal b/purescript.cabal
index 743f0bf..9a31906 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.5.2.6
+version: 0.5.3
cabal-version: >=1.8
build-type: Custom
license: MIT
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 0c37a64..6184461 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -171,7 +171,7 @@ valueToJs opts m e (Let ds val) = do
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
+ ret <- valueToJs opts m 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
@@ -201,22 +201,6 @@ extendObj obj sts = do
stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
extend = map stToAssign sts
return $ JSApp (JSFunction Nothing [] block) []
- where
-
--- |
--- Temporarily extends the environment with a single local variable name
---
-bindName :: ModuleName -> Ident -> Environment -> Environment
-bindName m ident = bindNames m [ident]
-
--- |
--- Temporarily extends the environment to include local variable names introduced by lambda
--- abstractions or case statements
---
-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"
-- |
-- Generate code in the simplified Javascript intermediate representation for runtime type checks.
@@ -274,7 +258,7 @@ bindersToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> E
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
+ ret <- valueToJs opts m e result
go valNames [JSReturn ret] bs grd
return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
vals
diff --git a/src/Language/PureScript/Optimizer/TCO.hs b/src/Language/PureScript/Optimizer/TCO.hs
index ba5ed68..511b006 100644
--- a/src/Language/PureScript/Optimizer/TCO.hs
+++ b/src/Language/PureScript/Optimizer/TCO.hs
@@ -41,7 +41,7 @@ tco' = everywhereOnJS convert
in case () of
_ | isTailCall name body' ->
let
- allArgs = reverse $ concat argss
+ allArgs = concat $ reverse argss
in
JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
| otherwise -> js
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 3e2470b..349f32e 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -137,8 +137,9 @@ typeClassDictionaryDeclaration name args implies members =
, let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs
, let fieldName = mkSuperclassDictionaryName superclass index
], REmpty))
-
- in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList ((C.__superclasses, superclassesType) : map (first identToProperty . memberToNameAndType) members, REmpty))
+ members' = map (first identToProperty . memberToNameAndType) members
+ mtys = if null implies then members' else (C.__superclasses, superclassesType) : members'
+ in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))
typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration
typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
@@ -187,7 +188,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
, let fieldName = mkSuperclassDictionaryName superclass index
]
- let memberNames' = (C.__superclasses, superclasses) : memberNames
+ let memberNames' = if null implies then memberNames else (C.__superclasses, superclasses) : memberNames
dictTy = foldl TypeApp (TypeConstructor className) tys
constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'