NicerData.hs

{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

module NicerData where

import Data.Functor.Const
import Data.Functor.Identity
import Data.Typeable
import Data.Generics.Aliases
import System.Random

-- A more modern formulation of 'Data'
class Typeable a => Data a where
  -- | Apply @f@ to every immediate child 
  gfoldl :: Applicative c
         => (forall b. Data b => b -> c b)
         -> a -> c a

{-------------------------------------------------------------------------------
  Example
-------------------------------------------------------------------------------}

data A = MkA Int Bool B
  deriving (Show)

data B = MkB Int
  deriving (Show)

instance Data Int  where gfoldl _ = pure
instance Data Bool where gfoldl _ = pure

instance Data A where
  gfoldl f (MkA x y z) = MkA <$> f x <*> f y <*> f z

instance Data B where
  gfoldl f (MkB x) = MkB <$> f x

gmapT :: Data a => (forall b. Data b => b -> b) -> a -> a
gmapT f = runIdentity . gfoldl (Identity . f)

gmapM :: (Data a, Monad m) => (forall d. Data d => d -> m d) -> a -> m a
gmapM = gfoldl

gmapQ :: (Data a, Monoid u) => (forall d. Data d => d -> u) -> a -> u
gmapQ f = getConst . gfoldl (Const . f)

{-------------------------------------------------------------------------------
  Combinators
-------------------------------------------------------------------------------}

everything :: (Data a, Typeable b) => a -> [b]
everything x = mkQ (gmapQ everything x) (:[]) x

-- Variation on 'everything' that more clearly shows the computational structure
everythingFree :: (Data a, Typeable b) => a -> FreeMonoid b
everythingFree x = mkQ (gmapQ everythingFree x) One x

everywhere :: (Typeable a, Data b) => (a -> a) -> (b -> b)
everywhere f x =
    case cast f of
      Just f' -> f' x
      Nothing -> gmapT (everywhere f) x

everywhereM :: (Monad m, Typeable m, Typeable a, Data b) => (a -> m a) -> (b -> m b)
everywhereM f x =
    case cast f of
      Just f' -> f' x
      Nothing -> gmapM (everywhereM f) x

{-------------------------------------------------------------------------------
  Example
-------------------------------------------------------------------------------}

exampleFree1, exampleFree2, exampleFree3 :: FreeMonoid Int
exampleFree1 = everythingFree (1 :: Int)
exampleFree2 = everythingFree True
exampleFree3 = everythingFree (MkA 1 True (MkB 2))

exampleList1, exampleList2, exampleList3 :: [Int]
exampleList1 = everything (1 :: Int)
exampleList2 = everything True
exampleList3 = everything (MkA 1 True (MkB 2))

exampleMap :: A
exampleMap = everywhere inc (MkA 1 True (MkB 2))
  where
    inc :: Int -> Int
    inc = (+) 1

exampleMapM :: IO A
exampleMapM = everywhereM randomInt (MkA 10 True (MkB 1000))
  where
    randomInt :: Int -> IO Int
    randomInt hi = randomRIO (0, hi)

{-------------------------------------------------------------------------------
  Binary trees
-------------------------------------------------------------------------------}

-- | Free monoid
--
-- (Laws hold only "up to interpretation")
data FreeMonoid a = None | One a | Branch (FreeMonoid a) (FreeMonoid a)
  deriving (Show)

instance Monoid    (FreeMonoid a) where mempty = None
instance Semigroup (FreeMonoid a) where (<>)   = Branch