Skip to content

Instantly share code, notes, and snippets.

@afternoon
Created November 23, 2016 13:31
Show Gist options
  • Save afternoon/ea6ef4bb84e71df8c769ef7e93e94bd4 to your computer and use it in GitHub Desktop.
Save afternoon/ea6ef4bb84e71df8c769ef7e93e94bd4 to your computer and use it in GitHub Desktop.
A DSL for editing streams defined in Haskell using a simple Monad
--
-- 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
]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment