Add non-termination tests (#18)

This also fixes `Fix` and adds `Cofix`. And adds some more strict
functors.

core-test/test/Test/Fold/Native.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Test.Fold.Native where
+
+import "base" Control.Category (Category (id))
+import "base" Control.Monad ((=<<))
+import "base" Data.Bool (Bool)
+import "base" Data.Function (($))
+import "base" Data.Proxy (Proxy (Proxy))
+import "base" System.IO (IO)
+import "hedgehog" Hedgehog (Property, checkParallel, discover, forAll, property)
+import qualified "hedgehog" Hedgehog.Gen as Gen
+import "yaya" Yaya.Fold.Common (size)
+import "yaya" Yaya.Fold.Native (Fix)
+import "yaya-hedgehog" Yaya.Hedgehog.Expr (Expr, genExpr, genFixExpr)
+import "yaya-hedgehog" Yaya.Hedgehog.Fold
+  ( law_cataCancel,
+    law_cataCompose,
+    law_cataRefl,
+  )
+
+-- TODO: For some reason HLint is complaining that TemplateHaskell is unused.
+{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-}
+
+prop_fixCataCancel :: Property
+prop_fixCataCancel =
+  property $ law_cataCancel size =<< forAll (genExpr (Gen.sized genFixExpr))
+
+prop_fixCataRefl :: Property
+prop_fixCataRefl =
+  property $ law_cataRefl =<< forAll (Gen.sized genFixExpr)
+
+prop_fixCataCompose :: Property
+prop_fixCataCompose =
+  property $
+    law_cataCompose (Proxy :: Proxy (Fix Expr)) size id
+      =<< forAll (Gen.sized genFixExpr)
+
+tests :: IO Bool
+tests = checkParallel $$discover

core-test/yaya-test.cabal

@@ -26,11 +26,12 @@ test-suite yaya-test
   main-is:             test.hs
   other-modules:       Test.Fold
                      , Test.Fold.Common
+                     , Test.Fold.Native
                      , Test.Retrofit
   build-depends:       base >= 4.7 && < 5
                      , deriving-compat
                      , hedgehog
-                     , yaya >= 0.3.1
+                     , yaya >= 0.5.0
                      , yaya-hedgehog >= 0.2.0
   default-extensions:  LambdaCase
                      , MultiParamTypeClasses

core/src/Yaya/Fold/Native.hs

@@ -2,20 +2,27 @@
 
 -- | Uses of recursion schemes that use Haskell’s built-in recursion in a total
 --   manner.
-module Yaya.Fold.Native where
+module Yaya.Fold.Native
+  ( module Yaya.Fold.Native.Internal,
+    Fix (..),
+    distCofreeT,
+  )
+where
 
 import "base" Control.Applicative (Applicative)
 import "base" Control.Category (Category (..))
 import "base" Data.Bifunctor (Bifunctor (..))
 import "base" Data.Bool (Bool)
+import "base" Data.Eq (Eq ((==)))
 import "base" Data.Foldable (Foldable)
 import "base" Data.Function (($))
 import "base" Data.Functor (Functor (..))
+import "base" Data.Functor.Classes (Eq1, Show1)
 import "base" Data.List.NonEmpty
 import "base" Data.Monoid (Monoid)
 import "base" Data.Ord (Ord)
 import "base" Numeric.Natural
-import "base" Text.Show (Show)
+import "base" Text.Show (Show (showsPrec))
 import "comonad" Control.Comonad (Comonad (..))
 import "comonad" Control.Comonad.Trans.Env (EnvT (..), runEnvT)
 import "free" Control.Comonad.Cofree (Cofree (..), unwrap)
@@ -27,13 +34,16 @@ import "this" Yaya.Fold
     Projectable (..),
     Recursive (..),
     Steppable (..),
+    recursiveEq,
+    recursiveShowsPrec,
   )
 import "this" Yaya.Fold.Common (diagonal)
+import "this" Yaya.Fold.Native.Internal (Cofix (unCofix))
 import "this" Yaya.Pattern (AndMaybe (..), Maybe, XNor (..), uncurry)
 import "base" Prelude (Integral)
 
 -- | A fixed-point constructor that uses Haskell's built-in recursion. This is
---   lazy/corecursive.
+--   strict/recursive.
 newtype Fix f = Fix {unFix :: f (Fix f)}
 
 instance Projectable (->) (Fix f) f where
@@ -42,8 +52,14 @@ instance Projectable (->) (Fix f) f where
 instance Steppable (->) (Fix f) f where
   embed = Fix
 
-instance (Functor f) => Corecursive (->) (Fix f) f where
-  ana φ = embed . fmap (ana φ) . φ
+instance (Functor f) => Recursive (->) (Fix f) f where
+  cata ɸ = ɸ . fmap (cata ɸ) . project
+
+instance (Functor f, Foldable f, Eq1 f) => Eq (Fix f) where
+  (==) = recursiveEq
+
+instance (Functor f, Show1 f) => Show (Fix f) where
+  showsPrec = recursiveShowsPrec
 
 instance Recursive (->) Natural Maybe where
   cata ɸ = ɸ . fmap (cata ɸ) . project

core/src/Yaya/Fold/Native/Internal.hs

