summaryrefslogtreecommitdiff
path: root/libraries/base/tests/T13191.hs
blob: d64fa71e24b611c0cf505231ac38ee17c24967be (plain)
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
-- To test with GHC before liftA2 was added to the Applicative
-- class, remove the definition of liftA2 here, and import
-- liftA2 separately from Control.Applicative.
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}


module Main where
import Control.Applicative (Applicative (..))
import Data.Monoid (Sum (..))
import qualified Data.Array as A

data Tree a = Leaf a a | Node (Tree a) (Tree a)
  deriving (Functor, Foldable, Traversable)

buildTree :: Int -> a -> Tree a
buildTree 0 a = Leaf a a
buildTree n a =
  let subtree = buildTree (n - 1) a
  in Node subtree subtree

data Nat = Z | S Nat

data Vec n a where
  Nil :: Vec 'Z a
  Cons :: a -> !(Vec n a) -> Vec ('S n) a

deriving instance Functor (Vec n)
deriving instance Foldable (Vec n)
deriving instance Show a => Show (Vec n a)

class Pure n where
  pure' :: a -> Vec n a
instance Pure 'Z where
  pure' _ = Nil
instance Pure n => Pure ('S n) where
  pure' a = Cons a (pure' a)

instance Pure n => Applicative (Vec n) where
  pure = pure'
  (<*>) = apVec
  liftA2 = liftA2Vec

apVec :: Vec n (a -> b) -> Vec n a -> Vec n b
apVec Nil Nil = Nil
apVec (Cons f fs) (Cons x xs) = f x `Cons` apVec fs xs

liftA2Vec :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c
liftA2Vec _ Nil Nil = Nil
liftA2Vec f (Cons x xs) (Cons y ys) = f x y `Cons` liftA2Vec f xs ys

data SomeVec a where
  SomeVec :: Pure n => Vec n a -> SomeVec a

replicateVec :: Int -> a -> SomeVec a
replicateVec 0 _ = SomeVec Nil
replicateVec n a =
  case replicateVec (n - 1) a of
    SomeVec v -> SomeVec (a `Cons` v)

ones :: SomeVec Int
ones = replicateVec 6000 (1 :: Int)

theTree :: Tree ()
theTree = buildTree 7 ()

blah :: SomeVec (Tree Int)
blah = case ones of
         SomeVec v -> SomeVec $ traverse (const v) theTree

main = case blah of
         SomeVec v -> print $ getSum $ foldMap (foldMap Sum) v