Constraint-based generics

ADT.hs

{-# 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
 

ADT1.hs

{-# 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) ]