A DSL for editing streams defined in Haskell using a simple Monad

StreamEditor.hs

--
--  Documents are objects to which a set of edits can be performed.
--
--  A simple example is a text document which is subjected to a number of find
--  and replace operations.
--
--  This module implements a simple state monad which allows operations to be
--  written using do notation. Example
--
--  badfiction = "11pm. Night time in the city."
--
--  night2day :: StreamEditor ()
--  night2day = do
--      replace "day" "night"
--      replace "am" "pm"
--
--  badfiction' = editStream night2day badfiction
--

module System.StreamEditor (
    contains, delete, edit, prefix, replace, editStream, suffix, wrap
) where

import Data.List (isInfixOf)
import Test.HUnit
import Text.Regex (mkRegexWithOpts, subRegex)

data StreamEditor a =
    StreamEditor (String -> (String, a))

instance Monad StreamEditor where
    return a =
        StreamEditor (\s -> (s, a))
    StreamEditor fst0 >>= fd1 =
        StreamEditor $ \st0 ->
            let (st1, d1) = fst0 st0
                StreamEditor fst1 = fd1 d1
            in fst1 st1

editStream (StreamEditor sed) doc = fst (sed doc)

-- Editing primitives

edit :: (String -> String) -> StreamEditor ()
edit op = StreamEditor (\s -> (op s, ()))

replace :: String -> String -> StreamEditor ()
replace before after =
    let re = mkRegexWithOpts before False True
    in StreamEditor (\s -> (subRegex re s after, ()))

delete :: String -> StreamEditor ()
delete text =
    replace text ""

prefix :: String -> StreamEditor ()
prefix before = edit (before ++)

suffix :: String -> StreamEditor ()
suffix after = edit (++ after)

wrap :: String -> String -> StreamEditor ()
wrap before after = edit (\s -> before ++ s ++ after)

contains :: String -> StreamEditor Bool
contains text =
    StreamEditor (\s -> (s, text `isInfixOf` s))

-- Tests

assertEdit edit input expected =
    TestCase (assertEqual "" expected (editStream edit input))

replaceTest =
    let e = do replace "night" "day"
    in assertEdit e "It was night." "It was day."

matchingReplaceTest =
    let e = do replace "My name is (.*)\\." "Hello \\1!"
    in assertEdit e "My name is Ben." "Hello Ben!"

noMatchTest =
    let e = do replace "interesting" "fascinating"
        text = "Boring boring boring."
    in assertEdit e text text

deleteTest =
    let e = do delete "rubbish"
    in assertEdit e "This is a rubbish program." "This is a program."

prefixTest =
    let e = do prefix "Fact: "
    in assertEdit e "Pandas are rare." "Fact: Pandas are rare."

wrapTest =
    let e = do wrap "And then I said \"" "\""
    in assertEdit e "Not bloody likely." "And then I said \"Not bloody likely.\""

bindTest =
    let e = do
        replace "Ben" "Louise"
        replace "a simple program" "an excellent book"
        prefix "It was clear "
    in assertEdit e "Ben had written a simple program."
                    "It was clear Louise had written an excellent book."

containsTest =
    let e = do
        x <- contains "blah"
        if x then replace "blah" "foo" else replace "bar" "quux"
    in assertEdit e "This is totally blah." "This is totally foo."

main =
    runTestTT $ TestList [
        TestLabel "replace" replaceTest,
        TestLabel "replace with match" matchingReplaceTest,
        TestLabel "replace with pattern but no match" noMatchTest,
        TestLabel "delete" deleteTest,
        TestLabel "prefix" prefixTest,
        TestLabel "wrap" wrapTest,
        TestLabel "binding" bindTest,
        TestLabel "contains" containsTest
    ]