1-- To test with GHC before liftA2 was added to the Applicative 2-- class, remove the definition of liftA2 here, and import 3-- liftA2 separately from Control.Applicative. 4{-# LANGUAGE DeriveTraversable, GADTs, DataKinds, 5 DeriveFunctor, StandaloneDeriving #-} 6 7module Main where 8import Control.Applicative (Applicative (..)) 9import Data.Monoid (Sum (..)) 10import qualified Data.Array as A 11 12data Tree a = Leaf a a | Node (Tree a) (Tree a) 13 deriving (Functor, Foldable, Traversable) 14 15buildTree :: Int -> a -> Tree a 16buildTree 0 a = Leaf a a 17buildTree n a = 18 let subtree = buildTree (n - 1) a 19 in Node subtree subtree 20 21data Nat = Z | S Nat 22 23data Vec n a where 24 Nil :: Vec 'Z a 25 Cons :: a -> !(Vec n a) -> Vec ('S n) a 26 27deriving instance Functor (Vec n) 28deriving instance Foldable (Vec n) 29deriving instance Show a => Show (Vec n a) 30 31class Pure n where 32 pure' :: a -> Vec n a 33instance Pure 'Z where 34 pure' _ = Nil 35instance Pure n => Pure ('S n) where 36 pure' a = Cons a (pure' a) 37 38instance Pure n => Applicative (Vec n) where 39 pure = pure' 40 (<*>) = apVec 41 liftA2 = liftA2Vec 42 43apVec :: Vec n (a -> b) -> Vec n a -> Vec n b 44apVec Nil Nil = Nil 45apVec (Cons f fs) (Cons x xs) = f x `Cons` apVec fs xs 46 47liftA2Vec :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c 48liftA2Vec _ Nil Nil = Nil 49liftA2Vec f (Cons x xs) (Cons y ys) = f x y `Cons` liftA2Vec f xs ys 50 51data SomeVec a where 52 SomeVec :: Pure n => Vec n a -> SomeVec a 53 54replicateVec :: Int -> a -> SomeVec a 55replicateVec 0 _ = SomeVec Nil 56replicateVec n a = 57 case replicateVec (n - 1) a of 58 SomeVec v -> SomeVec (a `Cons` v) 59 60ones :: SomeVec Int 61ones = replicateVec 6000 (1 :: Int) 62 63theTree :: Tree () 64theTree = buildTree 7 () 65 66blah :: SomeVec (Tree Int) 67blah = case ones of 68 SomeVec v -> SomeVec $ traverse (const v) theTree 69 70main = case blah of 71 SomeVec v -> print $ getSum $ foldMap (foldMap Sum) v 72