Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add support for categorifying Natural #101

Closed
wants to merge 3 commits into from
Closed

Add support for categorifying Natural #101

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
1455f33
Sort default-extensions
sellout Jan 12, 2024
ecc25fe
Test basic operations on `Natural`
sellout Jan 12, 2024
3cdb6f5
Implement `Natural` support
sellout Jan 12, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 5 additions & 0 deletions hedgehog/Categorifier/Hedgehog.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@ module Categorifier.Hedgehog
( floatingEq,
genFloating,
genIntegralBounded,
genNatural,
)
where

Expand All @@ -11,6 +12,7 @@ import GHC.Stack (HasCallStack, withFrozenCallStack)
import qualified Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Numeric.Natural (Natural)

-- | A variant on `Hedgehog.===` that identifies NaNs as equals. It still works for non-FP types.
floatingEq :: (Hedgehog.MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m ()
Expand Down Expand Up @@ -61,3 +63,6 @@ genFloating =
-- (which can vary based on the platform).
genIntegralBounded :: (Hedgehog.MonadGen m, Bounded a, Integral a) => m a
genIntegralBounded = Gen.integral Range.linearBounded

genNatural :: (Hedgehog.MonadGen m) => m Natural
genNatural = Gen.integral $ Range.linear 0 1_000_000_000
23 changes: 12 additions & 11 deletions hedgehog/categorifier-hedgehog.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -25,19 +25,20 @@ library
, hedgehog >=1.0.3 && <1.3
default-language: Haskell2010
default-extensions:
InstanceSigs
, ScopedTypeVariables
, TypeApplications
BangPatterns
, DeriveDataTypeable
, DeriveFoldable
, DeriveFunctor
, DeriveGeneric
, DeriveTraversable
, DerivingStrategies
, FlexibleContexts
, FlexibleInstances
, FunctionalDependencies
, InstanceSigs
, LambdaCase
, TypeOperators
, BangPatterns
, NumericUnderscores
, ScopedTypeVariables
, StandaloneDeriving
, DeriveGeneric
, DeriveDataTypeable
, DeriveFunctor
, DeriveFoldable
, DeriveTraversable
, DerivingStrategies
, TypeApplications
, TypeOperators
20 changes: 19 additions & 1 deletion integrations/categories/integration-test/test/Categories/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,7 @@ module Main
)
where

import Categorifier.Hedgehog (genFloating, genIntegralBounded)
import Categorifier.Hedgehog (genFloating, genIntegralBounded, genNatural)
import Categorifier.Test.Categories.Instances (Hask (..), Term)
import Categorifier.Test.Data (Pair (..))
import Categorifier.Test.HList (HMap1 (..))
Expand Down Expand Up @@ -581,6 +581,24 @@ mkTestTerms
( TestCases
(const [((), pure ([|(,) <$> genIntegralBounded <*> genIntegralBounded|], [|show|]))])
)
. HInsert1
(Proxy @"EqualNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"NotEqualNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"GeNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"GtNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"LeNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"LtNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"EqualWord")
( TestCases
Expand Down
20 changes: 19 additions & 1 deletion integrations/concat-extensions/integration-test/test/ConCatExtensions/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -10,7 +10,7 @@ module Main
)
where

import Categorifier.Hedgehog (genFloating, genIntegralBounded)
import Categorifier.Hedgehog (genFloating, genIntegralBounded, genNatural)
import Categorifier.Test.ConCatExtensions.Instances (Hask (..), Term)
import Categorifier.Test.Data (Pair (..))
import Categorifier.Test.HList (HMap1 (..))
Expand Down Expand Up @@ -554,6 +554,24 @@ mkTestTerms
( TestCases
(const [((), pure ([|(,) <$> genIntegralBounded <*> genIntegralBounded|], [|show|]))])
)
. HInsert1
(Proxy @"EqualNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"NotEqualNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"GeNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"GtNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"LeNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"LtNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"EqualWord")
( TestCases
Expand Down
56 changes: 55 additions & 1 deletion integrations/concat/integration-test/test/ConCat/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -39,7 +39,7 @@ module Main
)
where

