module Generics.EMGM.Functions.Read (
Read(..),
readPrec,
readP,
readsPrec,
reads,
read,
) where
import Prelude hiding (Read, read, reads, readsPrec)
import qualified Prelude as P (Read)
import Data.List (find)
import Control.Monad
import Debug.Trace
import Text.ParserCombinators.ReadPrec (ReadPrec, step, (+++), pfail, lift,
look, 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.Common
newtype Read a = Read { selRead :: ConType -> ReadPrec a }
ltrace :: String -> ReadPrec ()
ltrace =
let debug = False
in if debug
then \s -> do la <- look
(trace $ "<<" ++ la ++ ">> " ++ s) $ return ()
else const $ do return ()
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 ltraceme "{ before"
Punc "{" <- lexP
ltraceme "{ after"
x <- reset p
ltraceme "} before"
Punc "}" <- lexP
ltraceme "} after"
return x
where ltraceme s = ltrace $ "braces: " ++ s
lexT :: String -> ReadPrec ()
lexT expected =
do found <- lift hsLex
if found == expected
then do ltraceme "success"
return ()
else do ltraceme $ "fnd=" ++ found ++ " FAIL"
pfail
where ltraceme s = ltrace $ "lexT: exp=" ++ expected ++ " -> " ++ s
recEntry :: Bool -> String -> ReadPrec a -> ReadPrec a
recEntry isComma label p =
do lexT label
ltraceme "before ="
equals
ltraceme "after ="
x <- p
ltraceme "after p"
if isComma
then do ltraceme "before ,"
comma
return x
else do ltraceme "no ,"
return x
where ltraceme s =
ltrace $ "recEntry: com=" ++ show isComma ++
" lbl=" ++ label ++ " " ++ s
rconstantRead :: (P.Read a) => ConType -> ReadPrec a
rconstantRead ct =
case ct of
ConStd ->
do ltraceme "ConStd"
TR.readPrec
ConRec (label:[]) ->
do ltraceme "ConRec1"
recEntry False label TR.readPrec
_ ->
do ltraceme "FAIL"
pfail
where ltraceme s = ltrace $ "rconstantRead: " ++ s
rsumRead :: Read a -> Read b -> ConType -> ReadPrec (a :+: b)
rsumRead ra rb _ =
do ltrace "rsumRead:"
(return . L =<< selRead ra ConStd) +++ (return . R =<< selRead rb ConStd)
rprodRead :: Read a -> Read b -> ConType -> ReadPrec (a :*: b)
rprodRead ra rb ct =
case ct of
ConStd ->
do ltraceme "ConStd (a)"
a <- step (selRead ra ConStd)
ltraceme "ConStd (b)"
b <- step (selRead rb ConStd)
return (a :*: b)
ConIfx symbol ->
do ltraceme "ConIfx (a)"
a <- step (selRead ra ConStd)
lexT symbol
ltraceme "ConIfx (b)"
b <- step (selRead rb ConStd)
return (a :*: b)
ConRec (label:labels) ->
do ltraceme "ConRec2 (a)"
a <- step (recEntry True label (selRead ra ConStd))
ltraceme "ConRec2 (b)"
b <- step $ selRead rb (ConRec (labels))
return (a :*: b)
_ ->
do ltraceme "FAIL"
pfail
where
ltraceme s = ltrace $ "rprodRead: " ++ show ct ++ " " ++ s
rconRead :: ConDescr -> Read a -> ConType -> ReadPrec a
rconRead cd ra _ =
parens $
case cd of
ConDescr name _ [] Nonfix ->
do ltraceme "ConStd"
lexT name
step $ selRead ra ConStd
ConDescr name _ [] fixity ->
do ltraceme "ConIfx"
let p = prec fixity
RP.prec p $ step $ selRead ra $ ConIfx name
ConDescr name _ labels Nonfix ->
do ltraceme "ConRec (a)"
lexT name
braces $ step $ selRead ra $ ConRec labels
ConDescr name _ labels _ ->
do ltraceme "ConRec (b)"
paren (lexT name)
braces $ step $ selRead ra $ ConRec labels
where ltraceme s = ltrace $ "rconRead: " ++ show cd ++ " " ++ s
rtypeRead :: EP d a -> Read a -> ConType -> ReadPrec d
rtypeRead ep ra ct =
case ct of
ConStd ->
do ltraceme "ConStd"
fmap (to ep) $ selRead ra ConStd
ConRec (label:[]) ->
do ltraceme "ConRec"
fmap (to ep) $ recEntry False label (selRead ra ConStd)
_ ->
do ltraceme "FAIL"
pfail
where
ltraceme s = ltrace $ "rtypeRead: " ++ show ct ++ " " ++ s
instance Generic Read where
rconstant = Read rconstantRead
rsum ra rb = Read (rsumRead ra rb)
rprod ra rb = Read (rprodRead ra rb)
rcon cd ra = Read (rconRead cd 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 ConStd
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