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