add tests

.gitignore

@@ -7,3 +7,4 @@ node_modules/
 bower_components/
 tmp/
 output/
+.psc-ide-port

bower.json

@@ -18,6 +18,7 @@
     "purescript-integers": "^3.0.0",
     "purescript-generics": "^4.0.0",
     "purescript-console": "^3.0.0",
-    "purescript-exceptions": "^3.0.0"
+    "purescript-exceptions": "^3.0.0",
+    "purescript-quickcheck-laws": "^3.0.1"
   }
 }

src/Control/Applicative/Free.purs

@@ -7,6 +7,7 @@ module Control.Applicative.Free
   , analyzeFreeAp
   ) where
 
+import Prelude
 import Data.Const (Const(..))
 import Data.Either (Either(..))
 import Data.List (List(..))
@@ -15,8 +16,6 @@ import Data.Monoid (class Monoid)
 import Data.Newtype (unwrap)
 import Data.NonEmpty ((:|))
 import Data.Tuple (Tuple(..))
-import Debug.Trace (spy)
-import Prelude hiding (ap)
 import Unsafe.Coerce (unsafeCoerce)
 
 -- | The free applicative functor for a type constructor `f`.

src/Control/Applicative/Free/Gen.purs

@@ -0,0 +1,40 @@
+module Control.Applicative.Free.Gen where
+
+import Prelude
+
+import Control.Applicative.Free as F
+import Control.Monad.Gen (class MonadGen, oneOf)
+import Control.Monad.Rec.Class (class MonadRec)
+import Data.NonEmpty (NonEmpty(..))
+
+genFree :: forall m f a
+   . MonadGen m
+  => MonadRec m
+  => m (f Unit)
+  -> m a
+  -> m (a -> a)
+  -> m (F.FreeAp f a)
+genFree genF genA genA2A = oneOf $ NonEmpty 
+    ( genA <#> pure)
+    [ do 
+        fUnit <- genF
+        a <- genA
+        pure $ 
+          pure (const a) <*> F.liftFreeAp fUnit
+    , do 
+        fUnit <- genF
+        a <- genA
+        a2a <- genA2A
+        pure $ 
+          (pure (const a) <*> F.liftFreeAp fUnit) <#> a2a
+    , do
+        fUnit <- genF
+        a <- genA
+        a2a <- genA2A
+        pure $
+          F.liftFreeAp fUnit <#> const a <#> a2a
+    , do
+        a <- genA
+        a2a <- genA2A
+        pure $ pure a <#> a2a
+    ]

test/Test/Control/Applicative/Free.purs

@@ -1,30 +1,24 @@
 module Test.Control.Applicative.Free
   ( checkAnalyze
+  , checkStack
+  , check
   ) where
 
--- import Prelude (Unit, (==), (<>), unit, (-), ($), (>>>))
 import Prelude
 
-import Control.Applicative ((*>))
 import Control.Applicative.Free (FreeAp, liftFreeAp, analyzeFreeAp, retractFreeAp)
+import Control.Applicative.Free.Gen as GenF
 import Data.Either (Either(..))
-import Data.Identity (Identity(..))
-import Data.Show (class Show)
-import Debug.Trace (spy)
+import Data.Tuple (Tuple)
+import Test.QuickCheck (class Arbitrary, class Coarbitrary, arbitrary)
+import Test.QuickCheck.Gen (Gen)
+import Test.QuickCheck.Laws (QC, A, checkLaws)
+import Test.QuickCheck.Laws.Control as Control
+import Test.QuickCheck.Laws.Data as Data
+import Type.Proxy (Proxy(..), Proxy2(..))
 
-data M r = A r | B r
-
-instance showFreeAp :: Show (M a) where
-  show (A _) = "A"
-  show (B _) = "B"
-
-fInc = liftFreeAp (Identity (_ + 1))
-fOne = liftFreeAp (Identity 1)
-fMult = liftFreeAp (Identity (+))
 
-x = fMult <*> (fInc <*> fOne) <*> (fInc <*> fOne)
-
-zzz = spy { res1: retractFreeAp x }
+data M r = A r | B r
 
 ma :: FreeAp M Unit
 ma = liftFreeAp (A unit)
@@ -34,7 +28,7 @@ mb = liftFreeAp (B unit)
 
 printM :: forall a. FreeAp M a -> String
 printM fr =
-  analyzeFreeAp (go >>> spy) fr
+  analyzeFreeAp go fr
   where
   go (A _) = "A"
   go (B _) = "B"
@@ -43,19 +37,58 @@ build :: Int -> FreeAp M Unit -> FreeAp M Unit -> FreeAp M Unit
 build 0 _ acc = acc
 build n x acc = build (n - 1) x (acc *> x)
 
-result :: String
-result = printM (build 10 (ma *> mb) mb)
--- result = printM ((mb *> mb) *> ma)
--- result = printM (mb *> (mb *> ma))
-
 buildExpected :: Int -> String -> String -> String
 buildExpected 0 _ acc = acc
 buildExpected n x acc = buildExpected (n - 1) x (acc <> x)
 
-expected :: String
-expected = buildExpected 10 "AB" "B"
-
 checkAnalyze :: Either String String
-checkAnalyze = if result == expected
-               then Right result
-               else Left (result <> " is not " <> expected)
+checkAnalyze = 
+  if result == expected
+    then Right result
+    else Left (result <> " is not " <> expected)
+  where
+  result :: String
+  result = printM (build 10 (ma *> mb) mb)
+
+  expected :: String
+  expected = buildExpected 10 "AB" "B"
+
+
+checkStack :: Either String String
+checkStack = 
+  if result == expected
+    then Right "safe for 100000 node"
+    else Left (result <> " is not " <> expected)
+  where
+  result :: String
+  result = printM (build 100000 (ma *> mb) mb)
+
+  expected :: String
+  expected = buildExpected 100000 "AB" "B"
+
+
+newtype ArbFreeAp a = ArbFreeAp (FreeAp (Tuple (Array String)) a)
+
+instance arbitraryArbFreeAp :: (Coarbitrary a, Arbitrary a) => Arbitrary (ArbFreeAp a) where
+  arbitrary = ArbFreeAp <$> 
+    GenF.genFree
+      arbitrary
+      (arbitrary :: Gen a)
+      (arbitrary :: Gen (a -> a))
+
+instance eqArbFreeAp :: Eq a => Eq (ArbFreeAp a) where
+  eq (ArbFreeAp a) (ArbFreeAp b) = retractFreeAp a == retractFreeAp b
+
+derive newtype instance functorArbFreeAp :: Functor ArbFreeAp
+derive newtype instance applyArbFreeAp :: Apply ArbFreeAp
+derive newtype instance applicativeArbFreeAp :: Applicative ArbFreeAp
+
+check ∷ ∀ eff. QC eff Unit
+check = checkLaws "FreeAp" do
+  Data.checkEq prxFree
+  Data.checkFunctor prx2Free
+  Control.checkApply prx2Free
+  Control.checkApplicative prx2Free
+  where
+  prxFree = Proxy ∷ Proxy (ArbFreeAp A)
+  prx2Free = Proxy2 ∷ Proxy2 ArbFreeAp

test/Test/Main.purs

@@ -1,14 +1,14 @@
 module Test.Main where
 
-import Prelude (Unit, bind, discard)
-
+import Prelude
 import Control.Monad.Eff (Eff)
 import Control.Monad.Eff.Console (CONSOLE, log, logShow)
-
-import Test.Control.Applicative.Free.Validation as Validation
+import Control.Monad.Eff.Exception (EXCEPTION)
+import Control.Monad.Eff.Random (RANDOM)
 import Test.Control.Applicative.Free as FreeTest
+import Test.Control.Applicative.Free.Validation as Validation
 
-main :: Eff (console :: CONSOLE) Unit
+main :: Eff  ( console ∷ CONSOLE , random ∷ RANDOM , exception ∷ EXCEPTION ) Unit
 main = do
   log "\nvalid case:"
   logShow (Validation.runForm "Joe" "Smith" "28")
@@ -21,3 +21,9 @@ main = do
 
   log "\nanalyze:"
   logShow FreeTest.checkAnalyze
+
+  log "\nstack safety:"
+  logShow FreeTest.checkStack
+
+  log "\nlaws:"
+  FreeTest.check