module Generics.EMGM.Functions.Read (
Read(..),
readPrec,
readP,
readsPrec,
reads,
read,
) where
import Prelude hiding (Read, read, reads, readsPrec)
import Data.List (find)
import Text.ParserCombinators.ReadPrec (ReadPrec, step, (+++), pfail, lift,
readPrec_to_S, readPrec_to_P)
import qualified Text.ParserCombinators.ReadPrec as RP (prec)
import Text.ParserCombinators.ReadP (ReadP)
import Text.Read (Lexeme(Punc), lexP, parens, reset)
import qualified Text.Read as TR (readPrec)
import Text.Read.Lex (hsLex)
import qualified GHC.Read as GHC (list)
import Generics.EMGM.Base
newtype Read a = Read { selRead :: ConType -> ReadPrec a }
comma :: ReadPrec ()
comma = do Punc "," <- lexP
return ()
equals :: ReadPrec ()
equals = do Punc "=" <- lexP
return ()
paren :: ReadPrec a -> ReadPrec a
paren p = do Punc "(" <- lexP
x <- reset p
Punc ")" <- lexP
return x
wrapTuple :: ReadPrec a -> ReadPrec a
wrapTuple = parens . paren
tuple2 :: ReadPrec a -> ReadPrec b -> ReadPrec (a,b)
tuple2 pa pb =
do a <- pa
comma
b <- pb
return (a,b)
tuple3 :: ReadPrec a -> ReadPrec b -> ReadPrec c -> ReadPrec (a,b,c)
tuple3 pa pb pc =
do (a,b) <- tuple2 pa pb
comma
c <- pc
return (a,b,c)
tuple4 :: ReadPrec a -> ReadPrec b -> ReadPrec c -> ReadPrec d -> ReadPrec (a,b,c,d)
tuple4 pa pb pc pd =
do (a,b) <- tuple2 pa pb
comma
(c,d) <- tuple2 pc pd
return (a,b,c,d)
braces :: ReadPrec a -> ReadPrec a
braces p = do Punc "{" <- lexP
x <- reset p
Punc "}" <- lexP
return x
lexT :: String -> ReadPrec ()
lexT expected =
do found <- lift hsLex
if found == expected
then return ()
else pfail
rsumRead :: Read a -> Read b -> ConType -> ReadPrec (a :+: b)
rsumRead ra rb _ =
(fmap L $ selRead ra UnknownC) +++ (fmap R $ selRead rb UnknownC)
rprodRead :: Read a -> Read b -> ConType -> ReadPrec (a :*: b)
rprodRead ra rb ct =
case ct of
NormalC ->
do a <- step (selRead ra NormalC)
b <- step (selRead rb NormalC)
return (a :*: b)
InfixC symbol ->
do a <- step (selRead ra NormalC)
lexT symbol
b <- step (selRead rb NormalC)
return (a :*: b)
RecordC ->
do a <- step $ selRead ra RecordC
comma
b <- step $ selRead rb RecordC
return (a :*: b)
_ ->
pfail
rconRead :: ConDescr -> Read a -> ConType -> ReadPrec a
rconRead cd ra _ =
parens $
case cd of
ConDescr name _ False Prefix ->
do lexT name
step $ selRead ra NormalC
ConDescr name _ False fixity ->
do let p = prec fixity
RP.prec p $ step $ selRead ra $ InfixC name
ConDescr name _ True Prefix ->
do lexT name
braces $ step $ selRead ra RecordC
ConDescr name _ True _ ->
do paren (lexT name)
braces $ step $ selRead ra RecordC
rlblRead :: LblDescr -> Read a -> ConType -> ReadPrec a
rlblRead (LblDescr label) ra _ =
do lexT label
equals
selRead ra UnknownC
rtypeRead :: EP d a -> Read a -> ConType -> ReadPrec d
rtypeRead ep ra = fmap (to ep) . selRead ra
instance Generic Read where
rint = Read $ const TR.readPrec
rinteger = Read $ const TR.readPrec
rfloat = Read $ const TR.readPrec
rdouble = Read $ const TR.readPrec
rchar = Read $ const TR.readPrec
runit = Read $ const $ return Unit
rsum ra rb = Read $ rsumRead ra rb
rprod ra rb = Read $ rprodRead ra rb
rcon cd ra = Read $ rconRead cd ra
rlbl ld ra = Read $ rlblRead ld ra
rtype ep ra = Read $ rtypeRead ep ra
instance (Rep Read a) => Rep Read [a] where
rep = Read $ const $ GHC.list $ readPrec
instance Rep Read String where
rep = Read $ const TR.readPrec
instance Rep Read () where
rep = Read $ const TR.readPrec
instance (Rep Read a, Rep Read b) => Rep Read (a,b) where
rep = Read $ const $ wrapTuple $
tuple2 readPrec readPrec
instance (Rep Read a, Rep Read b, Rep Read c)
=> Rep Read (a,b,c) where
rep = Read $ const $ wrapTuple $
tuple3 readPrec readPrec readPrec
instance (Rep Read a, Rep Read b, Rep Read c, Rep Read d)
=> Rep Read (a,b,c,d) where
rep = Read $ const $ wrapTuple $
tuple4 readPrec readPrec readPrec readPrec
instance (Rep Read a, Rep Read b, Rep Read c, Rep Read d, Rep Read e)
=> Rep Read (a,b,c,d,e) where
rep = Read $ const $ wrapTuple $
do (a,b,c,d) <- tuple4 readPrec readPrec readPrec readPrec
comma
e <- readPrec
return (a,b,c,d,e)
instance (Rep Read a, Rep Read b, Rep Read c, Rep Read d, Rep Read e,
Rep Read f)
=> Rep Read (a,b,c,d,e,f) where
rep = Read $ const $ wrapTuple $
do (a,b,c,d) <- tuple4 readPrec readPrec readPrec readPrec
comma
(e,f) <- tuple2 readPrec readPrec
return (a,b,c,d,e,f)
instance (Rep Read a, Rep Read b, Rep Read c, Rep Read d, Rep Read e,
Rep Read f, Rep Read h)
=> Rep Read (a,b,c,d,e,f,h) where
rep = Read $ const $ wrapTuple $
do (a,b,c,d) <- tuple4 readPrec readPrec readPrec readPrec
comma
(e,f,h) <- tuple3 readPrec readPrec readPrec
return (a,b,c,d,e,f,h)
readPrec :: (Rep Read a) => ReadPrec a
readPrec = selRead rep UnknownC
readsPrec ::
(Rep Read a)
=> Int
-> ReadS a
readsPrec = readPrec_to_S readPrec
readP ::
(Rep Read a)
=> Int
-> ReadP a
readP = readPrec_to_P readPrec
reads :: (Rep Read a) => ReadS a
reads = readsPrec minPrec
read :: (Rep Read a) => String -> Maybe a
read = fmap fst . find (null . snd) . reads