public
Last active

Constraint-based generics

  • Download Gist
ADT.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203
{-# 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
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
{-# 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) ]

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.