Main.hs

{-# language LambdaCase #-}
{-# language PatternSynonyms #-}
{-# language ViewPatterns #-}
{-# language DeriveFunctor #-}
{-# language DeriveFoldable #-}
{-# language DeriveTraversable #-}
{-# language TypeSynonymInstances #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
module Main where

import Control.Comonad.Trans.Cofree
import Control.Monad.Free
import Data.Functor.Compose
import Data.Functor.Foldable
import Data.Functor.Identity

type List a = Fix (ListF a)

pattern Cons' :: a -> List a -> List a
pattern Cons' a b = Fix (Cons a b)

pattern Nil' :: List a
pattern Nil' = Fix Nil

glength :: List a -> Int
glength = cata $ \case
  Nil      -> 0
  Cons _ n -> n + 1

gsum :: Num a => List a -> a
gsum = cata $ \case
  Nil      -> 0
  Cons m n -> m + n

gshow :: Show a => List a -> String
gshow = ("[" ++) . gshow'
  where
  gshow' = cata $ \case
    Nil         -> "]"
    Cons n next -> show n ++ "," ++ next

smartshow :: Show a => List a -> String
smartshow = ("[" ++) . smartshow'
  where
  smartshow' = para $ \case
    Nil -> "]"
    Cons n (t, next)
      | Nil' <- t -> show n ++ next
      | otherwise -> show n ++ "," ++ next

gmap :: (a -> b) -> List a -> List b
gmap f = cata $ \case
  Nil         -> Nil'
  Cons a next -> Cons' (f a) next

toList :: [a] -> List a
toList = \case
  []   -> Nil'
  a:as -> Cons' a (toList as)

fromList :: List a -> [a]
fromList = cata $ \case
  Nil         -> []
  Cons a next -> a:next

pattern List :: [a] -> List a
pattern List a <- (fromList -> a) where
  List a = toList a

gfilter :: (a -> Bool) -> List a -> List a
gfilter f = cata $ \case
  Nil         -> Nil'
  Cons a next
    | f a       -> Cons' a next
    | otherwise -> next

data ExprF a
  = LiteralF Int
  | AddF a a
  | MultiplyF a a
  | SubtractF a a
  deriving (Functor, Foldable, Traversable, Show)

type Expr = Fix ExprF
type UnaryFn = Free ExprF ()

pattern Literal :: Int -> Expr
pattern Literal i = Fix (LiteralF i)

pattern Add :: Expr -> Expr -> Expr
pattern Add a b = Fix (AddF a b)

pattern Multiply :: Expr -> Expr -> Expr
pattern Multiply a b = Fix (MultiplyF a b)

pattern Subtract :: Expr -> Expr -> Expr
pattern Subtract a b = Fix (SubtractF a b)

instance Num Expr where
  fromInteger = Literal . fromInteger
  (+) = Add
  (*) = Multiply
  (-) = Subtract

  abs = undefined
  signum = undefined

-- TODO: smart parens
showexpr :: Expr -> String
showexpr = cata $ \case
  LiteralF i    -> show i
  AddF a b      -> "(" ++ a ++ " + " ++ b ++ ")"
  MultiplyF a b -> "(" ++ a ++ " * " ++ b ++ ")"
  SubtractF a b -> "(" ++ a ++ " - " ++ b ++ ")"

evalexpr :: Expr -> Int
evalexpr = cata $ \case
  LiteralF i    -> i
  AddF a b      -> a + b
  MultiplyF a b -> a * b
  SubtractF a b -> a - b

-- rewrite * to +
transform :: Expr -> Expr
transform = cata $ \case
  MultiplyF l r -> Add l r
  other         -> Fix other

-- now the coalgebraic version!
cotransform :: Expr -> Expr
cotransform = ana $ \case
  Multiply l r -> AddF l r
  Fix other    -> other

lit :: Int -> UnaryFn
lit v = liftF (LiteralF v)

add :: UnaryFn -> UnaryFn -> UnaryFn
add l r = wrap (AddF l r)

mul :: UnaryFn -> UnaryFn -> UnaryFn
mul l r = wrap (MultiplyF l r)

sub :: UnaryFn -> UnaryFn -> UnaryFn
sub l r = wrap (SubtractF l r)

annotate :: Expr -> Cofree ExprF Int
annotate = ana $ \expr -> evalexpr expr :<< unfix expr

pattern (:<<) :: a -> f b -> Compose Identity (CofreeF f a) b
pattern a :<< b = Compose (Identity (a :< b))
{-# complete (:<<) #-}

showannotated :: Cofree ExprF Int -> String
showannotated = cata $ \case
  _ :<< LiteralF i    -> show i
  n :<< AddF a b      -> "[" ++ show n ++ "](" ++ a ++ " + " ++ b ++ ")"
  n :<< MultiplyF a b -> "[" ++ show n ++ "](" ++ a ++ " * " ++ b ++ ")"
  n :<< SubtractF a b -> "[" ++ show n ++ "](" ++ a ++ " - " ++ b ++ ")"

main :: IO ()
main = do
  let list :: List Int
      list = List [1, 2, 3]

  print $ glength list
  print $ gsum list
  putStrLn $ smartshow list
  putStrLn $ smartshow $ gmap (+1) list
  putStrLn $ smartshow $ gfilter even list

  let tree :: Expr
      tree = (3 + 4) * 6 - (-3)

  putStrLn $ showexpr tree
  print $ evalexpr tree
  putStrLn $ showexpr $ transform tree
  putStrLn $ showexpr $ cotransform tree

  putStrLn $ showannotated $ annotate tree