added snippets

css/default.css

@@ -34,7 +34,7 @@ div#header #navigation {
 div#header #navigation a {
     color: black;
     font-family: Garamond, Times New Roman, Serif;
-    font-size: 120%;
+    font-size: 115%;
     margin-left: 12px;
     text-decoration: none;
     text-transform: uppercase

site.cabal

@@ -20,9 +20,7 @@ test-suite site-test
   hs-source-dirs:      test
   main-is:             Spec.hs
   build-depends:       base
-                     , mddoctest
-                     , directory >= 1.2
+                     , doctest
                      , QuickCheck >= 2.9
-                     , ghc-typelits-natnormalise >= 0.5
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
   default-language:    Haskell2010

snippets.html

@@ -0,0 +1,4 @@
+---
+title: Code Snippets
+---
+$partial("templates/snippet-list.html")$

snippets/breadth-first.lhs

@@ -0,0 +1,67 @@
+---
+title: Breadth-First Rose Tree Traversals
+---
+
+These use implicit queues to efficiently perform breadth-first operations on rose trees.
+
+\begin{code}
+module BreadthFirst where
+
+import Data.Tree
+\end{code}
+
+The most basic is simply converting to a list breadth-first:
+
+\begin{code}
+breadthFirst :: Tree a -> [a]
+breadthFirst (Node x xs) = x : breadthFirstForest xs
+
+breadthFirstForest :: Forest a -> [a]
+breadthFirstForest ts = foldr f b ts []
+  where
+    f (Node x xs) fw bw = x : fw (xs : bw)
+
+    b [] = []
+    b qs = foldl (foldr f) b qs []
+\end{code}
+
+Then, we can delimit between levels of the tree:
+
+\begin{code}
+levels :: Tree a -> [[a]]
+levels (Node x xs) = [x] : levelsForest xs
+
+levelsForest :: Forest a -> [[a]]
+levelsForest ts = foldl f b ts [] []
+  where
+    f k (Node x xs) ls qs = k (x : ls) (xs : qs)
+
+    b _ [] = []
+    b k qs = k : foldl (foldl f) b qs [] []
+\end{code}
+
+Finally, we can build a tree back up again, monadically.
+
+\begin{code}
+unfoldForestM_BF :: Monad m => (b -> m (a, [b])) -> [b] -> m (Forest a)
+unfoldForestM_BF = unfoldForestMWith_BF concat
+
+unfoldTreeM_BF :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a)
+unfoldTreeM_BF f b = unfoldForestMWith_BF (head . head) f [b]
+
+unfoldForestMWith_BF :: Monad m => ([Forest a] -> c) -> (b -> m (a, [b])) -> [b] -> m c
+unfoldForestMWith_BF r f ts = b [ts] (\ls -> r . ls)
+  where
+    b [] k = pure (k id [])
+    b qs k = foldl g b qs [] (\ls -> k id . ls)
+
+    g a xs qs k = foldr t (\ls ys -> a ys (k . run ls)) xs [] qs
+
+    t a fw xs bw = f a >>= \(x,cs) -> fw (x:xs) (cs:bw)
+
+    run x xs = uncurry (:) . foldl go ((,) [] . xs) x
+      where
+        go ys y (z:zs) = (Node y z : ys', zs')
+          where
+            (ys',zs') = ys zs
+\end{code}

snippets/convolutions.lhs

