parselets

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
{-# LANGUAGE
             ScopedTypeVariables
             ,TypeSynonymInstances
             ,FlexibleInstances
             ,MultiParamTypeClasses

          #-}

import Control.Applicative
import Data.Monoid
import System.IO.Unsafe
import Control.Exception  as CE
import Data.List(isPrefixOf)
import Data.Maybe
import Debug.Trace
(!>)= flip trace

data RS v a= RS v  (Maybe a)

newtype RSView v a=  RSView{runRSView :: (v -> (RS v a,v))}

instance Functor (RSView v) where
  fmap f (RSView p)=RSView $  \v -> let (RS v1 x, r)= p v
                                    in (RS v1 (fmap f x),r)



instance Monoid v => Applicative( RSView v) where
  pure a  = RSView ( \v  -> (RS  mempty $ Just a,v))

  RSView f <*> RSView g= RSView ( \v  ->

                   let (RS v1 k,r)  = f v 

                       (RS v2 x,r2) = g r

                   in  (RS (mappend v1 v2) (k <*> x),r2))

instance  Monoid v => Alternative (RSView v) where

  empty= RSView $ \v -> (RS mempty Nothing, v)
  RSView f <|> RSView g= RSView ( \v  ->

                   let rs@(RS v1 k,r)  = f v 



                   in case k of
                     Just _  -> rs
                     Nothing -> g v )




class Monoid v =>  ParseLet a v where
  parse :: Maybe a -> RSView v a -- must not use pattern match

serial :: ParseLet a v => a -> v
serial x    = getSerial $ (runRSView $ parse  (Just x)) mempty
   where
   getSerial  (RS v _,_)= v

deserial :: ParseLet a v =>  v -> Maybe a
deserial str= getDeserial ( (runRSView ( parse Nothing)) str)
   where
   getDeserial (RS _ x,_)= x

sel f mpx= unsafePerformIO $
   CE.handle (\(e:: SomeException) -> return Nothing)
   $ let x= f $ fromJust mpx in x `seq` return (Just x)




pString :: (Read a, Show a)=>  Maybe a -> RSView String a
pString (Just fpx)= RSView $ \str ->  (RS (show$ fpx) (Just fpx),str)


pString Nothing  = RSView $ \str ->
          case readsPrec  1 str of
                  []      ->  (RS " " Nothing, str)
                  (x,r):_ ->  (RS " " (Just x), r)


--str :: String -> RSView String ()
str s= RSView ( \st ->
   let readit= if isPrefixOf s st then Just() else Nothing
   in (RS (s++" ") readit , drop (length s) st))



data P = I Int | S String deriving (Read, Show)

instance   ParseLet P String where
    parse mpx  =   I <$> (str "I" *> pString (sel (\(I x) -> x) mpx ))
              <|>  S <$> (str "S" *> pString (sel (\(S s) -> s) mpx ))

main =  do
   putStrLn . serial $ S "hi"
   print (deserial "I 2" :: Maybe P )

20:29: Warning: Redundant bracket
Found:
runRSView :: (v -> (RS v a, v))
Why not:
runRSView :: v -> (RS v a, v)
64:29: Warning: Redundant bracket
Found:
(runRSView (parse Nothing)) str
Why not:
runRSView (parse Nothing) str
76:44: Warning: Redundant $
Found:
show $ fpx
Why not:
show fpx
87:19: Warning: Use infix
Found:
isPrefixOf s st
Why not:
s `isPrefixOf` st