module Text.PrintScan where
import Prelude hiding ((^))
data F a b where
FLit :: String -> F a a
FInt :: F a (Int -> a)
FChr :: F a (Char -> a)
FPP :: PrinterParser b -> F a (b -> a)
(:^) :: F b c -> F a b -> F a c
data PrinterParser a = PrinterParser (a -> String) (String -> Maybe (a,String))
infixl 5 ^
(^) = (:^)
lit = FLit
int = FInt
char = FChr
fmt :: (Show b, Read b) => b -> F a (b -> a)
fmt x = FPP showread
intp :: F a b -> (String -> a) -> b
intp (FLit str) k = k str
intp FInt k = \x -> k (show x)
intp FChr k = \x -> k [x]
intp (FPP (PrinterParser pr _)) k = \x -> k (pr x)
intp (a :^ b) k = intp a (\sa -> intp b (\sb -> k (sa ++ sb)))
ints :: F a b -> String -> b -> Maybe (a,String)
ints (FLit str) inp x = maybe Nothing (\inp' -> Just (x,inp')) $ prefix str inp
ints FChr (c:inp) f = Just (f c,inp)
ints FChr "" f = Nothing
ints (FPP (PrinterParser _ pa)) inp f =
maybe Nothing (\(v,s) -> Just (f v,s)) $ pa inp
ints FInt inp f = ints (FPP showread) inp f
ints (a :^ b) inp f = maybe Nothing (\(vb,inp') -> ints b inp' vb) $
ints a inp f
sprintf :: F String b -> b
sprintf fmt = intp fmt id
sscanf :: String -> F a b -> b -> Maybe a
sscanf inp fmt f = maybe Nothing (Just . fst) $ ints fmt inp f
tp1 = sprintf $ lit "Hello world"
ts1 = sscanf "Hello world" (lit "Hello world") ()
tp2 = sprintf (lit "Hello " ^ lit "world" ^ char) '!'
ts2 = sscanf "Hello world!" (lit "Hello " ^ lit "world" ^ char) id
fmt3 = lit "The value of " ^ char ^ lit " is " ^ int
tp3 = sprintf fmt3 'x' 3
ts3 = sscanf "The value of x is 3" fmt3 (\c i -> (c,i))
tp4 = sprintf (lit "abc" ^ int ^ lit "cde") 5
ts4 = sscanf "abc5cde" (lit "abc" ^ int ^ lit "cde") id
fmt50 = lit "abc" ^ int ^ lit "cde"
fmt5 = fmt50 ^ fmt (undefined::Float) ^ char
tp5 = sprintf fmt5 5 15 'c'
ts5 = sscanf "abc5cde15.0c" fmt5 (\i f c -> (i,f,c))
showread :: (Show a, Read a) => PrinterParser a
showread = PrinterParser show parse
where
parse s = case reads s of
[(v,s')] -> Just (v,s')
_ -> Nothing
prefix :: String -> String -> Maybe String
prefix "" str = Just str
prefix (pc:pr) (sc:sr) | pc == sc = prefix pr sr
prefix _ _ = Nothing