Repro.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE
  DataKinds,
  TypeFamilies,
  TypeOperators,
  FlexibleContexts,
  TypeApplications,
  FlexibleInstances,
  AllowAmbiguousTypes,
  ScopedTypeVariables,
  UndecidableInstances,
  MultiParamTypeClasses,
  NoMonomorphismRestriction,
  DeriveGeneric,
  DeriveAnyClass
#-}
module Main where

import Generics.OneLiner
import Data.Type.Equality

import Data.Functor.Identity
import Control.Applicative
import System.Random
import Weigh
import GHC.Generics
import Control.DeepSeq

data Tree a = TLeaf | Bin a (Tree a) (Tree a) deriving (Show, Eq, NFData, Generic)

genTree :: [Int] -> Tree Int
genTree []    = TLeaf
genTree [_]   = TLeaf
genTree (h:t@(_:_)) | even h = Bin h (genTree t) (genTree (tail t))
                    | odd h  = Bin h (genTree (tail t)) (genTree t)


-- Big trees (size 1542685, 36924 even labels, 477304 odd)
bigTrees :: [Tree Int]
bigTrees = [bigTreeGen seed | seed <- [123456789..223456789]]

bigTreeGen :: Int -> Tree Int
bigTreeGen seed = genTree . take 30 $ randomRs (0,100) (mkStdGen seed)

bigTree :: Tree Int
bigTree = head bigTrees

-- Smaller trees
smallerTrees :: [Tree Int]
smallerTrees = [smallerTreeGen seed | seed <- [123456789..223456789]]

smallerTreeGen :: Int -> Tree Int
smallerTreeGen seed = genTree . take 26 $ randomRs (0,100) (mkStdGen seed)

smallerTree :: Tree Int
smallerTree = head smallerTrees

-- Copied from the examples directory

class TinplateHelper (p :: Bool) a b where
  trav' :: Applicative f => (a -> f a) -> b -> f b

instance TinplateHelper 'True a a where trav' f = f

instance {-# OVERLAPPABLE #-} (ADT b, Constraints b (TinplateAlias a)) => TinplateHelper 'False a b where
  trav' = tinplate

instance TinplateHelper 'False a Char where trav' _ = pure
instance TinplateHelper 'False a Double where trav' _ = pure
instance TinplateHelper 'False a Float where trav' _ = pure
instance TinplateHelper 'False a Int where trav' _ = pure
instance TinplateHelper 'False a Word where trav' _ = pure
instance TinplateHelper 'False a Integer where trav' _ = pure

class TinplateAlias a b where
  trav :: Applicative f => (a -> f a) -> b -> f b
instance TinplateHelper (a == b) a b => TinplateAlias a b where
  trav = trav' @(a == b)


tinplate :: forall a b f. (ADT b, Constraints b (TinplateAlias a), Applicative f) => (a -> f a) -> b -> f b
tinplate f = gtraverse @(TinplateAlias a) (trav f)


tinmap f = runIdentity . tinplate (Identity . f)

mapTree :: (Int -> Int) -> (Tree Int -> Tree Int)
mapTree f = tinmap f

mapTreeInc :: Tree Int -> Tree Int
mapTreeInc = mapTree (+1)

handMap :: (a -> b) -> Tree a -> Tree b
handMap f TLeaf = TLeaf
handMap f (Bin a l r) = Bin (f a) (handMap f l) (handMap f r)

main = mainWith (do func "small" mapTreeInc smallerTree
                    func "smallH" (handMap (+1)) smallerTree )

--                    func "big" mapTreeInc bigTree )