11{-# LANGUAGE RecordWildCards #-}
2+ {-# LANGUAGE LambdaCase #-}
23{-# LANGUAGE PatternGuards #-}
4+ {-# LANGUAGE ScopedTypeVariables #-}
5+ {-# LANGUAGE RankNTypes #-}
36
47
58module Network.Socket.ReadShow where
69
10+ import Text.Read ((<++) )
711import qualified Text.Read as P
12+ import qualified Text.Read.Lex as P
13+ import Control.Monad (mzero )
814
915-- type alias for individual correspondences of a (possibly partial) bijection
1016type Pair a b = (a , b )
@@ -19,77 +25,112 @@ eqFst x = \(x',_) -> x' == x
1925eqSnd :: Eq b => b -> (a , b ) -> Bool
2026eqSnd y = \ (_,y') -> y' == y
2127
22- -- | Return RHS element that is paired with provided LHS,
23- -- or apply a default fallback function if the list is partial
24- lookForward :: Eq a => (a -> b ) -> [Pair a b ] -> a -> b
25- lookForward defFwd ps x
26- = case filter (eqFst x) ps of
27- (_,y): _ -> y
28- [] -> defFwd x
29-
30- -- | Return LHS element that is paired with provided RHS,
31- -- or apply a default fallback function if the list is partial
32- lookBackward :: Eq b => (b -> a ) -> [Pair a b ] -> b -> a
33- lookBackward defBwd ps y
34- = case filter (eqSnd y) ps of
35- (x,_): _ -> x
36- [] -> defBwd y
37-
38- data Bijection a b
39- = Bijection
40- { defFwd :: a -> b
41- , defBwd :: b -> a
42- , pairs :: [Pair a b ]
43- }
44-
45- -- | apply a bijection over an LHS-value
46- forward :: (Eq a ) => Bijection a b -> a -> b
47- forward Bijection {.. } = lookForward defFwd pairs
48-
49- -- | apply a bijection over an RHS-value
50- backward :: (Eq b ) => Bijection a b -> b -> a
51- backward Bijection {.. } = lookBackward defBwd pairs
52-
53- -- | show function for Int-like types that encodes negative numbers
54- -- with leading '_' instead of '-'
55- _showInt :: (Show a , Num a , Ord a ) => a -> String
56- _showInt n | n < 0 = let (' -' : s) = show n in ' _' : s
57- | otherwise = show n
58-
59- -- | parse function for Int-like types that interprets leading '_'
60- -- as if it were '-' instead
61- _readInt :: (Read a ) => String -> a
62- _readInt (' _' : s) = read $ ' -' : s
63- _readInt s = read s
64-
65-
66- -- | parse a quote-separated pair into a tuple of Int-like values
67- -- should not be used if either type might have
68- -- literal quote-characters in the Read pre-image
69- _parse :: (Read a , Read b ) => String -> (a , b )
70- _parse xy =
71- let (xs, ' \' ' : ys) = break (== ' \' '
72- in (_readInt xs, _readInt ys)
73- {-# INLINE _parse #-}
74-
75- -- | inverse function to _parse
76- -- show a tuple of Int-like values as quote-separated strings
77- _show :: (Show a , Num a , Ord a , Show b , Num b , Ord b ) => (a , b ) -> String
78- _show (x, y) = _showInt x ++ " '" ++ _showInt y
79- {-# INLINE _show #-}
80-
81- defShow :: Eq a => String -> (a -> b ) -> (b -> String -> (a -> String
82- defShow name unwrap sho = \ x -> name ++ (sho . unwrap $ x)
28+
29+ -- | Unified automorphic involution over @Either a b@ that converts between
30+ -- LHS and RHS elements of a list of @Pair a b@ mappings and is the identity
31+ -- function if no matching pair is found
32+ --
33+ -- If list contains duplicate matches, short-circuits to the first matching @Pair@
34+ lookBetween :: (Eq a , Eq b ) => [Pair a b ] -> Either a b -> Either a b
35+ lookBetween ps = \ case
36+ Left | (_,y): _ <- filter (eqFst x) ps -> Right
37+ Right | (x,_): _ <- filter (eqSnd y) ps -> Left
38+ z -> z
39+
40+ -- Type alias for partial bijections between two types, consisting of a list
41+ -- of individual correspondences that are checked in order and short-circuit
42+ -- on first match
43+ --
44+ -- Depending on how this is used, may not actually be a true bijection over
45+ -- the partial types, as no overlap-checking is currently implemented. If
46+ -- overlaps are unavoidable, the canonical short-circuit pair should appear
47+ -- first to avoid round-trip inconsistencies.
48+ type Bijection a b = [Pair a b ]
49+
50+ -- | Helper function for prefixing an optional constructor name before arbitrary values,
51+ -- which only enforces high precedence on subsequent output if the constructor name is not
52+ -- blank and space-separates for non-blank constructor names
53+ namePrefix :: Int -> String -> (Int -> b -> ShowS -> b -> ShowS
54+ namePrefix i name f x
55+ | null name = f i x
56+ | otherwise = showParen (i > app_prec) $ showString name . showChar ' ' . f (app_prec+ 1 ) x
57+ {-# INLINE namePrefix #-}
58+
59+ -- | Helper function for defining bijective Show instances that represents
60+ -- a common use-case where a constructor (or constructor-like pattern) name
61+ -- (optionally) precedes an internal value with a separate show function
62+ defShow :: Eq a => String -> (a -> b ) -> (Int -> b -> ShowS -> (Int -> a -> ShowS
63+ defShow name unwrap shoPrec = \ i x -> namePrefix i name shoPrec (unwrap x)
8364{-# INLINE defShow #-}
8465
85- defRead :: Read a => String -> (b -> a ) -> (String -> b ) -> (String -> a )
86- defRead name wrap red = \ s ->
87- case splitAt (length name) s of
88- (x, sn) | x == name -> wrap $ red sn
89- _ -> error $ " defRead: unable to parse " ++ show s
66+ -- Helper function for stripping an optional constructor-name prefix before parsing
67+ -- an arbitrary value, which only consumes an extra token and increases precedence
68+ -- if the provided name prefix is non-blank
69+ expectPrefix :: String -> P. ReadPreca -> P. ReadPreca
70+ expectPrefix name pars
71+ | null name = pars
72+ | otherwise = do
73+ P. lift $ P. expect $ P. Ident
74+ P. step pars
75+ {-# INLINE expectPrefix #-}
76+
77+ -- | Helper function for defining bijective Read instances that represent a
78+ -- common use case where a constructor (or constructor-like pattern) name
79+ -- (optionally) precedes an internal value with a separate parse function
80+ defRead :: Eq a => String -> (b -> a ) -> P. ReadPrecb -> P. ReadPreca
81+ defRead name wrap redPrec = expectPrefix name $ wrap <$> redPrec
9082{-# INLINE defRead #-}
9183
92- -- | Apply a precedence-invariant one-token parse function within ReadPrec monad
93- tokenize :: (String -> a ) -> P. ReadPreca
94- tokenize f = P. lexP >>= \ (P. Ident-> return $ f x
95- {-# INLINE tokenize #-}
84+ -- | Alias for showsPrec that pairs well with `_readInt`
85+ _showInt :: (Show a ) => Int -> a -> ShowS
86+ _showInt = showsPrec
87+ {-# INLINE _showInt #-}
88+
89+ -- | More descriptive alias for `safeInt`
90+ _readInt :: (Bounded a , Integral a ) => P. ReadPreca
91+ _readInt = safeInt
92+ {-# INLINE _readInt #-}
93+
94+ -- | show two elements of a tuple separated by a space character
95+ -- inverse function to readIntInt when used on integer-like values
96+ showIntInt :: (Show a , Show b ) => Int -> (a , b ) -> ShowS
97+ showIntInt i (x, y) = _showInt i x . showChar ' ' . _showInt i y
98+ {-# INLINE showIntInt #-}
99+
100+ -- | consume and return two integer-like values from two consecutive lexical tokens
101+ readIntInt :: (Bounded a , Integral a , Bounded b , Integral b ) => P. ReadPreca , b )
102+ readIntInt = do
103+ x <- _readInt
104+ y <- _readInt
105+ return (x, y)
106+ {-# INLINE readIntInt #-}
107+
108+ bijectiveShow :: (Eq a ) => Bijection a String -> (Int -> a -> ShowS -> (Int -> a -> ShowS
109+ bijectiveShow bi def = \ i x ->
110+ case lookBetween bi (Left of
111+ Right -> showString y
112+ _ -> def i x
113+
114+ bijectiveRead :: (Eq a ) => Bijection a String -> P. ReadPreca -> P. ReadPreca
115+ bijectiveRead bi def = P. parens $ bijective <++ def
116+ where
117+ bijective = do
118+ (P. Ident<- P. lexP
119+ case lookBetween bi (Right of
120+ Left -> return x
121+ _ -> mzero
122+
123+ app_prec :: Int
124+ app_prec = 10
125+ {-# INLINE app_prec #-}
126+
127+ -- Parse integral values with type-specific overflow and underflow bounds-checks
128+ safeInt :: forall a . (Bounded a , Integral a ) => P. ReadPreca
129+ safeInt = do
130+ i <- signed
131+ if (i >= fromIntegral (minBound :: a ) && i <= fromIntegral (maxBound :: a ))
132+ then return $ fromIntegral i
133+ else mzero
134+ where
135+ signed :: P. ReadPrecInteger
136+ signed = P. readPrec
0 commit comments