shithub: MicroHs

Download patch

ref: d4d8306d5bd23fb6555662a7883a2d1a1cdda07c
parent: 977b959064ac1d5d3ceba5ad7a32e29bb46bfc0c
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Mon Feb 5 15:39:30 EST 2024

Even more Read

--- a/lib/Text/Read.hs
+++ b/lib/Text/Read.hs
@@ -83,7 +83,7 @@
                 [ (Left  a, t) | ("Left",  s) <- lex r, (a, t) <- readsPrec 11 s ] ++
                 [ (Right b, t) | ("Right", s) <- lex r, (b, t) <- readsPrec 11 s ]
 
-instance Read () where  
+instance Read () where
   readsPrec p  = readParen False $
                    \ r -> [((),t) | ("(",s) <- lex r,
                                     (")",t) <- lex s ]
@@ -93,3 +93,38 @@
                   \ r -> [((a, b), u) | (a, s)   <- reads r,
                                         (",", t) <- lex s,
                                         (b, u)   <- reads t ]
+
+instance Read Char where
+    readsPrec p = readParen False $
+                    \ r -> [(c,t) | ('\'':s,t)<- lex r,
+                                    (c,"\'")  <- readLitChar s]
+ 
+    readList = readParen False $ \ r -> [(l,t) | ('"':s, t) <- lex r,
+                                                 (l,_)      <- readl s ]
+        where readl ('"':s)      = [("",s)]
+              readl ('\\':'&':s) = readl s
+              readl s            = [(c:cs,u) | (c ,t) <- readLitChar s,
+                                               (cs,u) <- readl t ]
+
+readLitChar :: ReadS Char
+readLitChar ('\\':s) = readEsc s
+readLitChar (c:s)    = [(c, s)]
+
+readEsc :: ReadS Char
+readEsc ('a':s)  = [('\a',s)]
+readEsc ('b':s)  = [('\b',s)]
+readEsc ('f':s)  = [('\f',s)]
+readEsc ('n':s)  = [('\n',s)]
+readEsc ('r':s)  = [('\r',s)]
+readEsc ('t':s)  = [('\t',s)]
+readEsc ('v':s)  = [('\v',s)]
+readEsc ('\\':s) = [('\\',s)]
+readEsc ('"':s)  = [('"',s)]
+readEsc ('\'':s) = [('\'',s)]
+readEsc ('^':c:s) | c >= '@' && c <= '_'
+                 = [(chr (ord c - ord '@'), s)]
+readEsc s@(d:_) | isDigit d
+                 = [(chr n, t) | (n,t) <- readDec s]
+readEsc ('o':s)  = [(chr n, t) | (n,t) <- readOct s]
+readEsc ('x':s)  = [(chr n, t) | (n,t) <- readHex s]
+readEsc _        = []
--- a/lib/Text/Read/Lex.hs
+++ b/lib/Text/Read/Lex.hs
@@ -61,6 +61,8 @@
     lexEsc _                     = []
 
     prefix c (t,s) = (c:t, s)
+lexLitChar (c:cs) = [([c], cs)]
+lexLitChar [] = []
 
 dropSpace :: String -> String
 dropSpace [] = []
--- a/tests/Read.hs
+++ b/tests/Read.hs
@@ -47,3 +47,12 @@
   print (read "Right 123" :: Either Bool Int)
   print (read "()" :: ())
   print (read "(True,123)" :: (Bool, Int))
+  print (read "'a'" :: Char)
+  print (read "'\n'" :: Char)
+  print (read "'\^A'" :: Char)
+  print (read "'\o2'" :: Char)
+  print (read "'\3'" :: Char)
+  print (read "'\x4'" :: Char)
+  print (read "\"abc\"" :: String)
+  print (read "\"a\nc\"" :: String)
+  print (read "\"a\1\&c\"" :: String)
--- a/tests/Read.ref
+++ b/tests/Read.ref
@@ -37,3 +37,12 @@
 Right 123
 ()
 (True,123)
+'a'
+'\n'
+'\1'
+'\2'
+'\3'
+'\4'
+"abc"
+"a\nc"
+"a\1c"
--