@@ -0,0 +1,18 @@
+---
+title: Convolutions
+---
+
+Convolutions of a list give a different traversal order than what you would traditionally expect. Adapted from [here](https://byorgey.wordpress.com/2008/04/22/list-convolutions/).
+
+\begin{code}
+module Convolve where
+
+-- | >>> [1,2,3] <.> [4,5,6]
+-- [[(1,4)],[(1,5),(2,4)],[(1,6),(2,5),(3,4)],[(2,6),(3,5)],[(3,6)]]
+(<.>) :: [a] -> [b] -> [[(a,b)]]
+xs <.> ys = foldr f [] xs
+  where
+    f x zs = foldr (g x) id ys ([] : zs)
+    g x y a (z:zs) = ((x, y) : z) : a zs
+    g x y a [] = [(x, y)] : a []
+\end{code}

snippets/generic-church.lhs

@@ -0,0 +1,140 @@
+---
+title: Church-Encode a Datatype, Generically
+---
+
+Church-encoding of datatypes is a common pattern you'll see in Haskell. It's possible to do it generically, by using a sum-of-products encoding.
+
+Some preamble:
+
+\begin{code}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE EmptyCase            #-}
+{-# LANGUAGE DefaultSignatures    #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+
+module ChurchGen where
+
+import GHC.Generics
+import Data.Proxy
+import Prelude hiding (take)
+import Data.Void
+\end{code}
+
+The Church-encoding of something like `Bool`{.haskell} looks like this:
+
+\begin{code}
+-- | >>> bool False 1 0
+-- 1
+bool False f t = f
+bool True  f t = t
+\end{code}
+
+Kind of like a flipped if statement. To replicate it in generics takes some work:
+
+\begin{code}
+class Summable c where
+  type Sum c a r :: *
+  take :: c p -> (a -> r) -> Sum c a r
+  ignore :: Proxy c -> Proxy a -> r -> Sum c a r
+
+class Prodable c where
+  type Prod c r :: *
+  strip :: c p -> Prod c r -> r
+
+class ChurchGen c where
+  type FoldGen c a :: *
+  foldGen:: c a -> FoldGen c a
+
+instance Summable c => Summable (M1 i t c) where
+  type Sum (M1 i t c) a r = Sum c a r
+  take (M1 x) = take x
+  ignore (_ :: Proxy (M1 i t c)) = ignore (Proxy :: Proxy c)
+
+instance Prodable c => Prodable (M1 i t c) where
+  type Prod (M1 i t c) r = Prod c r
+  strip (M1 x) = strip x
+
+instance ChurchGen c => ChurchGen (M1 i t c) where
+  type FoldGen (M1 i t c) a = FoldGen c a
+  foldGen (M1 x) = foldGen x
+
+instance Summable (K1 i c) where
+  type Sum (K1 i c) a r = (c -> a) -> r
+  take (K1 x) k f = k (f x)
+  ignore _ _ r _ = r
+
+instance Summable U1 where
+  type Sum U1 a r = a -> r
+  take U1 k f = k f
+  ignore _ _ r _ = r
+
+instance Prodable U1 where
+  type Prod U1 r = r
+  strip U1 x = x
+
+instance ChurchGen U1 where
+  type FoldGen U1 a = a -> a
+  foldGen U1 x = x
+
+instance Summable V1 where
+  type Sum V1 a r = r
+  take x = case x of
+  ignore _ _ = id
+
+instance Prodable V1 where
+  type Prod V1 r = Void -> r
+  strip x = case x of
+
+instance Prodable (K1 i c) where
+  type Prod (K1 i c) r = c -> r
+  strip (K1 x) f = f x
+
+instance ChurchGen (K1 i c) where
+  type FoldGen (K1 i c) a = (c -> a) -> a
+  foldGen(K1 x) f = f x
+
+instance (Summable li, Summable ri) => Summable (li :+: ri) where
+  type Sum (li :+: ri) a r = Sum li a (Sum ri a r)
+  take (L1 x) (k :: a -> r) = take x (ignore (Proxy :: Proxy ri) (Proxy :: Proxy a) . k)
+  take (R1 x) (k :: a -> r) = ignore (Proxy :: Proxy li) (Proxy :: Proxy a) (take x k)
+  ignore p a x = ignore (Proxy :: Proxy li) a (ignore (Proxy :: Proxy ri) a x)
+
+instance (Summable li, Summable ri) => ChurchGen (li :+: ri) where
+  type FoldGen (li :+: ri) a = Sum li a (Sum ri a a)
+  foldGen(x :: (li :+: ri) a) = take x (id :: a -> a)
+
+instance (Prodable li, Prodable ri) => Prodable (li :*: ri) where
+  type Prod (li :*: ri) a = Prod li (Prod ri a)
+  strip (li :*: ri) f = strip ri (strip li f)
+
+instance (Prodable li, Prodable ri) => ChurchGen (li :*: ri) where
+  type FoldGen (li :*: ri) a = Prod li (Prod ri a) -> a
+  foldGen(li :*: ri) f = strip ri (strip li f)
+
+instance (Prodable li, Prodable ri) => Summable (li :*: ri) where
+  type Sum (li :*: ri) a r = Prod li (Prod ri a) -> r
+  take x k = k . strip x
+  ignore _ _ r _ = r
+
+class Church c where
+  type Fold c a :: *
+  type Fold c a = FoldGen (Rep c) a
+  fold :: Proxy a -> c -> Fold c a
+  default fold :: (Generic c, ChurchGen (Rep c), FoldGen (Rep c) a ~ Fold c a) => proxy a -> c -> Fold c a
+  fold = defaultFold
+
+defaultFold :: (Generic c, ChurchGen (Rep c)) => proxy a -> c -> FoldGen (Rep c) a
+defaultFold (p :: proxy a) (x :: c) = foldGen (from x :: Rep c a)
+\end{code}
+
+After all of that, we can write the church-encoded bool function like so:
+
+\begin{code}
+instance Church Bool
+
+-- | >>> fold (Proxy :: Proxy Int) False 0 1
+-- 0
+\end{code}

snippets/nary-uncurry.lhs

@@ -0,0 +1,45 @@
+---
+title: liftAN
+---
+
+There's a family of functions in [Control.Applicative](https://hackage.haskell.org/package/base-4.11.0.0/docs/Control-Applicative.html) which follow the pattern `liftA2`{.haskell}, `liftA3`{.haskell}, etc. Using some tricks from Richard Eisenberg's thesis we can write them all at once.
+
+\begin{code}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE FlexibleContexts      #-}
+
+module Apply where
+
+data Nat = Z | S Nat
+
+type family AppFunc f (n :: Nat) arrows where
+  AppFunc f 'Z a = f a
+  AppFunc f ('S n) (a -> b) = f a -> AppFunc f n b
+
+type family CountArgs f where
+  CountArgs (a -> b) = 'S (CountArgs b)
+  CountArgs result = 'Z
+
+class (CountArgs a ~ n) => Applyable a n where
+  apply :: Applicative f => f a -> AppFunc f (CountArgs a) a
+
+instance (CountArgs a ~ 'Z) => Applyable a 'Z where
+  apply = id
+  {-# INLINE apply #-}
+
+instance Applyable b n => Applyable (a -> b) ('S n) where
+  apply f x = apply (f <*> x)
+  {-# INLINE apply #-}
+
+-- | >>> lift (\x y z -> x ++ y ++ z) (Just "a") (Just "b") (Just "c")
+-- Just "abc"
+lift :: (Applyable a n, Applicative f) => (b -> a) -> (f b -> AppFunc f n a)
+lift f x = apply (fmap f x)
+{-# INLINE lift #-}
+\end{code}
+
+
+[Eisenberg, Richard A. “Dependent Types in Haskell: Theory and Practice.” University of Pennsylvania, 2016.](https://github.com/goldfirere/thesis/raw/master/built/thesis.pdf)

snippets/one-pass-choose.lhs

@@ -0,0 +1,24 @@
+---
+title: Choose a random item from a list in one pass
+---
+
+Adapted from [here](https://blog.plover.com/prog/weighted-reservoir-sampling.html).
+
+\begin{code}
+{-# LANGUAGE BangPatterns #-}
+
+module Choose where
+
+import System.Random
+import GHC.Base (oneShot)
+
+choose :: (Foldable f, RandomGen g) =>  f a -> g -> (Maybe a, g)
+choose xs = foldr f (const (,)) xs (0 :: Integer) Nothing
+  where
+    f x a = oneShot (\ !c m g -> case m of 
+      Nothing -> a 1 (Just x) g
+      Just y -> case randomR (0,c) g of
+        (0,g') -> a (c+1) (Just x) g'
+        (_,g') -> a (c+1) (Just y) g')
+    {-# INLINE f #-}
+\end{code}

snippets/unfoldl.lhs

@@ -0,0 +1,27 @@
+---
+title: Unfoldl
+---
+
+\begin{code}
+{-# LANGUAGE LambdaCase #-}
+
+module Unfoldl where
+
+import GHC.Base (build)
+import Data.Tuple (swap)
+
+unfoldl :: (b -> Maybe (a, b)) -> b -> [a]
+unfoldl f b =
+    build
+        (\c n ->
+              let r a = maybe a (uncurry (r . (`c` a))) . f
+              in r n b)
+
+-- | >>> toDigs 10 123
+-- [1,2,3]
+toDigs :: (Integral a, Num a) => a -> a -> [a]
+toDigs base =
+  unfoldl (\case
+    0 -> Nothing
+    n -> Just (swap (n `quotRem` base)))
+\end{code}