Printer.hs

import Data.Semigroup (stimes)
import qualified Data.List as List

import Prelude hiding (words)

data Layout a = Space | Content a
  deriving (Eq, Show)

layout :: b -> (a -> b) -> Layout a -> b
layout space f c =
  case c of
    Space -> space
    Content a -> f a

newtype Doc a = Doc { unDoc :: [Line a] }
  deriving (Eq, Show)

-- | The 'Semigroup' instance for 'Doc' performs vertical concatenation
instance Semigroup (Doc a) where
  Doc a <> Doc b = Doc (a <> b)

instance Monoid (Doc a) where
  -- | The empty document
  mempty = Doc mempty

newtype Line a = Line { unLine :: [Layout a] }
  deriving (Eq, Show)

-- | The 'Semigroup' instance for 'Line' performs horizontal concatenation
instance Semigroup (Line a) where
  Line a <> Line b = Line (a <> b)

instance Monoid (Line a) where
  -- | The empty line
  mempty = Line mempty

word :: a -> Line a
word a = Line [Content a]

space :: Line a
space = Line [Space]

-- | @words ws1 <> words ws2 = words (ws1 <> ws2)
words :: [a] -> Line a
words = Line . List.intersperse Space . fmap Content

-- | A document with a single line
line :: Line a -> Doc a
line l = Doc [l]

-- | @lines ls1 <> lines ls2 = lines (ls1 <> ls2)
lines :: [Line a] -> Doc a
lines = Doc

-- | A document with all lines indented by @n@ spaces
--
-- @indented m (indented n d) = indented (m + n) d@
indented :: Int -> Doc a -> Doc a
indented n (Doc ls) = Doc (Line . (replicate n Space <>) . unLine <$> ls)

render ::
  Monoid m =>
  -- | How to display a space
  m ->
  -- | How to display a newline
  m ->
  -- | How to display content
  (a -> m) ->
  Doc a ->
  m
render space newline f = go . unDoc
  where
    go ls =
      case ls of
        [] -> mempty
        Line l : ls' ->
          foldMap (layout space f) l <>
          case ls' of
            [] -> mempty
            _:_ -> newline <> go ls'