module Text.PrintScanF where
import Prelude hiding ((^))
class FormattingSpec repr where
lit :: String -> repr a a
int :: repr a (Int -> a)
char :: repr a (Char -> a)
fpp :: PrinterParser b -> repr a (b -> a)
(^) :: repr b c -> repr a b -> repr a c
infixl 5 ^
data PrinterParser a = PrinterParser (a -> String) (String -> Maybe (a,String))
fmt :: (FormattingSpec repr, Show b, Read b) => b -> repr a (b -> a)
fmt x = fpp showread
newtype FPr a b = FPr ((String -> a) -> b)
instance FormattingSpec FPr where
lit str = FPr $ \k -> k str
int = FPr $ \k -> \x -> k (show x)
char = FPr $ \k -> \x -> k [x]
fpp (PrinterParser pr _) = FPr $ \k -> \x -> k (pr x)
(FPr a) ^ (FPr b) = FPr $ \k -> a (\sa -> b (\sb -> k (sa ++ sb)))
newtype FSc a b = FSc (String -> b -> Maybe (a,String))
instance FormattingSpec FSc where
lit str = FSc $ \inp x ->
maybe Nothing (\inp' -> Just (x,inp')) $ prefix str inp
char = FSc $ \inp f -> case inp of
(c:inp) -> Just (f c,inp)
"" -> Nothing
fpp (PrinterParser _ pa) = FSc $ \inp f ->
maybe Nothing (\(v,s) -> Just (f v,s)) $ pa inp
int = fpp showread
(FSc a) ^ (FSc b) = FSc $ \inp f ->
maybe Nothing (\(vb,inp') -> b inp' vb) $ a inp f
sprintf :: FPr String b -> b
sprintf (FPr fmt) = fmt id
sscanf :: String -> FSc a b -> b -> Maybe a
sscanf inp (FSc fmt) f = maybe Nothing (Just . fst) $ 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