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.

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

Make NuMatchingAny1Proof an alias for a quantified NuMatching constraint #8

Merged
merged 1 commit into from
Dec 5, 2022
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
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
34 changes: 8 additions & 26 deletions src/Data/Binding/Hobbits/NuMatching.hs
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
Expand Down Expand Up @@ -35,7 +36,7 @@
module Data.Binding.Hobbits.NuMatching (
NuMatching(..), mkNuMatching,
MbTypeRepr(), isoMbTypeRepr, unsafeMbTypeRepr,
NuMatchingAny1(..)
NuMatchingAny1
) where

import Prelude hiding (exp)
Expand All @@ -47,11 +48,8 @@ import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Datatype.TyVarBndr
import Control.Monad.State
import Numeric.Natural
import Data.Functor.Constant
import Data.Kind as DK
import Data.Word
import Data.Proxy
import Data.Type.Equality
--import Control.Monad.Identity

import Data.Type.RList hiding (map)
Expand Down Expand Up @@ -231,25 +229,12 @@ instance {-# OVERLAPPABLE #-} (NuMatching1 f, NuMatchingList ctx) =>
mapNames r elm
-}

-- | Typeclass for lifting the 'NuMatching' constraint to functors on arbitrary
-- kinds that do not require any constraints on their input types
class NuMatchingAny1 (f :: k -> Type) where
nuMatchingAny1Proof :: MbTypeRepr (f a)

instance {-# INCOHERENT #-} NuMatchingAny1 f => NuMatching (f a) where
nuMatchingProof = nuMatchingAny1Proof

instance NuMatchingAny1 Name where
nuMatchingAny1Proof = nuMatchingProof

instance NuMatchingAny1 Proxy where
nuMatchingAny1Proof = nuMatchingProof

instance NuMatchingAny1 ((:~:) a) where
nuMatchingAny1Proof = nuMatchingProof

instance NuMatching a => NuMatchingAny1 (Constant a) where
nuMatchingAny1Proof = nuMatchingProof
-- | An alias for a 'NuMatching' constraint on a functor of arbitrary kind that
-- does not require any constraints on the input type. We define this as a
-- class, rather than a type synonym, so that downstream users do not have to
-- enable @QuantifiedConstraints@ just to be able to use it.
class (forall a. NuMatching (f a)) => NuMatchingAny1 (f :: k -> Type)
instance (forall a. NuMatching (f a)) => NuMatchingAny1 (f :: k -> Type)

instance {-# OVERLAPPABLE #-} NuMatchingAny1 f => NuMatching (RAssign f ctx) where
nuMatchingProof = MbTypeReprData $ MkMbTypeReprData helper where
Expand All @@ -258,9 +243,6 @@ instance {-# OVERLAPPABLE #-} NuMatchingAny1 f => NuMatching (RAssign f ctx) whe
helper _ MNil = MNil
helper r (elms :>: elm) = helper r elms :>: mapNames r elm

instance NuMatchingAny1 f => NuMatchingAny1 (RAssign f) where
nuMatchingAny1Proof = nuMatchingProof

-- now we define some TH to create NuMatchings

natsFrom :: Integer -> [Integer]
Expand Down
4 changes: 0 additions & 4 deletions src/Data/Binding/Hobbits/NuMatchingInstances.hs
Original file line number Diff line number Diff line change
Expand Up @@ -44,10 +44,6 @@ $(mkNuMatching [t| forall a b. NuMatching a => Constant a b |])
$(mkNuMatching [t| forall f g a. (NuMatchingAny1 f,
NuMatchingAny1 g) => Product f g a |])

instance (NuMatchingAny1 f,
NuMatchingAny1 g) => NuMatchingAny1 (Product f g) where
nuMatchingAny1Proof = nuMatchingProof

instance (Integral a, NuMatching a) => NuMatching (Ratio a) where
nuMatchingProof =
isoMbTypeRepr (\r -> (numerator r, denominator r)) (\(n,d) -> n%d)