HaskellでMonad使ったDSL書く練習 #1 未テスト

MinPrint.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

module MinPrint (
    MinPrint, Doc,
    text, br, nest,
    execMinPrint, printDoc
) where

import qualified Data.ByteString.Char8  as S

import Control.Applicative   (Applicative, pure, (*>))
import Data.Monoid           (Monoid, mempty, mappend)
import Data.String           (IsString, fromString)
import System.IO             (hFlush, hPutStr, stdout)

newtype MinPrint s a
    = MinPrint { unMinPrint :: Doc s -> (a, Doc s) }

data Doc s
    = Nil
    | Line (Item s) (Doc s)
    | Nest !Int (Doc s) (Doc s)
    deriving (Show)

data Item s
    = Cat (Item s) (Item s)
    | Empty
    | Text !s
    deriving (Show)

instance (Applicative f, Monoid a) => Monoid (f a) where
    mempty = pure mempty
    mappend = (*>)

instance Monad (MinPrint s) where
    return a = MinPrint $ \d -> (a, Line Empty d)
    m >>= k = MinPrint $ \d -> let (a, d') = unMinPrint m d
                               in unMinPrint (k a) d'

text :: s -> MinPrint s (Item s) 
text t = MinPrint $ \d -> let s' = Text t
                          in case d of
                            (Line Empty d'@(Line _ _)) -> (s', Line s' d')
                            (Line Empty d') -> (s', Line s' d)
                            (Line s     d') -> (s', Line (Cat s s') d')
                            _               -> (s', Line s' d)
                          
br :: MinPrint s (Item s)
br = MinPrint $ \d -> (Empty, Line Empty d)

nest :: Int -> MinPrint s a -> MinPrint s a
nest n m = MinPrint $ \d2 -> let (a, d1) = unMinPrint m Nil
                             in (a, Nest n d1 d2)

execMinPrint :: MinPrint s a -> Doc s
execMinPrint m = let ~(_, d) = runMinPrint Nil m
                 in d

runMinPrint :: Doc s -> MinPrint s a -> (a, Doc s)
runMinPrint d m = unMinPrint m d

printDoc :: (Monad m, Monoid (m a), IsString s) => (s -> m a) -> Doc s -> m a
printDoc f d = printTreeR f 0 d

printTreeR :: (Monad m, Monoid (m a), IsString s) => (s -> m a) -> Int -> Doc s -> m a
printTreeR f n Nil = mempty
printTreeR f n (Line s Nil) = do
    printWS f n
    printTreeL f s
printTreeR f n (Line s d) = do
    printTreeR f n d
    printBR f
    printWS f n
    printTreeL f s
printTreeR f n1 (Nest n2 d1 Nil) = do
    printTreeR f (n1+n2) d1
printTreeR f n1 (Nest n2 d1 d2) = do
    printTreeR f n1 d2
    printBR f
    printTreeR f (n1+n2) d1

printTreeL :: (Monad m, Monoid (m a)) => (s -> m a) -> Item s -> m a
printTreeL f Empty = mempty
printTreeL f (Cat s1 s2) = do
    printTreeL f s1
    printTreeL f s2
printTreeL f (Text s) = do
    f s

printWS :: (Monad m, IsString s) => (s -> m a) -> Int -> m a
printWS f n = f $ fromString $ take n $ repeat ' '

printBR :: (Monad m, IsString s) => (s -> m a) -> m a
printBR f = f $ fromString "\n"

main :: IO ()
main = do
    S.hPutStrLn stdout "## 1 ##########################"
    printDoc (S.hPutStr stdout) createDoc1
    S.hPutStrLn stdout "\n"
    S.hPutStrLn stdout "## 2 ##########################"
    printDoc (S.hPutStr stdout) createDoc2
    S.hPutStrLn stdout "\n"

createDoc1 :: (IsString s) => Doc s
createDoc1 = Line (Text "h")
                  (Line Empty
                        (Nest 4 (Nest 4 (Line (Cat (Text "f")
                                                   (Text "g"))
                                              Nil)
                                        (Line (Text "e")
                                              (Line (Cat (Text "c")
                                                         (Text "d"))
                                                    Nil)))
                                (Line (Cat (Text "a")
                                           (Text "b"))
                                      Nil)))
                                             
createDoc2 :: (IsString s) => Doc s
createDoc2 = execMinPrint $ do
    text "a"
    text "b"
    nest 4 $ do
        text "c"
        text "d"
        br
        text "e"
        nest 4 $ do
            text "f"
            text "g"
    br
    text "h"