interleave.hs

{-# LANGUAGE OverloadedStrings         #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}

module Main where

import           Control.Applicative
import           Control.Error
import           Control.Monad.Trans.Class
import           Control.Monad
import           Control.Proxy
import           Control.Proxy.Trans.Attoparsec as PA
import qualified Data.Attoparsec.Text           as AT
import qualified Data.Text                      as T

--------------------------------------------------------------------------------
-- Our fancy data types

data Frame = Frame { frameTitle :: T.Text, frameBody :: T.Text }
  deriving (Eq, Show)

--------------------------------------------------------------------------------
-- Attoparsec parsers

{- Example full frame input:

A 11 characters long title and a body of length 6: Hello WorldLambda
-}


-- | Parse a 'Frame' header.
pFrameHeader :: Integral a => AT.Parser (a,a)
pFrameHeader = do
  AT.string "A "
  lenTitle <- AT.decimal
  AT.string " characters long title and a body of length "
  lenBody <- AT.decimal
  AT.string ": "
  return (lenTitle, lenBody)

--------------------------------------------------------------------------------
-- Two alternative AttoparsecP proxies for parsing 'Frame's.

-- | Continuously parse raw input flowing downstream representing a 'Frame'.
-- Send downstream the title of each parsed frame and discard the body.
-- In case of parsing failures the parsing error is printed to stdout and then
-- parsing continues.
debugParseFrameD :: Proxy p => ()
                      -> Pipe (AttoparsecP T.Text p) T.Text T.Text IO r
debugParseFrameD () = loop where
    loop = eitherT onFailure onSuccess $ do
      let parser = pFrameHeader -- <|> mzero
      -- ^The `mzero` here enables perfect backtracking in case of errors, and
      -- might or might not be needed, depending of how you wrote your parser.
      (lenTitle, lenBody) <- hoistEither =<< lift (eitherParseD parser)
      lift $ passN lenTitle >> skipN lenBody
      return (lenTitle, lenBody)
    onFailure e = do
      lift . putStrLn $ "debugFrameD parsing error: " ++ show e
      skipN 1 >> loop
    onSuccess x = do
      lift . putStrLn $ "debugFrameD parsing success: " ++ show x
      loop

-- | Continuously parse raw input flowing downstream representing a 'Frame'.
-- Send downstream the title of each parsed frame and discard the body.
-- In case of parsing failures a warning notice is printed to stdout and then
-- parsing continues.
warnParseFrameD :: Proxy p => () -> Pipe (AttoparsecP T.Text p) T.Text T.Text IO r
warnParseFrameD () = loop where
    loop = maybeT onFailure onSuccess $ do
      let parser = pFrameHeader -- <|> mzero
      -- ^The `mzero` here enables perfect backtracking in case of errors, and
      -- might or might not be needed, depending of how you wrote your parser.
      (lenTitle, lenBody) <- hoistMaybe =<< lift (maybeParseD parser)
      lift $ passN lenTitle >> skipN lenBody
    onFailure = do
      lift . putStrLn $ "warnParseFrameD parsing error"
      skipN 1 >> loop
    onSuccess x = do
      lift . putStrLn $ "warnParseFrameD parsing success: " ++ show x
      loop

--------------------------------------------------------------------------------
-- Sample input

input1 :: [T.Text]
input1 =
  [ "A 7 characters long title and a body of length 6: Hello 1Lambda"
  , "A 7 characters long title and a body of length 6: Hello 2Øáµbðá"
  , "A 7 characters long title and a body of length 6: Hello 3Lambda\
    \A 7 characters long title and a body of length 0: Hello 4"
  , "A 7 characters long title and a body of length 0: Hello 5"
  , "A\
    \A \
    \A 7\
    \A 7 \
    \A 7 characters long title and a body of length\
    \A 7 characters long title and a body of length \
    \A 7 characters long title and a body of length 6\
    \A 7 characters long title and a body of length 6:\
    \A 7 characters long title and a body of length 6: Hello 6Lambda\
    \A 7 characters long title and a body of length 6: Hello 7Lambda"
  , "A " , "7 ch"
  , "aracters long title and a body of "
  , "length 1"
  , "2: "
  , "Hello 8LambdaLambda"

  , "What?"
  , "FooA 7 characters long title and WHAT? a body of length 6: HelloCCLambda\
    \FooA 7 characters long title and WHAT? a body of length 6: Hello 9LambdaX"
  ]

output1 :: [T.Text]
output1 = map (\s -> T.pack ("Hello " ++ show s)) [1..9::Int]

--------------------------------------------------------------------------------
-- Fun stuff

run :: Bool -> IO ()
run debug = void $ do
  let p1 = if debug then debugParseFrameD else warnParseFrameD
      p = fromListS input1 >-> p1 >-> printD
  runProxy . PA.runParseK Nothing $ p

main :: IO ()
main = run True