import Categorifier.Hedgehog (genFloating, genIntegralBounded)
import Categorifier.Hedgehog (genFloating, genIntegralBounded, genNatural)
import qualified Categorifier.Test.Adjunctions as Adjunctions
import Categorifier.Test.ConCat.Instances (Hask (..), Term)
import Categorifier.Test.Data (One (..), Pair (..))
Expand Down Expand Up @@ -928,6 +928,60 @@ mkTestTerms
else [((), pure ([|(,) <$> genIntegralBounded <*> genIntegralBounded|], [|show|]))]
)
)
. HInsert1
(Proxy @"EqualNatural")
( TestCases
( \arrow ->
if arrow == ''TotOrd
then [] -- #19
else [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]
)
)
. HInsert1
(Proxy @"NotEqualNatural")
( TestCases
( \arrow ->
if arrow == ''TotOrd
then [] -- #19
else [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]
)
)
. HInsert1
(Proxy @"GeNatural")
( TestCases
( \arrow ->
if arrow == ''TotOrd
then [] -- #19
else [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]
)
)
. HInsert1
(Proxy @"GtNatural")
( TestCases
( \arrow ->
if arrow == ''TotOrd
then [] -- #19
else [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]
)
)
. HInsert1
(Proxy @"LeNatural")
( TestCases
( \arrow ->
if arrow == ''TotOrd
then [] -- #19
else [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]
)
)
. HInsert1
(Proxy @"LtNatural")
( TestCases
( \arrow ->
if arrow == ''TotOrd
then [] -- #19
else [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]
)
)
. HInsert1
(Proxy @"EqualWord")
( TestCases
Expand Down
20 changes: 19 additions & 1 deletion integrations/unconcat/integration-test/test/UnconCat/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -10,7 +10,7 @@ module Main
)
where

import Categorifier.Hedgehog (genFloating, genIntegralBounded)
import Categorifier.Hedgehog (genFloating, genIntegralBounded, genNatural)
import Categorifier.Test.Data (Pair (..))
import Categorifier.Test.HList (HMap1 (..))
import Categorifier.Test.Tests
Expand Down Expand Up @@ -480,6 +480,24 @@ mkTestTerms
. HInsert1
(Proxy @"LtInt8")
(TestCases (const [((), pure ([|(,) <$> genIntegralBounded <*> genIntegralBounded|], [|show|]))]))
. HInsert1
(Proxy @"EqualNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"NotEqualNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"GeNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"GtNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"LeNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"LtNatural")
(TestCases (const [((), pure ([|(,) <$> genNatural <*> genNatural|], [|show|]))]))
. HInsert1
(Proxy @"EqualWord")
(TestCases (const [((), pure ([|(,) <$> genIntegralBounded <*> genIntegralBounded|], [|show|]))]))
Expand Down
32 changes: 32 additions & 0 deletions plugin-test/Categorifier/Test/Tests.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -58,6 +58,8 @@ import Data.Tuple (swap)
import qualified GHC.Float
import GHC.Int (Int16, Int32, Int64, Int8)
import qualified GHC.Int
import GHC.Num.Natural (Natural)
import qualified GHC.Num.Natural
import GHC.TypeLits (KnownSymbol, symbolVal)
import GHC.Word (Word16, Word32, Word64, Word8)
import qualified GHC.Word
Expand Down Expand Up @@ -528,6 +530,36 @@ baseTestTerms =
. insertTest (Proxy @"GtInt8") mkBinaryTestConfig (\() -> ([t|Int8|], [t|Int8 -> Bool|])) [|GHC.Int.gtInt8|]
. insertTest (Proxy @"LeInt8") mkBinaryTestConfig (\() -> ([t|Int8|], [t|Int8 -> Bool|])) [|GHC.Int.leInt8|]
. insertTest (Proxy @"LtInt8") mkBinaryTestConfig (\() -> ([t|Int8|], [t|Int8 -> Bool|])) [|GHC.Int.ltInt8|]
. insertTest
(Proxy @"EqualNatural")
mkBinaryTestConfig
(\() -> ([t|Natural|], [t|Natural -> Bool|]))
[|GHC.Num.Natural.naturalEq|]
. insertTest
(Proxy @"NotEqualNatural")
mkBinaryTestConfig
(\() -> ([t|Natural|], [t|Natural -> Bool|]))
[|GHC.Num.Natural.naturalNe|]
. insertTest
(Proxy @"GeNatural")
mkBinaryTestConfig
(\() -> ([t|Natural|], [t|Natural -> Bool|]))
[|GHC.Num.Natural.naturalGe|]
. insertTest
(Proxy @"GtNatural")
mkBinaryTestConfig
(\() -> ([t|Natural|], [t|Natural -> Bool|]))
[|GHC.Num.Natural.naturalGt|]
. insertTest
(Proxy @"LeNatural")
mkBinaryTestConfig
(\() -> ([t|Natural|], [t|Natural -> Bool|]))
[|GHC.Num.Natural.naturalLe|]
. insertTest
(Proxy @"LtNatural")
mkBinaryTestConfig
(\() -> ([t|Natural|], [t|Natural -> Bool|]))
[|GHC.Num.Natural.naturalLt|]
. insertTest (Proxy @"EqualWord") mkBinaryTestConfig (\() -> ([t|Word|], [t|Word -> Bool|])) [|GHC.Word.eqWord|]
. insertTest (Proxy @"NotEqualWord") mkBinaryTestConfig (\() -> ([t|Word|], [t|Word -> Bool|])) [|GHC.Word.neWord|]
. insertTest (Proxy @"GeWord") mkBinaryTestConfig (\() -> ([t|Word|], [t|Word -> Bool|])) [|GHC.Word.geWord|]
Expand Down
6 changes: 6 additions & 0 deletions plugin-test/test/Base/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -274,6 +274,12 @@ mkTestTerms
. HInsert1 (Proxy @"GtInt8") (TestCases (const [((), Nothing)]))
. HInsert1 (Proxy @"LeInt8") (TestCases (const [((), Nothing)]))
. HInsert1 (Proxy @"LtInt8") (TestCases (const [((), Nothing)]))
. HInsert1 (Proxy @"EqualNatural") (TestCases (const [((), Nothing)]))
. HInsert1 (Proxy @"NotEqualNatural") (TestCases (const [((), Nothing)]))
. HInsert1 (Proxy @"GeNatural") (TestCases (const [((), Nothing)]))
. HInsert1 (Proxy @"GtNatural") (TestCases (const [((), Nothing)]))
. HInsert1 (Proxy @"LeNatural") (TestCases (const [((), Nothing)]))
. HInsert1 (Proxy @"LtNatural") (TestCases (const [((), Nothing)]))
. HInsert1 (Proxy @"EqualWord") (TestCases (const [((), Nothing)]))
. HInsert1 (Proxy @"NotEqualWord") (TestCases (const [((), Nothing)]))
. HInsert1 (Proxy @"GeWord") (TestCases (const [((), Nothing)]))
Expand Down
33 changes: 33 additions & 0 deletions plugin/Categorifier/Core/MakerMap.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -70,6 +70,7 @@ import qualified GHC.Float
import qualified GHC.Int
import qualified GHC.List
import qualified GHC.Num
import qualified GHC.Num.Natural
import qualified GHC.Real
import qualified GHC.Types
import qualified GHC.Word
Expand Down Expand Up @@ -101,6 +102,7 @@ baseSymbolLookup = do
int64TyCon <- findTyCon ''GHC.Int.Int64
int8TyCon <- findTyCon ''GHC.Int.Int8
floatTyCon <- findTyCon ''GHC.Types.Float
naturalTyCon <- findTyCon ''GHC.Num.Natural.Natural
word16TyCon <- findTyCon ''GHC.Word.Word16
word32TyCon <- findTyCon ''GHC.Word.Word32
word64TyCon <- findTyCon ''GHC.Word.Word64
Expand All @@ -112,6 +114,7 @@ baseSymbolLookup = do
(''GHC.Int.Int64, int64TyCon),
(''GHC.Int.Int8, int8TyCon),
(''GHC.Types.Float, floatTyCon),
(''GHC.Num.Natural.Natural, naturalTyCon),
(''GHC.Word.Word16, word16TyCon),
(''GHC.Word.Word32, word32TyCon),
(''GHC.Word.Word64, word64TyCon)
Expand Down Expand Up @@ -992,6 +995,36 @@ baseMakerMapFun
pure $ maker2 rest =<\< mkSum (Plugins.mkTyConTy Plugins.listTyCon) a
_ -> Nothing
),
( 'GHC.Num.Natural.naturalGe,
\rest -> do
naturalTyCon <- Map.lookup ''GHC.Num.Natural.Natural (tyConLookup symLookup)
pure $ maker2 rest =<\< mkGE (Plugins.mkTyConTy naturalTyCon)
),
( 'GHC.Num.Natural.naturalGt,
\rest -> do
naturalTyCon <- Map.lookup ''GHC.Num.Natural.Natural (tyConLookup symLookup)
pure $ maker2 rest =<\< mkGT (Plugins.mkTyConTy naturalTyCon)
),
( 'GHC.Num.Natural.naturalLe,
\rest -> do
naturalTyCon <- Map.lookup ''GHC.Num.Natural.Natural (tyConLookup symLookup)
pure $ maker2 rest =<\< mkLE (Plugins.mkTyConTy naturalTyCon)
),
( 'GHC.Num.Natural.naturalLt,
\rest -> do
naturalTyCon <- Map.lookup ''GHC.Num.Natural.Natural (tyConLookup symLookup)
pure $ maker2 rest =<\< mkLT (Plugins.mkTyConTy naturalTyCon)
),
( 'GHC.Num.Natural.naturalNe,
\rest -> do
naturalTyCon <- Map.lookup ''GHC.Num.Natural.Natural (tyConLookup symLookup)
pure $ maker2 rest =<\< mkNotEqual (Plugins.mkTyConTy naturalTyCon)
),
( 'GHC.Num.Natural.naturalEq,
\rest -> do
naturalTyCon <- Map.lookup ''GHC.Num.Natural.Natural (tyConLookup symLookup)
pure $ maker2 rest =<\< mkEqual (Plugins.mkTyConTy naturalTyCon)
),
( '(GHC.Num.+),
\case
Plugins.Type ty : _num : rest -> pure $ maker2 rest =<\< mkPlus ty
Expand Down
Loading