Skip to content

Instantly share code, notes, and snippets.

@sjoerdvisscher
Created August 8, 2010 20:02
Show Gist options
  • Save sjoerdvisscher/514469 to your computer and use it in GitHub Desktop.
Save sjoerdvisscher/514469 to your computer and use it in GitHub Desktop.
Exactly like clowns and jokers but with the same input and output types so dissection can be repeated.
{-# LANGUAGE TypeFamilies, EmptyDataDecls, TypeOperators, FlexibleInstances, ScopedTypeVariables #-}
import Data.Maybe (catMaybes)
import Data.List (intercalate)
import Control.Applicative (liftA2)
-- Void datatypes as labels, which are easier to work with
data K a
data X
data Rec
data p :+: q
data p :*: q
data Fl p
data Fr p
data DD p
data Void
type Zero = K Void
type One = K ()
-- Mapping from label to bifunctor datatype.
data family F p xs r :: *
data instance F (K a) xs r = K a
data instance F (p :+: q) xs r = L (F p xs r) | R (F q xs r)
data instance F (p :*: q) xs r = F p xs r :*: F q xs r
data instance F X (x, t) r = X x
data instance F Rec xs r = Rec r
data instance F (DD p) xs r = DD (F (D p) xs r)
-- I think this one is not right:
-- data instance F (Fl p) (x0, (x1, t)) r = Fl (F p (x0, t) r)
data instance F (Fr p) (x0, (x1, t)) r = Fr (F p (x1, t) r)
-- Dissection operation on the labels.
type family D p :: *
type instance D (K a) = Zero
type instance D X = One
type instance D Rec = DD Rec
type instance D (p :+: q) = D p :+: D q
type instance D (p :*: q) = (D p :*: Fr q) :+: (Fl p :*: D q)
type instance D (Fl p) = Fl (D p)
type instance D (Fr p) = Fr (D p)
type instance D (DD p) = DD (D p)
class Debug p where
debug :: p -> String
sumsOfProducts :: p -> [String] -> [Maybe [String]]
dataDecl :: p -> Int -> String
dataDecl p i = "data F" ++ replicate i '\'' ++ " " ++ unwords args ++ " = " ++ intercalate " | " ctors
where
ctors = zipWith showCtor (catMaybes $ sumsOfProducts p args) [0..]
showCtor ps i = "C" ++ show i ++ " " ++ unwords (fmap (\p -> "(" ++ p ++ ")") ps)
args = fmap (('x':) . show) [0 .. i]
instance Debug (K Void) where
debug _ = "0"
sumsOfProducts _ _ = [Nothing]
instance Debug (K ()) where
debug _ = "1"
sumsOfProducts _ _ = [Just []]
instance Debug (K Int) where
debug _ = "Int"
sumsOfProducts _ _ = [Just ["Int"]]
instance Debug X where
debug _ = "X"
sumsOfProducts _ (x:xs) = [Just [x]]
instance Debug Rec where
debug _ = "Rec"
sumsOfProducts _ xs = [Just ["F " ++ unwords xs]]
instance Debug p => Debug (DD p) where
debug _ = "(DD " ++ debug (undefined :: p) ++ ")"
sumsOfProducts _ xs = let [Just [f:s]] = sumsOfProducts (undefined :: p) xs in [Just [f:'\'':s]]
instance (Debug p, Debug q) => Debug (p :+: q) where
debug _ = "(" ++ debug (undefined :: p) ++ " + " ++ debug (undefined :: q) ++ ")"
sumsOfProducts _ xs = sumsOfProducts (undefined :: p) xs ++ sumsOfProducts (undefined :: q) xs
instance (Debug p, Debug q) => Debug (p :*: q) where
debug _ = "(" ++ debug (undefined :: p) ++ " * " ++ debug (undefined :: q) ++ ")"
sumsOfProducts _ xs =
[ liftA2 (++) (head $ sumsOfProducts (undefined :: p) xs) (head $ sumsOfProducts (undefined :: q) xs)]
instance Debug p => Debug (Fl p) where
debug _ = "(Fl " ++ debug (undefined :: p) ++ ")"
sumsOfProducts _ xs = sumsOfProducts (undefined :: p) (init xs)
instance Debug p => Debug (Fr p) where
debug _ = "(Fr " ++ debug (undefined :: p) ++ ")"
sumsOfProducts _ xs = sumsOfProducts (undefined :: p) (tail xs)
type Tree = X :+: (Rec :*: Rec)
test0 = dataDecl (undefined :: Tree) 0
-- "data F x0 = C0 (x0) | C1 (F x0) (F x0)"
test1 = dataDecl (undefined :: D Tree) 1
-- "data F' x0 x1 = C0 | C1 (F' x0 x1) (F x1) | C2 (F x0) (F' x0 x1)"
test2 = dataDecl (undefined :: D (D Tree)) 2
-- "data F'' x0 x1 x2 = C0 (F'' x0 x1 x2) (F x2) | C1 (F' x0 x1) (F' x1 x2) | C2 (F' x0 x1) (F' x1 x2) | C3 (F x0) (F'' x0 x1 x2)"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment