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
|
