smile.hs

{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}

class Profunctor p where
  dimap :: (s -> a) -> (b -> t) -> p a b -> p s t

type Iso s t a b = forall p. Profunctor p => p a b -> p s t

iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso = dimap

data Tagged a b = Tag b

instance Profunctor Tagged where
  dimap _ f (Tag x) = Tag $ f x

untag :: Tagged a b -> b
untag (Tag x) = x

data Forget r a b = Forget (a -> r)

instance Profunctor (Forget r) where
  dimap f _ (Forget g) = Forget $ g . f

remember :: Forget r a b -> (a -> r)
remember (Forget f) = f

forwards :: Iso s t a b -> s -> a
forwards i = remember . i $ Forget id

backwards :: Iso s t a b -> b -> t
backwards i = untag . i . Tag

liftM2 :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c
liftM2 f a b = do a' <- a
                  b' <- b
                  return $ f a' b'

invert :: Iso s t a b -> Iso b a t s
invert = liftM2 iso backwards forwards

data Nat = Z | S Nat

data Repeat n where
  One :: String -> Repeat Z
  Again :: Repeat n -> Repeat (S n)

instance Show (Repeat n) where
  show (One s) = s
  show (Again r) = go 2 r where
    go :: Int -> Repeat n -> String
    go n (One s) = concat . take n $ repeat s
    go n (Again r) = go (n + 1) r

extract :: Repeat n -> String
extract (One s) = s
extract (Again r) = extract r

data SNat n where
  SO :: SNat Z
  SS :: SNat n -> SNat (S n)

reiterate :: SNat n -> String -> Repeat n
reiterate SO s = One s
reiterate (SS n) s = Again $ reiterate n s

repeated :: SNat n -> Iso String String (Repeat n) (Repeat n)
repeated s = iso (reiterate s) extract

descending :: SNat n -> String -> [String]
descending SO s = return . show $ forwards (repeated SO) s
descending (SS n) s = show (forwards (repeated $ SS n) s) : descending n s

data Language a r = Output a r
                  | Done

data Free f r = Free (f (Free f r)) | Pure r

interpret :: (Show a) => Free (Language a) r -> IO ()
interpret (Free (Output a x)) = print a >> interpret x
interpret (Free Done) = return ()
interpret (Pure _) = error "u fucked up"

emancipate :: [a] -> Free (Language a) r
emancipate = foldr (\x y -> Free . Output x $ y) $ Free Done

main :: IO ()
main = interpret . emancipate $ descending (SS (SS SO)) "smile!"