{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}
#if MIN_VERSION_base(4,12,0)
{-# LANGUAGE NoStarIsType #-}
#endif
module Data.Finitary (
Finitary(..)
) where
import Data.Semigroup (Max, Min, Sum, Product, Dual, Last, First, Any, All)
import Data.Functor.Identity (Identity)
#if MIN_VERSION_base(4,12,0)
import Data.Ord (Down)
#else
import Data.Ord (Down(..))
#endif
import Foreign.Storable (Storable)
import Data.Maybe (fromJust)
import Control.Monad.State.Strict (MonadState(..), modify, evalState)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Word (Word8, Word16, Word32, Word64)
import Data.Proxy (Proxy(..))
import Data.Void (Void)
import Data.Bool (bool)
import CoercibleUtils (op)
import GHC.Generics (Generic, Rep, U1(..), K1(..), V1, (:+:)(..), (:*:)(..), M1(..), from, to)
import Control.Applicative (Alternative(..), Const)
import Data.Kind (Type)
import GHC.TypeNats
import Data.Finite (Finite, separateSum, separateProduct, combineProduct, weakenN, shiftN, strengthenN, finite)
import qualified Data.Bit as B
import qualified Data.Bit.ThreadSafe as BTS
import qualified Data.Vector.Sized as VS
import qualified Data.Vector.Unboxed.Sized as VUS
import qualified Data.Vector.Storable.Sized as VSS
import Data.Finitary.TH
class (KnownNat (Cardinality a)) => Finitary (a :: Type) where
type Cardinality a :: Nat
type Cardinality a = GCardinality (Rep a)
fromFinite :: Finite (Cardinality a) -> a
default fromFinite :: (Generic a, GFinitary (Rep a), Cardinality a ~ GCardinality (Rep a)) => Finite (Cardinality a) -> a
fromFinite = to . gFromFinite
toFinite :: a -> Finite (Cardinality a)
default toFinite :: (Generic a, GFinitary (Rep a), Cardinality a ~ GCardinality (Rep a)) => a -> Finite (Cardinality a)
toFinite = gToFinite . from
start :: (1 <= Cardinality a) => a
start = fromFinite minBound
end :: (1 <= Cardinality a) => a
end = fromFinite maxBound
previous :: (Alternative f) => a -> f a
previous = fmap fromFinite . guarded (== maxBound) . dec . toFinite
next :: (Alternative f) => a -> f a
next = fmap fromFinite . guarded (== minBound) . inc . toFinite
enumerateFrom :: a -> [a]
enumerateFrom x = fromFinite <$> [toFinite x ..]
enumerateFromThen :: a -> a -> [a]
enumerateFromThen x y = fromFinite <$> [toFinite x, toFinite y ..]
enumerateFromTo :: a -> a -> [a]
enumerateFromTo x y = fromFinite <$> [toFinite x .. toFinite y]
enumerateFromThenTo :: a -> a -> a -> [a]
enumerateFromThenTo x y z = fromFinite <$> [toFinite x, toFinite y .. toFinite z]
class (KnownNat (GCardinality a)) => GFinitary (a :: Type -> Type) where
type GCardinality a :: Nat
gFromFinite :: Finite (GCardinality a) -> a x
gToFinite :: a x -> Finite (GCardinality a)
instance GFinitary V1 where
type GCardinality V1 = 0
{-# INLINE gFromFinite #-}
gFromFinite = const undefined
{-# INLINE gToFinite #-}
gToFinite = const undefined
instance GFinitary U1 where
type GCardinality U1 = 1
{-# INLINE gFromFinite #-}
gFromFinite = const U1
{-# INLINE gToFinite #-}
gToFinite = const 0
instance (Finitary a) => GFinitary (K1 _1 a) where
type GCardinality (K1 _1 a) = Cardinality a
{-# INLINE gFromFinite #-}
gFromFinite = K1 . fromFinite
{-# INLINE gToFinite #-}
gToFinite = toFinite . op K1
instance (GFinitary a, GFinitary b) => GFinitary (a :+: b) where
type GCardinality (a :+: b) = GCardinality a + GCardinality b
{-# INLINE gFromFinite #-}
gFromFinite = either (L1 . gFromFinite) (R1 . gFromFinite) . separateSum
{-# INLINE gToFinite #-}
gToFinite (L1 x) = weakenN . gToFinite $ x
gToFinite (R1 x) = shiftN . gToFinite $ x
instance (GFinitary a, GFinitary b) => GFinitary (a :*: b) where
type GCardinality (a :*: b) = GCardinality a * GCardinality b
{-# INLINE gFromFinite #-}
gFromFinite i = let (x, y) = separateProduct i in
gFromFinite x :*: gFromFinite y
{-# INLINE gToFinite #-}
gToFinite (x :*: y) = combineProduct @(GCardinality a) @(GCardinality b) (weakenN . gToFinite $ x, weakenN . gToFinite $ y)
instance (GFinitary a) => GFinitary (M1 _x _y a) where
type GCardinality (M1 _x _y a) = GCardinality a
{-# INLINE gFromFinite #-}
gFromFinite = M1 . gFromFinite
{-# INLINE gToFinite #-}
gToFinite = gToFinite . op M1
instance Finitary Void
instance Finitary ()
instance Finitary (Proxy a)
instance Finitary Bool
instance Finitary Any
instance Finitary All
instance Finitary B.Bit where
type Cardinality B.Bit = 2
{-# INLINE fromFinite #-}
fromFinite = B.Bit . toEnum . fromEnum
{-# INLINE toFinite #-}
toFinite = toEnum . fromEnum . op B.Bit
{-# INLINE start #-}
start = minBound
{-# INLINE end #-}
end = maxBound
{-# INLINE next #-}
next = fmap succ . guarded (== minBound)
{-# INLINE previous #-}
previous = fmap pred . guarded (== maxBound)
{-# INLINE enumerateFrom #-}
enumerateFrom = enumFrom
{-# INLINE enumerateFromThen #-}
enumerateFromThen = enumFromThen
{-# INLINE enumerateFromTo #-}
enumerateFromTo = enumFromTo
{-# INLINE enumerateFromThenTo #-}
enumerateFromThenTo = enumFromThenTo
instance Finitary BTS.Bit where
type Cardinality BTS.Bit = 2
{-# INLINE fromFinite #-}
fromFinite = BTS.Bit . toEnum . fromEnum
{-# INLINE toFinite #-}
toFinite = toEnum . fromEnum . op BTS.Bit
{-# INLINE start #-}
start = minBound
{-# INLINE end #-}
end = maxBound
{-# INLINE next #-}
next = fmap succ . guarded (== minBound)
{-# INLINE previous #-}
previous = fmap pred . guarded (== maxBound)
{-# INLINE enumerateFrom #-}
enumerateFrom = enumFrom
{-# INLINE enumerateFromThen #-}
enumerateFromThen = enumFromThen
{-# INLINE enumerateFromTo #-}
enumerateFromTo = enumFromTo
{-# INLINE enumerateFromThenTo #-}
enumerateFromThenTo = enumFromThenTo
instance Finitary Ordering
instance Finitary Char where
type Cardinality Char = $(charCardinality)
{-# INLINE fromFinite #-}
fromFinite = toEnum . fromEnum
{-# INLINE toFinite #-}
toFinite = toEnum . fromEnum
{-# INLINE start #-}
start = minBound
{-# INLINE end #-}
end = maxBound
{-# INLINE next #-}
next = fmap succ . guarded (/= maxBound)
{-# INLINE previous #-}
previous = fmap pred . guarded (/= minBound)
{-# INLINE enumerateFrom #-}
enumerateFrom = enumFrom
{-# INLINE enumerateFromThen #-}
enumerateFromThen = enumFromThen
{-# INLINE enumerateFromTo #-}
enumerateFromTo = enumFromTo
{-# INLINE enumerateFromThenTo #-}
enumerateFromThenTo = enumFromThenTo
instance Finitary Word8 where
type Cardinality Word8 = $(cardinalityOf @Word8)
{-# INLINE fromFinite #-}
fromFinite = toEnum . fromEnum
{-# INLINE toFinite #-}
toFinite = toEnum . fromEnum
{-# INLINE start #-}
start = minBound
{-# INLINE end #-}
end = maxBound
{-# INLINE next #-}
next = fmap succ . guarded (/= maxBound)
{-# INLINE previous #-}
previous = fmap pred . guarded (/= minBound)
{-# INLINE enumerateFrom #-}
enumerateFrom = enumFrom
{-# INLINE enumerateFromThen #-}
enumerateFromThen = enumFromThen
{-# INLINE enumerateFromTo #-}
enumerateFromTo = enumFromTo
{-# INLINE enumerateFromThenTo #-}
enumerateFromThenTo = enumFromThenTo
instance Finitary Word16 where
type Cardinality Word16 = $(cardinalityOf @Word16)
{-# INLINE fromFinite #-}
fromFinite = toEnum . fromEnum
{-# INLINE toFinite #-}
toFinite = toEnum . fromEnum
{-# INLINE start #-}
start = minBound
{-# INLINE end #-}
end = maxBound
{-# INLINE next #-}
next = fmap succ . guarded (/= maxBound)
{-# INLINE previous #-}
previous = fmap pred . guarded (/= minBound)
{-# INLINE enumerateFrom #-}
enumerateFrom = enumFrom
{-# INLINE enumerateFromThen #-}
enumerateFromThen = enumFromThen
{-# INLINE enumerateFromTo #-}
enumerateFromTo = enumFromTo
{-# INLINE enumerateFromThenTo #-}
enumerateFromThenTo = enumFromThenTo
instance Finitary Word32 where
type Cardinality Word32 = $(cardinalityOf @Word32)
{-# INLINE fromFinite #-}
fromFinite = fromIntegral
{-# INLINE toFinite #-}
toFinite = fromIntegral
{-# INLINE start #-}
start = minBound
{-# INLINE end #-}
end = maxBound
{-# INLINE next #-}
next = guarded (== minBound) . inc
{-# INLINE previous #-}
previous = guarded (== maxBound) . dec
{-# INLINE enumerateFrom #-}
enumerateFrom = enumFrom
{-# INLINE enumerateFromThen #-}
enumerateFromThen = enumFromThen
{-# INLINE enumerateFromTo #-}
enumerateFromTo = enumFromTo
{-# INLINE enumerateFromThenTo #-}
enumerateFromThenTo = enumFromThenTo
instance Finitary Word64 where
type Cardinality Word64 = $(cardinalityOf @Word64)
{-# INLINE fromFinite #-}
fromFinite = fromIntegral
{-# INLINE toFinite #-}
toFinite = fromIntegral
{-# INLINE start #-}
start = minBound
{-# INLINE end #-}
end = maxBound
{-# INLINE next #-}
next = guarded (== minBound) . inc
{-# INLINE previous #-}
previous = guarded (== maxBound) . dec
{-# INLINE enumerateFrom #-}
enumerateFrom = enumFrom
{-# INLINE enumerateFromThen #-}
enumerateFromThen = enumFromThen
{-# INLINE enumerateFromTo #-}
enumerateFromTo = enumFromTo
{-# INLINE enumerateFromThenTo #-}
enumerateFromThenTo = enumFromThenTo
instance Finitary Int8 where
type Cardinality Int8 = $(cardinalityOf @Int8)
{-# INLINE fromFinite #-}
fromFinite = fromIntegral . subtract 128 . fromIntegral @_ @Int16
{-# INLINE toFinite #-}
toFinite = fromIntegral . (+ 128) . fromIntegral @_ @Int16
{-# INLINE start #-}
start = minBound
{-# INLINE end #-}
end = maxBound
{-# INLINE next #-}
next = fmap succ . guarded (/= maxBound)
{-# INLINE previous #-}
previous = fmap pred . guarded (/= minBound)
{-# INLINE enumerateFrom #-}
enumerateFrom = enumFrom
{-# INLINE enumerateFromThen #-}
enumerateFromThen = enumFromThen
{-# INLINE enumerateFromTo #-}
enumerateFromTo = enumFromTo
{-# INLINE enumerateFromThenTo #-}
enumerateFromThenTo = enumFromThenTo
instance Finitary Int16 where
type Cardinality Int16 = $(cardinalityOf @Int16)
{-# INLINE fromFinite #-}
fromFinite = fromIntegral . subtract 32768 . fromIntegral @_ @Int32
{-# INLINE toFinite #-}
toFinite = fromIntegral . (+ 32768) . fromIntegral @_ @Int32
{-# INLINE start #-}
start = minBound
{-# INLINE end #-}
end = maxBound
{-# INLINE next #-}
next = fmap succ . guarded (/= maxBound)
{-# INLINE previous #-}
previous = fmap pred . guarded (/= minBound)
{-# INLINE enumerateFrom #-}
enumerateFrom = enumFrom
{-# INLINE enumerateFromThen #-}
enumerateFromThen = enumFromThen
{-# INLINE enumerateFromTo #-}
enumerateFromTo = enumFromTo
{-# INLINE enumerateFromThenTo #-}
enumerateFromThenTo = enumFromThenTo
instance Finitary Int32 where
type Cardinality Int32 = $(cardinalityOf @Int32)
{-# INLINE fromFinite #-}
fromFinite = fromIntegral @_ @Int32 . subtract $(adjustmentOf @Int32) . fromIntegral @_ @Integer
{-# INLINE toFinite #-}
toFinite = fromIntegral . (+ $(adjustmentOf @Int32)) . fromIntegral @_ @Integer . fromEnum
{-# INLINE start #-}
start = minBound
{-# INLINE end #-}
end = maxBound
{-# INLINE next #-}
next = guarded (== minBound) . inc
{-# INLINE previous #-}
previous = guarded (== maxBound) . dec
{-# INLINE enumerateFrom #-}
enumerateFrom = enumFrom
{-# INLINE enumerateFromThen #-}
enumerateFromThen = enumFromThen
{-# INLINE enumerateFromTo #-}
enumerateFromTo = enumFromTo
{-# INLINE enumerateFromThenTo #-}
enumerateFromThenTo = enumFromThenTo
instance Finitary Int64 where
type Cardinality Int64 = $(cardinalityOf @Int64)
{-# INLINE fromFinite #-}
fromFinite = fromIntegral @_ @Int64 . subtract $(adjustmentOf @Int64) . fromIntegral @_ @Integer
{-# INLINE toFinite #-}
toFinite = fromIntegral . (+ $(adjustmentOf @Int64)) . fromIntegral @_ @Integer . fromEnum
{-# INLINE start #-}
start = minBound
{-# INLINE end #-}
end = maxBound
{-# INLINE next #-}
next = guarded (== minBound) . inc
{-# INLINE previous #-}
previous = guarded (== maxBound) . dec
{-# INLINE enumerateFrom #-}
enumerateFrom = enumFrom
{-# INLINE enumerateFromThen #-}
enumerateFromThen = enumFromThen
{-# INLINE enumerateFromTo #-}
enumerateFromTo = enumFromTo
{-# INLINE enumerateFromThenTo #-}
enumerateFromThenTo = enumFromThenTo
instance Finitary Int where
type Cardinality Int = $(cardinalityOf @Int)
{-# INLINE fromFinite #-}
fromFinite = fromIntegral @_ @Int . subtract $(adjustmentOf @Int) . fromIntegral @_ @Integer
{-# INLINE toFinite #-}
toFinite = fromIntegral . (+ $(adjustmentOf @Int)) . fromIntegral @_ @Integer . fromEnum
{-# INLINE start #-}
start = minBound
{-# INLINE end #-}
end = maxBound
{-# INLINE next #-}
next = guarded (== minBound) . inc
{-# INLINE previous #-}
previous = guarded (== maxBound) . dec
{-# INLINE enumerateFrom #-}
enumerateFrom = enumFrom
{-# INLINE enumerateFromThen #-}
enumerateFromThen = enumFromThen
{-# INLINE enumerateFromTo #-}
enumerateFromTo = enumFromTo
{-# INLINE enumerateFromThenTo #-}
enumerateFromThenTo = enumFromThenTo
instance Finitary Word where
type Cardinality Word = $(cardinalityOf @Word)
{-# INLINE fromFinite #-}
fromFinite = fromIntegral
{-# INLINE toFinite #-}
toFinite = fromIntegral
{-# INLINE start #-}
start = minBound
{-# INLINE end #-}
end = maxBound
{-# INLINE next #-}
next = guarded (== minBound) . inc
{-# INLINE previous #-}
previous = guarded (== maxBound) . dec
{-# INLINE enumerateFrom #-}
enumerateFrom = enumFrom
{-# INLINE enumerateFromThen #-}
enumerateFromThen = enumFromThen
{-# INLINE enumerateFromTo #-}
enumerateFromTo = enumFromTo
{-# INLINE enumerateFromThenTo #-}
enumerateFromThenTo = enumFromThenTo
instance (KnownNat n) => Finitary (Finite n) where
type Cardinality (Finite n) = n
{-# INLINE fromFinite #-}
fromFinite = id
{-# INLINE toFinite #-}
toFinite = id
{-# INLINE start #-}
start = minBound
{-# INLINE end #-}
end = maxBound
{-# INLINE next #-}
next = guarded (== minBound) . inc
{-# INLINE previous #-}
previous = guarded (== maxBound) . dec
{-# INLINE enumerateFrom #-}
enumerateFrom = enumFrom
{-# INLINE enumerateFromThen #-}
enumerateFromThen = enumFromThen
{-# INLINE enumerateFromTo #-}
enumerateFromTo = enumFromTo
{-# INLINE enumerateFromThenTo #-}
enumerateFromThenTo = enumFromThenTo
instance (Finitary a) => Finitary (Maybe a)
instance (Finitary a, Finitary b) => Finitary (Either a b)
instance (Finitary a, Finitary b) => Finitary (a, b)
instance (Finitary a, Finitary b, Finitary c) => Finitary (a, b, c)
instance (Finitary a, Finitary b, Finitary c, Finitary d) => Finitary (a, b, c, d)
instance (Finitary a, Finitary b, Finitary c, Finitary d, Finitary e) => Finitary (a, b, c, d, e)
instance (Finitary a, Finitary b, Finitary c, Finitary d, Finitary e, Finitary f) => Finitary (a, b, c, d, e, f)
instance (Finitary a) => Finitary (Const a b)
#if MIN_VERSION_base(4,12,0)
instance (Finitary a) => Finitary (Down a)
#else
instance (Finitary a) => Finitary (Down a) where
type Cardinality (Down a) = Cardinality a
{-# INLINE fromFinite #-}
fromFinite = Down . fromFinite
{-# INLINE toFinite #-}
toFinite = toFinite . op Down
{-# INLINE start #-}
start = Down start
{-# INLINE end #-}
end = Down end
{-# INLINE previous #-}
previous = fmap Down . previous . op Down
{-# INLINE next #-}
next = fmap Down . next . op Down
{-# INLINE enumerateFrom #-}
enumerateFrom = fmap Down . enumerateFrom . op Down
{-# INLINE enumerateFromThen #-}
enumerateFromThen (Down x) (Down y) = fmap Down . enumerateFromThen x $ y
{-# INLINE enumerateFromTo #-}
enumerateFromTo (Down x) (Down y) = fmap Down . enumerateFromTo x $ y
{-# INLINE enumerateFromThenTo #-}
enumerateFromThenTo (Down x) (Down y) (Down z) = fmap Down . enumerateFromThenTo x y $ z
#endif
instance (Finitary a) => Finitary (Sum a)
instance (Finitary a) => Finitary (Product a)
instance (Finitary a) => Finitary (Dual a)
instance (Finitary a) => Finitary (Last a)
instance (Finitary a) => Finitary (First a)
instance (Finitary a) => Finitary (Identity a)
instance (Finitary a) => Finitary (Max a)
instance (Finitary a) => Finitary (Min a)
instance (Finitary a, KnownNat n, Cardinality a <= Cardinality a ^ n) => Finitary (VS.Vector n a) where
type Cardinality (VS.Vector n a) = Cardinality a ^ n
{-# INLINE fromFinite #-}
fromFinite = evalState (VS.replicateM (unrank typeSize))
where typeSize = finite @(Cardinality (VS.Vector n a)) . fromIntegral . natVal @(Cardinality a) $ Proxy
{-# INLINE toFinite #-}
toFinite v = evalState go base
where go = VS.foldM' (accumStep base) minBound v
base = finite @(Cardinality (VS.Vector n a)) . fromIntegral . natVal @(Cardinality a) $ Proxy
instance (Finitary a, VUS.Unbox a, KnownNat n, Cardinality a <= Cardinality a ^ n) => Finitary (VUS.Vector n a) where
type Cardinality (VUS.Vector n a) = Cardinality a ^ n
{-# INLINE fromFinite #-}
fromFinite = evalState (VUS.replicateM (unrank typeSize))
where typeSize = finite @(Cardinality (VUS.Vector n a)) . fromIntegral . natVal @(Cardinality a) $ Proxy
{-# INLINE toFinite #-}
toFinite v = evalState go base
where go = VUS.foldM' (accumStep base) minBound v
base = finite @(Cardinality (VUS.Vector n a)) . fromIntegral . natVal @(Cardinality a) $ Proxy
instance (Finitary a, Storable a, KnownNat n, Cardinality a <= Cardinality a ^ n) => Finitary (VSS.Vector n a) where
type Cardinality (VSS.Vector n a) = Cardinality a ^ n
{-# INLINE fromFinite #-}
fromFinite = evalState (VSS.replicateM (unrank typeSize))
where typeSize = finite @(Cardinality (VSS.Vector n a)) . fromIntegral . natVal @(Cardinality a) $ Proxy
{-# INLINE toFinite #-}
toFinite v = evalState go base
where go = VSS.foldM' (accumStep base) minBound v
base = finite @(Cardinality (VSS.Vector n a)) . fromIntegral . natVal @(Cardinality a) $ Proxy
{-# INLINE unrank #-}
unrank :: (MonadState (Finite n) m, Finitary a, KnownNat n, (Cardinality a) <= n) => Finite n -> m a
unrank typeSize = do remaining <- get
let (d, r) = remaining `divMod` typeSize
put d
return (fromFinite . fromJust . strengthenN $ r)
{-# INLINE accumStep #-}
accumStep :: (MonadState (Finite n) m, Finitary a, KnownNat n, (Cardinality a) <= n) => Finite n -> Finite n -> a -> m (Finite n)
accumStep base total e = do let e' = weakenN . toFinite $ e
ex <- get
modify (* base)
return (total + (e' * ex))
{-# INLINE inc #-}
inc :: (Num a) => a -> a
inc = (+ 1)
{-# INLINE dec #-}
dec :: (Num a) => a -> a
dec = subtract 1
{-# INLINE guarded #-}
guarded :: forall (a :: Type) (f :: Type -> Type) . (Alternative f) => (a -> Bool) -> a -> f a
guarded p x = bool empty (pure x) (p x)