Skip to content

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Constraint-based generics
{-# LANGUAGE
GADTs
, RankNTypes
, TypeFamilies
, ConstraintKinds
, FlexibleInstances
, ScopedTypeVariables
, UndecidableInstances
#-}
import GHC.Prim (Constraint)
import Control.Applicative
import Data.Functor.Identity
import Data.Functor.Constant
import Data.Monoid
import Control.Monad.Trans.State (State, state, runState)
import qualified Data.Binary as B
import Data.Foldable (foldlM)
import Data.Traversable (mapAccumL, Traversable(..))
data For (c :: * -> Constraint) = For
class ADT t where
ctorIndex :: t -> Int
type Constraints t c :: Constraint
buildsA :: (Constraints t c, Applicative f) => For c -> (forall s. c s => (t -> s) -> f s) -> [f t]
builds :: (ADT t, Constraints t c) => For c -> (forall s. c s => (t -> s) -> s) -> [t]
builds for f = fmap runIdentity $ buildsA for (Identity . f)
mbuilds :: forall t c m. (ADT t, Constraints t c, Monoid m) => For c -> (forall s. c s => (t -> s) -> m) -> [m]
mbuilds for f = fmap getConstant ms
where
ms :: [Constant m t]
ms = buildsA for (Constant . f)
eqADT :: (ADT t, Constraints t Eq) => t -> t -> Bool
eqADT s t = ctorIndex s == ctorIndex t &&
getAll (mbuilds (For :: For Eq) (\proj -> All $ proj s == proj t) !! ctorIndex s)
cmpADT :: (ADT t, Constraints t Ord) => t -> t -> Ordering
cmpADT s t = ctorIndex s `compare` ctorIndex t <>
mbuilds (For :: For Ord) (\proj -> proj s `compare` proj t) !! ctorIndex s
-- For data types with one constructor
memptyADT :: (ADT t, Constraints t Monoid) => t
memptyADT = head $ builds (For :: For Monoid) (const mempty)
-- For data types with one constructor
mappendADT :: (ADT t, Constraints t Monoid) => t -> t -> t
mappendADT s t = head $ builds (For :: For Monoid) (\proj -> proj s `mappend` proj t)
-- For data types with one constructor
fromIntegerADT :: (ADT t, Constraints t Num) => Integer -> t
fromIntegerADT i = head $ builds (For :: For Num) (const $ fromInteger i)
-- For data types with one constructor
num1 :: (ADT t, Constraints t Num) => (forall a. Num a => a -> a) -> t -> t
num1 op t = head $ builds (For :: For Num) (\proj -> op (proj t))
-- For data types with one constructor
num2 :: (ADT t, Constraints t Num) => (forall a. Num a => a -> a -> a) -> t -> t -> t
num2 op s t = head $ builds (For :: For Num) (\proj -> proj s `op` proj t)
minBoundADT :: (ADT t, Constraints t Bounded) => t
minBoundADT = head $ builds (For :: For Bounded) (const minBound)
maxBoundADT :: (ADT t, Constraints t Bounded) => t
maxBoundADT = last $ builds (For :: For Bounded) (const maxBound)
class (Bounded a, Enum a) => BoundedEnum a where
indexOf :: a -> Int
indexOf a = fromEnum a - fromEnum (minBound :: a)
instance (Bounded a, Enum a) => BoundedEnum a
fromEnumADT :: forall t. (ADT t, Constraints t BoundedEnum) => t -> Int
fromEnumADT t = totals !! ctorIndex t + fst (counts !! ctorIndex t)
where
counts :: [(Int, Int)]
counts = fmap (flip appEndo (0, 1) . getDual) (mbuilds (For :: For BoundedEnum) f)
totals :: [Int]
totals = snd $ mapAccumL (\a (_, b) -> (a + b, a)) 0 counts
f :: forall b. BoundedEnum b => (t -> b) -> Dual (Endo (Int, Int))
f proj = Dual $ Endo $ \(r, base) -> (r + base * indexOf (proj t), base * (1 + indexOf (maxBound :: b)))
toEnumADT :: forall t. (ADT t, Constraints t BoundedEnum) => Int -> t
toEnumADT = either id (const $ error "toEnumADT: Bad argument") . flip (foldlM g) (buildsA (For :: For BoundedEnum) f)
where
g :: Int -> State (Int, Int) t -> Either t Int
g i s = if total > i then Left t else Right (i - total)
where (t, (_, total)) = runState s (i, 1)
f :: forall b. BoundedEnum b => (t -> b) -> State (Int, Int) b
f _ = state $ \(r, base) ->
let
base' = base * (1 + indexOf (maxBound :: b))
(r', m) = divMod r base'
in (toEnum m, (r', base'))
fillADT :: forall t a. (ADT t, Constraints t ((~) a)) => a -> [t]
fillADT a = builds (For :: For ((~) a)) (const a)
-- foldADT :: forall t m. (ADT t, Constraints t ((~) m), Monoid m) => t -> m
-- foldADT t = getConstant $ buildsA (For :: For ((~) m)) f !! ctorIndex t
-- where
-- f :: forall b. m ~ b => (t -> b) -> Constant m b
-- f proj = Constant $ proj t
instance Monoid B.Put where
mempty = return ()
mappend = (>>)
putADT :: (ADT t, Constraints t B.Binary) => t -> B.Put
putADT t = B.putWord8 (toEnum (ctorIndex t)) >>
mbuilds (For :: For B.Binary) (\proj -> B.put (proj t)) !! ctorIndex t
getADT :: (ADT t, Constraints t B.Binary) => B.Get t
getADT = do
ix <- fromEnum <$> B.getWord8
buildsA (For :: For B.Binary) (const B.get) !! ix
data P a b = P { p1 :: a, p2 :: b } deriving Show
instance ADT (P a b) where
ctorIndex (P _ _) = 0
type Constraints (P a b) c = (c a, c b)
buildsA For f = [P <$> f p1 <*> f p2]
instance (Monoid a, Monoid b) => Monoid (P a b) where
mempty = memptyADT
mappend = mappendADT
instance (Num a, Num b) => Num (P a b) where
(+) = num2 (+)
(*) = num2 (*)
abs = num1 abs
signum = num1 signum
fromInteger = fromIntegerADT
instance (Bounded a, Bounded b) => Bounded (P a b) where
minBound = minBoundADT
maxBound = maxBoundADT
instance (Enum a, Bounded a, Enum b, Bounded b) => Enum (P a b) where
fromEnum = fromEnumADT
toEnum = toEnumADT
instance (B.Binary a, B.Binary b) => B.Binary (P a b) where
put = putADT
get = getADT
data Expr a where
Int :: Int -> Expr Int
Bool :: Bool -> Expr Bool
Ifte :: Expr Bool -> Expr a -> Expr a -> Expr a
instance ADT (Expr Int) where
ctorIndex (Int _) = 0
ctorIndex (Ifte _ _ _) = 1
type Constraints (Expr Int) c = (c Int, c (Expr Int), c (Expr Bool))
buildsA For f =
[ Int <$> f (\(Int i) -> i)
, Ifte <$> f (\(Ifte b _ _) -> b) <*> f (\(Ifte _ t _) -> t) <*> f (\(Ifte _ _ e) -> e)
]
instance ADT (Expr Bool) where
ctorIndex (Bool _) = 0
ctorIndex (Ifte _ _ _) = 1
type Constraints (Expr Bool) c = (c Bool, c (Expr Bool))
buildsA For f =
[ Bool <$> f (\(Bool b) -> b)
, Ifte <$> f (\(Ifte b _ _) -> b) <*> f (\(Ifte _ t _) -> t) <*> f (\(Ifte _ _ e) -> e)
]
instance B.Binary (Expr Int) where
put = putADT
get = getADT
instance B.Binary (Expr Bool) where
put = putADT
get = getADT
{-# LANGUAGE
RankNTypes
, TypeFamilies
, TypeOperators
, ConstraintKinds
, ScopedTypeVariables
#-}
import GHC.Prim (Constraint)
import Control.Applicative
import Data.Functor.Identity
import Data.Traversable (Traversable(..))
import Data.Unfolder (Unfolder(..))
import Data.Unfoldable (Unfoldable(..))
import Data.Foldable (Foldable(..))
import Data.Functor.Constant
import Data.Monoid
import Data.Tree
import Data.Functor.Compose
type f :~> g = forall x. f x -> g x
data For (c :: (* -> *) -> Constraint) = For
class ADT1 t where
ctorIndex :: t a -> Int
type Constraints t c :: Constraint
buildsA :: (Constraints t c, Applicative f)
=> For c
-> ((forall a. t a -> a) -> f b)
-> (forall s. c s => (t :~> s) -> f (s b))
-> [f (t b)]
builds :: (ADT1 t, Constraints t c)
=> For c
-> ((forall a. t a -> a) -> b)
-> (forall s. c s => (t :~> s) -> s b)
-> [t b]
builds for f g = fmap runIdentity $ buildsA for (Identity . f) (Identity . g)
mbuilds :: forall t c m. (ADT1 t, Constraints t c, Monoid m)
=> For c
-> ((forall a. t a -> a) -> m)
-> (forall s. c s => (t :~> s) -> m)
-> [m]
mbuilds for f g = fmap getConstant ms
where
ms :: [Constant m (t b)]
ms = buildsA for (Constant . f) (Constant . g)
fmapADT :: (ADT1 t, Constraints t Functor) => (a -> b) -> t a -> t b
fmapADT f ta = builds (For :: For Functor) (\proj -> f (proj ta)) (\proj -> fmap f (proj ta)) !! ctorIndex ta
foldMapADT :: (ADT1 t, Constraints t Foldable, Monoid m) => (a -> m) -> t a -> m
foldMapADT f ta = mbuilds (For :: For Foldable) (\proj -> f (proj ta)) (\proj -> foldMap f (proj ta)) !! ctorIndex ta
traverseADT :: (ADT1 t, Constraints t Traversable, Applicative f) => (a -> f b) -> t a -> f (t b)
traverseADT f ta = buildsA (For :: For Traversable) (\proj -> f (proj ta)) (\proj -> traverse f (proj ta)) !! ctorIndex ta
unfoldADT :: (ADT1 t, Constraints t Unfoldable, Unfolder f) => f a -> f (t a)
unfoldADT fa = choose $ buildsA (For :: For Unfoldable) (const fa) (const $ unfold fa)
-- For data types with one constructor
pureADT :: (ADT1 t, Constraints t Applicative) => a -> t a
pureADT a = head $ builds (For :: For Applicative) (const a) (const $ pure a)
-- For data types with one constructor
apADT :: (ADT1 t, Constraints t Applicative) => t (a -> b) -> t a -> t b
apADT tf ta = head $ builds (For :: For Applicative) (\proj -> proj tf (proj ta)) (\proj -> proj tf <*> proj ta)
-- For data types with one constructor
bindADT :: (ADT1 t, Constraints t Monad) => t a -> (a -> t b) -> t b
bindADT ta f = head $ builds (For :: For Monad) (\proj -> proj $ f (proj ta)) (\proj -> proj ta >>= (proj . f))
data BTree a = Leaf { value :: a } | Branch { left :: BTree a, right :: BTree a }
instance ADT1 BTree where
ctorIndex Leaf{} = 0
ctorIndex Branch{} = 1
type Constraints BTree c = c BTree
buildsA For param sub =
[ Leaf <$> param value
, Branch <$> sub left <*> sub right
]
instance ADT1 Tree where
ctorIndex Node{} = 0
type Constraints Tree c = c (Compose [] Tree)
buildsA For param sub =
[ (\a (Compose forest) -> Node a forest) <$> param rootLabel <*> sub (Compose . subForest) ]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.