Parsing Proxy Transformer

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}

import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Control.Proxy
import Control.Proxy.Trans.Either
import Control.Proxy.Trans.State as S
import qualified Data.Text as T
import Data.Text.IO as TIO

newtype ParseP p a' a b' b m r =
    ParseP { unParseP :: EitherP String (StateP T.Text p) a' a b' b m r }
    deriving
        ( Functor
        , Applicative
        , Monad
        , MonadTrans
        , MonadPlus
        , MonadIO
        , Proxy
        , MonadPlusP
        , MonadIOP
        )

runParseK
 :: (q -> ParseP p a' a b' b m r)
 -> (q -> p a' a b' b m (Either String r, T.Text))
runParseK k q = runStateP (T.empty) . runEitherP . unParseP $ k q

instance ProxyTrans ParseP where
    liftP = ParseP . liftP . liftP

-- Simple version
string :: (Monad m, Proxy p) => T.Text -> Consumer (ParseP p) T.Text m T.Text
string str = ParseP go where
    len = T.length str
    go = do
        leftover <- liftP S.get
        if (T.length leftover < len)
            then do
                input <- request ()
                liftP $ S.put (T.append leftover input)
                go
            else do
                let (prefix, suffix) = T.splitAt len leftover
                if (prefix == str)
                    then do
                        liftP $ S.put suffix
                        return str
                    else do
                        let msg =  "Expected: '"
                                ++ T.unpack str
                                ++ "' -- Found: "
                                ++ T.unpack prefix
                        throw msg

{- Probably more efficient version, because:
   * It does not use put and get and handles state-passing manually
   * request is more efficient in base proxies than extended proxies
-}
string' :: (Monad m, Proxy p) => T.Text -> Consumer (ParseP p) T.Text m T.Text
string' str = ParseP $ EitherP $ StateP $ runIdentityK go where
    len = T.length str
    go leftover = do
        let len = T.length str
        if (T.length leftover < len)
            then do
                input <- request ()
                go (T.append leftover input)
            else do
                let (prefix, suffix) = T.splitAt len leftover
                if (prefix == str)
                    then return (Right str, suffix)
                    else do
                        let msg =  "Expected: '"
                                ++ T.unpack str
                                ++ "' -- Found: "
                                ++ T.unpack prefix
                        return (Left msg, leftover)

source1 :: (Monad m, Proxy p) => () -> Producer p T.Text m ()
source1 = fromListS ["Hell", "o, world!"]

source2 :: (Monad m, Proxy p) => () -> Producer p T.Text m ()
source2 = fromListS ["AAAA", "AAAAAA"]

sink :: (Proxy p) => () -> Consumer (ParseP p) T.Text IO ()
sink () = do
    str <- string "Hello"
    lift $ TIO.putStrLn str

main1 = runProxy $ runParseK $ source1 >-> sink
{- Outputs in ghci:
Hello
(Right (),", world!")
-}

main2 = runProxy $ runParseK $ source2 >-> sink
{- Outputs in ghci:
(Left "Expected: 'Hello' -- Found: AAAAA","AAAAAAAAAA")
-}
27:5: Warning: Redundant bracket
Found:
(q -> ParseP p a' a b' b m r) ->
(q -> p a' a b' b m (Either String r, T.Text))
Why not:
(q -> ParseP p a' a b' b m r) ->
q -> p a' a b' b m (Either String r, T.Text)
29:27: Error: Redundant bracket
Found:
(T.empty)
Why not:
T.empty
40:9: Warning: Redundant bracket
Found:
if (T.length leftover < len) then
do input <- request ()
liftP $ S.put (T.append leftover input)
go
else
do let (prefix, suffix) = T.splitAt len leftover
if (prefix == str) then
do liftP $ S.put suffix
return str
else
do let msg
= "Expected: '" ++
T.unpack str ++ "' -- Found: " ++ T.unpack prefix
throw msg
Why not:
if T.length leftover < len then
do input <- request ()
liftP $ S.put (T.append leftover input)
go
else
do let (prefix, suffix) = T.splitAt len leftover
if (prefix == str) then
do liftP $ S.put suffix
return str
else
do let msg
= "Expected: '" ++
T.unpack str ++ "' -- Found: " ++ T.unpack prefix
throw msg
47:17: Warning: Redundant bracket
Found:
if (prefix == str) then
do liftP $ S.put suffix
return str
else
do let msg
= "Expected: '" ++
T.unpack str ++ "' -- Found: " ++ T.unpack prefix
throw msg
Why not:
if prefix == str then
do liftP $ S.put suffix
return str
else
do let msg
= "Expected: '" ++
T.unpack str ++ "' -- Found: " ++ T.unpack prefix
throw msg
67:9: Warning: Redundant bracket
Found:
if (T.length leftover < len) then
do input <- request ()
go (T.append leftover input)
else
do let (prefix, suffix) = T.splitAt len leftover
if (prefix == str) then return (Right str, suffix) else
do let msg
= "Expected: '" ++
T.unpack str ++ "' -- Found: " ++ T.unpack prefix
return (Left msg, leftover)
Why not:
if T.length leftover < len then
do input <- request ()
go (T.append leftover input)
else
do let (prefix, suffix) = T.splitAt len leftover
if (prefix == str) then return (Right str, suffix) else
do let msg
= "Expected: '" ++
T.unpack str ++ "' -- Found: " ++ T.unpack prefix
return (Left msg, leftover)
73:17: Warning: Redundant bracket
Found:
if (prefix == str) then return (Right str, suffix) else
do let msg
= "Expected: '" ++
T.unpack str ++ "' -- Found: " ++ T.unpack prefix
return (Left msg, leftover)
Why not:
if prefix == str then return (Right str, suffix) else
do let msg
= "Expected: '" ++
T.unpack str ++ "' -- Found: " ++ T.unpack prefix
return (Left msg, leftover)