summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--examples/passing/2787.purs8
-rw-r--r--examples/passing/TCO.purs8
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs28
-rw-r--r--src/Language/PureScript/CoreImp/Optimizer/Blocks.hs8
-rw-r--r--src/Language/PureScript/CoreImp/Optimizer/TCO.hs8
-rw-r--r--src/Language/PureScript/Docs/AsHtml.hs2
-rw-r--r--src/Language/PureScript/Docs/Convert/Single.hs16
-rw-r--r--stack.yaml6
-rw-r--r--tests/TestUtils.hs9
-rw-r--r--tests/support/bower.json30
11 files changed, 77 insertions, 48 deletions
diff --git a/examples/passing/2787.purs b/examples/passing/2787.purs
new file mode 100644
index 0000000..d7e957a
--- /dev/null
+++ b/examples/passing/2787.purs
@@ -0,0 +1,8 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console
+
+main
+ | between 0 1 2 = log "Fail"
+ | otherwise = log "Done"
diff --git a/examples/passing/TCO.purs b/examples/passing/TCO.purs
index dc55311..fbd9951 100644
--- a/examples/passing/TCO.purs
+++ b/examples/passing/TCO.purs
@@ -2,6 +2,8 @@ module Main where
import Prelude
import Control.Monad.Eff.Console (log, logShow)
+import Control.Monad.Rec.Class
+import Data.Array ((..), span, length)
main = do
let f x = x + 1
@@ -11,6 +13,12 @@ main = do
logShow (applyN 2 f v)
logShow (applyN 3 f v)
logShow (applyN 4 f v)
+
+ let largeArray = 1..10000
+ logShow (length (span (\_ -> true) largeArray).init)
+
+ logShow (tailRec (\n -> if n < 10000 then Loop (n + 1) else Done 42) 0)
+
log "Done"
applyN :: forall a. Int -> (a -> a) -> a -> a
diff --git a/purescript.cabal b/purescript.cabal
index 0df22a1..f9dc2d8 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.11.0
+version: 0.11.1
cabal-version: >=1.8
build-type: Simple
license: BSD3
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 991223a..4a67550 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -9,7 +9,7 @@ module Language.PureScript.CodeGen.JS
import Prelude.Compat
import Protolude (ordNub)
-import Control.Arrow ((&&&), second)
+import Control.Arrow ((&&&))
import Control.Monad (forM, replicateM, void)
import Control.Monad.Except (MonadError, throwError)
import Control.Monad.Reader (MonadReader, asks)
@@ -329,25 +329,13 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
valueError s _ = accessorString "name" . accessorString "constructor" $ AST.Var Nothing s
guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
- guardsToJs (Left gs) = snd <$> F.foldrM genGuard (False, []) gs
- where
- genGuard (cond, val) (False, js) = second (: js) <$> genCondVal cond val
- genGuard _ x = pure x
-
- genCondVal cond val
- | condIsTrue cond = do
- js <- AST.Return Nothing <$> valueToJs val
- return (True, js)
- | otherwise = do
- cond' <- valueToJs cond
- val' <- valueToJs val
- return
- (False, AST.IfElse Nothing cond'
- (AST.Block Nothing [AST.Return Nothing val']) Nothing)
-
- -- hopefully the inliner did its job and inlined `otherwise`
- condIsTrue (Literal _ (BooleanLiteral True)) = True
- condIsTrue _ = False
+ guardsToJs (Left gs) = traverse genGuard gs where
+ genGuard (cond, val) = do
+ cond' <- valueToJs cond
+ val' <- valueToJs val
+ return
+ (AST.IfElse Nothing cond'
+ (AST.Block Nothing [AST.Return Nothing val']) Nothing)
guardsToJs (Right v) = return . AST.Return Nothing <$> valueToJs v
diff --git a/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs
index 47b2373..04febf2 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs
@@ -10,19 +10,19 @@ import Language.PureScript.CoreImp.AST
-- | Collapse blocks which appear nested directly below another block
collapseNestedBlocks :: AST -> AST
-collapseNestedBlocks = everywhere collapse
- where
+collapseNestedBlocks = everywhere collapse where
collapse :: AST -> AST
collapse (Block ss sts) = Block ss (concatMap go sts)
collapse js = js
+
go :: AST -> [AST]
go (Block _ sts) = sts
go s = [s]
collapseNestedIfs :: AST -> AST
-collapseNestedIfs = everywhere collapse
- where
+collapseNestedIfs = everywhere collapse where
collapse :: AST -> AST
+ collapse (IfElse _ (BooleanLiteral _ True) (Block _ [js]) _) = js
collapse (IfElse s1 cond1 (Block _ [IfElse s2 cond2 body Nothing]) Nothing) =
IfElse s1 (Binary s2 And cond1 cond2) body Nothing
collapse js = js
diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
index 7d8518a..f27a843 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
@@ -68,6 +68,14 @@ tco = everywhere convert where
= all allInTailPosition body
allInTailPosition (Throw _ js1)
= countSelfReferences js1 == 0
+ allInTailPosition (ReturnNoResult _)
+ = True
+ allInTailPosition (VariableIntroduction _ _ js1)
+ = all ((== 0) . countSelfReferences) js1
+ allInTailPosition (Assignment _ _ js1)
+ = countSelfReferences js1 == 0
+ allInTailPosition (Comment _ _ js1)
+ = allInTailPosition js1
allInTailPosition _
= False
diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs
index e99c5b6..c3eec5b 100644
--- a/src/Language/PureScript/Docs/AsHtml.hs
+++ b/src/Language/PureScript/Docs/AsHtml.hs
@@ -126,7 +126,7 @@ declAsHtml r d@Declaration{..} = do
H.div ! A.class_ "decl" ! A.id (v (T.drop 1 declFragment)) $ do
h3 ! A.class_ "decl__title clearfix" $ do
a ! A.class_ "decl__anchor" ! A.href (v declFragment) $ "#"
- text declTitle
+ H.span $ text declTitle
for_ declSourceSpan (linkToSource r)
H.div ! A.class_ "decl__body" $ do
diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs
index 84b0b62..0c4ce09 100644
--- a/src/Language/PureScript/Docs/Convert/Single.hs
+++ b/src/Language/PureScript/Docs/Convert/Single.hs
@@ -25,6 +25,13 @@ convertSingleModule m@(P.Module _ coms moduleName _ _) =
>>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)
>>> augmentDeclarations
+-- | Different declarations we can augment
+data AugmentType
+ = AugmentClass
+ -- ^ Augment documentation for a type class
+ | AugmentType
+ -- ^ Augment documentation for a type constructor
+
-- | The data type for an intermediate stage which we go through during
-- converting.
--
@@ -43,7 +50,7 @@ convertSingleModule m@(P.Module _ coms moduleName _ _) =
-- instance. For a fixity declaration, it would be just the relevant operator's
-- name.
type IntermediateDeclaration
- = Either ([Text], DeclarationAugment) Declaration
+ = Either ([(Text, AugmentType)], DeclarationAugment) Declaration
-- | Some data which will be used to augment a Declaration in the
-- output.
@@ -64,10 +71,13 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) =
where
go ds (parentTitles, a) =
map (\d ->
- if declTitle d `elem` parentTitles
+ if any (matches d) parentTitles
then augmentWith a d
else d) ds
+ matches d (name, AugmentType) = isType d && declTitle d == name
+ matches d (name, AugmentClass) = isTypeClass d && declTitle d == name
+
augmentWith (AugmentChild child) d =
d { declChildren = declChildren d ++ [child] }
@@ -132,7 +142,7 @@ convertDeclaration (P.TypeClassDeclaration _ args implies fundeps ds) title =
convertClassMember _ =
P.internalError "convertDeclaration: Invalid argument to convertClassMember."
convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =
- Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))
+ Just (Left ((classNameString, AugmentClass) : map (, AugmentType) typeNameStrings, AugmentChild childDecl))
where
classNameString = unQual className
typeNameStrings = ordNub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
diff --git a/stack.yaml b/stack.yaml
index 4e9e34c..c04a09e 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,7 +1,5 @@
-resolver: lts-6.25
+resolver: lts-8.5
packages:
- '.'
extra-deps:
-- aeson-better-errors-0.9.1.0
-- bower-json-1.0.0.1
-- optparse-applicative-0.13.0.0
+- pipes-http-1.0.5
diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
index 3e04f69..86a99f6 100644
--- a/tests/TestUtils.hs
+++ b/tests/TestUtils.hs
@@ -113,6 +113,15 @@ supportModules =
, "Data.Generic.Rep.Show"
, "Data.HeytingAlgebra"
, "Data.Identity"
+ , "Data.Lazy"
+ , "Data.List"
+ , "Data.List.Lazy"
+ , "Data.List.Lazy.NonEmpty"
+ , "Data.List.Lazy.Types"
+ , "Data.List.NonEmpty"
+ , "Data.List.Partial"
+ , "Data.List.Types"
+ , "Data.List.ZipList"
, "Data.Maybe"
, "Data.Maybe.First"
, "Data.Maybe.Last"
diff --git a/tests/support/bower.json b/tests/support/bower.json
index bae32d6..bdee017 100644
--- a/tests/support/bower.json
+++ b/tests/support/bower.json
@@ -1,21 +1,21 @@
{
"name": "purescript-test-suite-support",
"dependencies": {
- "purescript-arrays": "ps-0.11",
- "purescript-assert": "ps-0.11",
- "purescript-console": "ps-0.11",
- "purescript-eff": "ps-0.11",
- "purescript-functions": "ps-0.11",
- "purescript-generics": "ps-0.11",
- "purescript-generics-rep": "ps-0.11",
- "purescript-newtype": "ps-0.11",
+ "purescript-arrays": "4.0.0",
+ "purescript-assert": "3.0.0",
+ "purescript-console": "3.0.0",
+ "purescript-eff": "3.0.0",
+ "purescript-functions": "3.0.0",
+ "purescript-generics": "4.0.0",
+ "purescript-generics-rep": "5.0.0",
+ "purescript-newtype": "2.0.0",
"purescript-partial": "1.2.0",
- "purescript-prelude": "ps-0.11",
- "purescript-psci-support": "ps-0.11",
- "purescript-st": "ps-0.11",
- "purescript-symbols": "ps-0.11",
- "purescript-tailrec": "ps-0.11",
- "purescript-typelevel-prelude": "ps-0.11",
- "purescript-unsafe-coerce": "ps-0.11"
+ "purescript-prelude": "3.0.0",
+ "purescript-psci-support": "3.0.0",
+ "purescript-st": "3.0.0",
+ "purescript-symbols": "3.0.0",
+ "purescript-tailrec": "3.0.0",
+ "purescript-typelevel-prelude": "2.0.0",
+ "purescript-unsafe-coerce": "3.0.0"
}
}