@@ -0,0 +1,30 @@
+-- NB: We disable @StrictData@ here in order for `Cofix` to be lazy. I don’t
+--     think there is any way to explicitly add @~@ patterns that has the
+--     correct semantics.
+{-# LANGUAGE NoStrictData #-}
+
+-- | This module only exists to restrict the scope of @NoStrictData@. Everything
+--    is re-exported via "Yaya.Fold".
+module Yaya.Fold.Native.Internal where
+
+import "base" Control.Category (Category ((.)))
+import "base" Data.Functor (Functor (fmap))
+import "this" Yaya.Fold
+  ( Corecursive (ana),
+    Projectable (project),
+    Steppable (embed),
+  )
+
+-- | A fixed-point constructor that uses Haskell's built-in recursion. This is
+--   lazy/corecursive.
+data Cofix f = Cofix {unCofix :: f (Cofix f)}
+{-# ANN Cofix "HLint: ignore Use newtype instead of data" #-}
+
+instance Projectable (->) (Cofix f) f where
+  project = unCofix
+
+instance Steppable (->) (Cofix f) f where
+  embed = Cofix
+
+instance (Functor f) => Corecursive (->) (Cofix f) f where
+  ana φ = embed . fmap (ana φ) . φ

core/src/Yaya/Pattern.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 -- | Common pattern functors (and instances for them).
@@ -13,22 +14,29 @@ module Yaya.Pattern
   )
 where
 
+import Text.Show.Deriving (deriveShow1, deriveShow2)
 import "base" Control.Applicative (Applicative (..))
 import "base" Control.Monad (Monad (..))
 import "base" Data.Bifunctor (Bifunctor (..))
+import "base" Data.Eq (Eq)
 import "base" Data.Foldable (Foldable)
 import "base" Data.Function (($))
 import "base" Data.Functor (Functor)
+import "base" Data.Ord (Ord)
 import "base" Data.Traversable (Traversable)
+import "base" Text.Show (Show)
 import "comonad" Control.Comonad (Comonad (..))
--- explicitly omitted import list for `strict` modules
+-- explicitly omitted import list for @strict@ modules
 import "strict" Data.Strict.Either
 import "strict" Data.Strict.Maybe
 import "strict" Data.Strict.Tuple
 
 -- | Isomorphic to 'Maybe (a, b)', it’s also the pattern functor for lists.
 data XNor a b = Neither | Both ~a b
-  deriving (Functor, Foldable, Traversable)
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+deriveShow1 ''XNor
+deriveShow2 ''XNor
 
 instance Bifunctor XNor where
   bimap f g = \case
@@ -38,7 +46,10 @@ instance Bifunctor XNor where
 -- | Isomorphic to `(a, Maybe b)`, it’s also the pattern functor for non-empty
 --   lists.
 data AndMaybe a b = Only a | Indeed ~a b
-  deriving (Functor, Foldable, Traversable)
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+deriveShow1 ''AndMaybe
+deriveShow2 ''AndMaybe
 
 instance Bifunctor AndMaybe where
   bimap f g = \case

core/yaya.cabal

@@ -1,5 +1,5 @@
 name:                yaya
-version:             0.4.2.3
+version:             0.5.0.0
 synopsis:            Total recursion schemes.
 description:         Recursion schemes allow you to separate recursion from your
                      business logic – making your own operations simpler, more
@@ -38,8 +38,10 @@ library
                      , Yaya.Applied
                      , Yaya.Zoo
                      , Yaya.Experimental.Foldable
+  other-modules:       Yaya.Fold.Native.Internal
   build-depends:       base >= 4.7 && < 5
                      , comonad
+                     , deriving-compat
                      , either
                      , free
                      , kan-extensions

hedgehog/src/Yaya/Hedgehog.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE NumericUnderscores #-}
+
+module Yaya.Hedgehog where
+
+import "base" Control.Category (Category ((.)))
+import "base" Control.Monad ((<=<))
+import "base" Control.Monad.IO.Class (MonadIO)
+import "base" Data.Function (const)
+import "base" Data.Maybe (maybe)
+import "base" GHC.IO (evaluate)
+import "base" GHC.Stack (HasCallStack)
+import "base" System.Timeout (timeout)
+import "base" Text.Show (Show)
+import "hedgehog" Hedgehog
+
+-- | Returns success if the expression doesn’t terminate, failure otherwise.
+--   Termination is just checked with a 1 second timeout, so this isn’t
+--   foolproof.
+evalNonterminating ::
+  (HasCallStack, MonadIO m, MonadTest m, Show a) => a -> m ()
+evalNonterminating =
+  maybe success (const failure <=< annotateShow)
+    <=< evalIO . timeout 1_000_000 . evaluate
+
+-- | Returns success if the expression doesn’t terminate, failure otherwise.
+--   The value passed here should termina
+nonterminatingProperty :: (HasCallStack, Show a) => a -> Property
+nonterminatingProperty = withTests 1 . property . evalNonterminating

hedgehog/src/Yaya/Hedgehog/Expr.hs

@@ -15,7 +15,7 @@ import "hedgehog" Hedgehog (Gen, Size)
 import qualified "hedgehog" Hedgehog.Gen as Gen
 import qualified "hedgehog" Hedgehog.Range as Range
 import "yaya" Yaya.Fold (Mu, Nu, Steppable)
-import "yaya" Yaya.Fold.Native (Fix)
+import "yaya" Yaya.Fold.Native (Cofix, Fix)
 import "this" Yaya.Hedgehog.Fold (embeddableOfHeight)
 
 data Expr a
@@ -47,3 +47,6 @@ genNuExpr = expression
 
 genFixExpr :: Size -> Gen (Fix Expr)
 genFixExpr = expression
+
+genCofixExpr :: Size -> Gen (Cofix Expr)
+genCofixExpr = expression