Merge pull request #20 from purescript/fix-size-issues

Fix size issues (looping `unfoldable`, sub-zero `genNonEmpty` sizes)

Author: garyb

.travis.yml

@@ -11,9 +11,11 @@ install:
   - chmod a+x $HOME/purescript
   - npm install -g bower
   - npm install
-  - bower install
+  - bower install --production
 script:
   - npm run -s build
+  - bower install
+  - npm run -s test
 after_success:
 - >-
   test $TRAVIS_TAG &&

bower.json

@@ -26,5 +26,10 @@
     "purescript-tailrec": "^4.0.0",
     "purescript-tuples": "^5.0.0",
     "purescript-unfoldable": "^4.0.0"
+  },
+  "devDependencies": {
+    "purescript-assert": "^4.1.0",
+    "purescript-console": "^4.2.0",
+    "purescript-lcg": "^2.0.0"
   }
 }

package.json

@@ -2,7 +2,8 @@
   "private": true,
   "scripts": {
     "clean": "rimraf output && rimraf .pulp-cache",
-    "build": "pulp build -- --censor-lib --strict"
+    "build": "pulp build -- --censor-lib --strict",
+    "test": "pulp test"
   },
   "devDependencies": {
     "eslint": "^4.19.1",

src/Control/Monad/Gen.purs

@@ -91,12 +91,12 @@ unfoldable
 unfoldable gen = unfoldr unfold <$> sized (tailRecM loopGen <<< Tuple Nil)
   where
   loopGen :: Tuple (LL a) Int -> m (Step (Tuple (LL a) Int) (LL a))
-  loopGen = case _ of
-    Tuple acc 0 ->
-      pure $ Done acc
-    Tuple acc n -> do
-      x <- gen
-      pure $ Loop (Tuple (Cons x acc) (n - 1))
+  loopGen (Tuple acc n)
+    | n <= 0 =
+        pure $ Done acc
+    | otherwise = do
+        x <- gen
+        pure $ Loop (Tuple (Cons x acc) (n - 1))
   unfold :: LL a -> Maybe (Tuple a (LL a))
   unfold = case _ of
     Nil -> Nothing

src/Control/Monad/Gen/Common.purs

@@ -64,4 +64,4 @@ genNonEmpty
   => Unfoldable f
   => m a
   -> m (NonEmpty f a)
-genNonEmpty gen = (:|) <$> gen <*> resize (_ - 1) (unfoldable gen)
+genNonEmpty gen = (:|) <$> gen <*> resize (max 0 <<< (_ - 1)) (unfoldable gen)

test/Main.purs

@@ -0,0 +1,86 @@
+module Test.Main where
+
+import Prelude
+
+import Control.Monad.Gen as Gen
+import Control.Monad.Gen.Common as GenC
+import Control.Monad.Rec.Class (class MonadRec, tailRecM)
+import Data.Bifunctor (bimap)
+import Data.Int as Int
+import Data.NonEmpty (NonEmpty, (:|))
+import Data.Tuple (Tuple(..), snd)
+import Effect (Effect)
+import Effect.Class (class MonadEffect, liftEffect)
+import Effect.Class.Console (log)
+import Random.LCG as LCG
+import Test.Assert (assertEqual)
+
+main :: Effect Unit
+main = do
+
+  seed ← LCG.randomSeed
+
+  runTestGen seed do
+
+    log $ show seed
+
+    log "`unfoldable` should not loop on negative size"
+    nil :: Array Unit ← Gen.resize (const (-1)) $ Gen.unfoldable (pure unit)
+    liftEffect $ assertEqual { actual: nil, expected: [] }
+
+    log "`genNonEmpty` should not reduce the remainder size below zero"
+    one :: NonEmpty Array Int ← Gen.resize (const 0) $ GenC.genNonEmpty (Gen.sized pure)
+    liftEffect $ assertEqual { actual: one, expected: 0 :| [] }
+
+--------------------------------------------------------------------------------
+
+type GenState = Tuple LCG.Seed Int
+
+newtype TestGen a = TestGen (GenState -> Effect (Tuple GenState a))
+
+derive instance functorTestGen :: Functor TestGen
+
+instance applyTestGen :: Apply TestGen where
+  apply = ap
+
+instance applicativeTestGen :: Applicative TestGen where
+  pure a = TestGen (pure <<< flip Tuple a)
+
+instance bindTestGen :: Bind TestGen where
+  bind gen f =
+    TestGen \s ->
+      unTestGen gen s >>= \(Tuple s' v) ->
+        unTestGen (f v) s'
+
+instance monadTestGen :: Monad TestGen
+
+instance monadRecTestGen :: MonadRec TestGen where
+  tailRecM f a = TestGen (tailRecM go <<< flip Tuple a)
+    where
+      go (Tuple s a') =
+        unTestGen (f a') s >>= \(Tuple s' m) ->
+          pure $ bimap (Tuple s') (Tuple s') m
+
+instance monadGenTestGen :: Gen.MonadGen TestGen where
+  chooseInt a b = Int.round <$> Gen.chooseFloat (Int.toNumber a) (Int.toNumber b)
+  chooseFloat a b = uniform <#> \n -> a + (b - a) * n
+  chooseBool = (_ < 0.5) <$> uniform
+  resize f (TestGen k) = TestGen \(Tuple seed size) -> k (Tuple seed (f size))
+  sized f = TestGen \s -> case f (snd s) of TestGen k -> k s
+
+instance monageEffectTestGen :: MonadEffect TestGen where
+  liftEffect a = TestGen \st -> Tuple st <$> a
+
+lcgStep :: TestGen Int
+lcgStep =
+  TestGen \(Tuple seed size) ->
+    pure $ Tuple (Tuple (LCG.lcgNext seed) size) (LCG.unSeed seed)
+
+uniform :: TestGen Number
+uniform = lcgStep <#> (\n -> Int.toNumber n / Int.toNumber LCG.lcgM)
+
+unTestGen :: forall a. TestGen a -> GenState -> Effect (Tuple GenState a)
+unTestGen (TestGen k) = k
+
+runTestGen :: forall a. LCG.Seed -> TestGen a -> Effect a
+runTestGen seed gen = snd <$> unTestGen gen (Tuple seed 5)