home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / gofer230.zip / Progs / Gofer / Demos / Utils / lexer.gs < prev   
Text File  |  1994-06-23  |  7KB  |  210 lines
  1. -- A simple attempt to provide the facilities of the Haskell Text
  2. -- class for reading values.  If you really want to use this, I
  3. -- would suggest combining it with the Text class in a modified
  4. -- version of the prelude.
  5. --
  6. -- Based, not surprisingly, on the definitions in the Haskell report
  7. -- version 1.2:
  8.  
  9. type  ReadS a = String -> [(a,String)]
  10.  
  11. class  Read a  where
  12.     readsPrec :: Int -> ReadS a
  13.     readList  :: ReadS [a]
  14.     readList    = readParen False (\r -> [pr | ("[",s)    <- lex r,
  15.                            pr    <- readl s])
  16.               where readl  s = [([],t)   | ("]",t)  <- lex s] ++
  17.                    [(x:xs,u) | (x,t)    <- reads s,
  18.                            (xs,u)   <- readl' t]
  19.             readl' s = [([],t)   | ("]",t)  <- lex s] ++
  20.                        [(x:xs,v) | (",",t)  <- lex s,
  21.                            (x,u)    <- reads t,
  22.                            (xs,v)   <- readl' u]
  23. instance  Read ()  where
  24.     readsPrec p    = readParen False
  25.                             (\r -> [((),t) | ("(",s) <- lex r,
  26.                          (")",t) <- lex s ] )
  27.  
  28. instance  Read Char  where
  29.     readsPrec p      = readParen False
  30.                             (\r -> [(c,t) | ('\'':s,t)<- lex r,
  31.                         (c,_)     <- readLitChar s])
  32.  
  33.     readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
  34.                            (l,_)      <- readl s ])
  35.            where readl ('"':s)    = [("",s)]
  36.              readl ('\\':'&':s)    = readl s
  37.              readl s        = [(c:cs,u) | (c ,t) <- readLitChar s,
  38.                               (cs,u) <- readl t          ]
  39. instance  Read Int  where
  40.     readsPrec p        = readSigned readDec
  41.  
  42. instance  (Read a) => Read [a]  where
  43.     readsPrec p        = readList
  44.  
  45. instance  (Read a, Read b) => Read (a,b)  where
  46.     readsPrec p = readParen False
  47.                             (\r -> [((x,y), w) | ("(",s) <- lex r,
  48.                          (x,t)   <- reads s,
  49.                          (",",u) <- lex t,
  50.                          (y,v)   <- reads u,
  51.                          (")",w) <- lex v ] )
  52.  
  53. reads             :: (Read a) => ReadS a
  54. reads        =  readsPrec 0
  55.  
  56. read             :: (Read a) => String -> a
  57. read s             =  case [x | (x,t) <- reads s, ("","") <- lex t] of
  58.             [x] -> x
  59.             []  -> error "read{PreludeRead}: no parse"
  60.             _   -> error "read{PreludeRead}: ambiguous parse"
  61.  
  62. readParen       :: Bool -> ReadS a -> ReadS a
  63. readParen b g    =  if b then mandatory else optional
  64.            where optional r  = g r ++ mandatory r
  65.              mandatory r = [(x,u) | ("(",s) <- lex r,
  66.                         (x,t)   <- optional s,
  67.                         (")",u) <- lex t    ]
  68.  
  69. lex                 :: ReadS String
  70. lex ""            = [("","")]
  71. lex (c:s) | isSpace c    = lex (dropWhile isSpace s)
  72. lex ('-':'-':s)        = case dropWhile (/= '\n') s of
  73.                  '\n':t -> lex t
  74.                  _    -> [] -- unterminated end-of-line
  75.                           -- comment
  76.  
  77. lex ('{':'-':s)        = lexNest lex s
  78.               where
  79.               lexNest f ('-':'}':s) = f s
  80.               lexNest f ('{':'-':s) = lexNest (lexNest f) s
  81.               lexNest f (c:s)          = lexNest f s
  82.               lexNest _ ""        = [] -- unterminated
  83.                              -- nested comment
  84.  
  85. lex ('<':'-':s)        = [("<-",s)]
  86. lex ('\'':s)        = [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,
  87.                            ch /= "'"        ]
  88. lex ('"':s)        = [('"':str, t)      | (str,t) <- lexString s]
  89.               where
  90.               lexString ('"':s) = [("\"",s)]
  91.               lexString s = [(ch++str, u)
  92.                         | (ch,t)  <- lexStrItem s,
  93.                           (str,u) <- lexString t  ]
  94.  
  95.               lexStrItem ('\\':'&':s) = [("\\&",s)]
  96.               lexStrItem ('\\':c:s) | isSpace c
  97.                   = [("\\&",t) | '\\':t <- [dropWhile isSpace s]]
  98.               lexStrItem s          = lexLitChar s
  99.  
  100. lex (c:s) | isSingle c    = [([c],s)]
  101.       | isSym1 c    = [(c:sym,t)         | (sym,t) <- [span isSym s]]
  102.       | isAlpha c    = [(c:nam,t)         | (nam,t) <- [span isIdChar s]]
  103.       | isDigit c    = [(c:ds++fe,t)         | (ds,s)  <- [span isDigit s],
  104.                            (fe,t)  <- lexFracExp s       ]
  105.       | otherwise    = []    -- bad character
  106.         where
  107.         isSingle c  =  c `elem` ",;()[]{}_"
  108.         isSym1 c    =  c `elem` "-~" || isSym c
  109.         isSym c        =  c `elem` "!@#$%&*+./<=>?\\^|:"
  110.         isIdChar c  =  isAlphanum c || c `elem` "_'"
  111.  
  112.         lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
  113.                               (e,u)  <- lexExp t    ]
  114.         lexFracExp s       = [("",s)]
  115.  
  116.         lexExp (e:s) | e `elem` "eE"
  117.              = [(e:c:ds,u) | (c:t)    <- [s], c `elem` "+-",
  118.                            (ds,u) <- lexDigits t] ++
  119.                [(e:ds,t)   | (ds,t)    <- lexDigits s]
  120.         lexExp s = [("",s)]
  121.  
  122. lexDigits        :: ReadS String    
  123. lexDigits        =  nonnull isDigit
  124.  
  125. nonnull            :: (Char -> Bool) -> ReadS String
  126. nonnull p s        =  [(cs,t) | (cs@(_:_),t) <- [span p s]]
  127.  
  128. lexLitChar        :: ReadS String
  129. lexLitChar ('\\':s)    =  [('\\':esc, t) | (esc,t) <- lexEsc s]
  130.     where
  131.     lexEsc (c:s)     | c `elem` "abfnrtv\\\"'" = [([c],s)]
  132.     lexEsc ('^':c:s) | c >= '@' && c <= '_'  = [(['^',c],s)]
  133.     lexEsc s@(d:_)     | isDigit d         = lexDigits s
  134.     lexEsc ('o':s)    =  [('o':os, t) | (os,t) <- nonnull isOctDigit s]
  135.     lexEsc ('x':s)    =  [('x':xs, t) | (xs,t) <- nonnull isHexDigit s]
  136.     lexEsc s@(c:_)     | isUpper c
  137.             =  case [(mne,s') | mne <- "DEL" : asciiTab,
  138.                         ([],s') <- [match mne s]      ]
  139.                of (pr:_) -> [pr]
  140.                   []     -> []
  141.     lexEsc _    =  []
  142. lexLitChar (c:s)    =  [([c],s)]
  143. lexLitChar ""        =  []
  144.  
  145. isOctDigit c  =  c >= '0' && c <= '7'
  146. isHexDigit c  =  isDigit c || c >= 'A' && c <= 'F'
  147.                || c >= 'a' && c <= 'f'
  148.  
  149. match            :: (Eq a) => [a] -> [a] -> ([a],[a])
  150. match (x:xs) (y:ys) | x == y  =  match xs ys
  151. match xs     ys              =  (xs,ys)
  152.  
  153. asciiTab = ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
  154.         "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI", 
  155.         "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
  156.         "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US", 
  157.         "SP"] 
  158.  
  159.  
  160.  
  161. readLitChar         :: ReadS Char
  162. readLitChar ('\\':s)    =  readEsc s
  163.     where
  164.     readEsc ('a':s)     = [('\a',s)]
  165.     readEsc ('b':s)     = [('\b',s)]
  166.     readEsc ('f':s)     = [('\f',s)]
  167.     readEsc ('n':s)     = [('\n',s)]
  168.     readEsc ('r':s)     = [('\r',s)]
  169.     readEsc ('t':s)     = [('\t',s)]
  170.     readEsc ('v':s)     = [('\v',s)]
  171.     readEsc ('\\':s) = [('\\',s)]
  172.     readEsc ('"':s)     = [('"',s)]
  173.     readEsc ('\'':s) = [('\'',s)]
  174.     readEsc ('^':c:s) | c >= '@' && c <= '_'
  175.              = [(chr (ord c - ord '@'), s)]
  176.     readEsc s@(d:_) | isDigit d
  177.              = [(chr n, t) | (n,t) <- readDec s]
  178.     readEsc ('o':s)  = [(chr n, t) | (n,t) <- readOct s]
  179.     readEsc ('x':s)     = [(chr n, t) | (n,t) <- readHex s]
  180.     readEsc s@(c:_) | isUpper c
  181.              = let table = ('\DEL',"DEL") : zip ['\NUL'..] asciiTab
  182.                in case [(c,s') | (c,mne) <- table,
  183.                          ([],s') <- [match mne s]]
  184.                   of (pr:_) -> [pr]
  185.                  []    -> []
  186.     readEsc _     = []
  187. readLitChar (c:s)    =  [(c,s)]
  188.  
  189. readDec, readOct, readHex :: ReadS Int
  190. readDec = readInt 10 isDigit (\d -> ord d - ord '0')
  191. readOct = readInt  8 isOctDigit (\d -> ord d - ord '0')
  192. readHex = readInt 16 isHexDigit hex
  193.         where hex d = ord d - (if isDigit d then ord '0'
  194.                    else ord (if isUpper d then 'A' else 'a')
  195.                     - 10)
  196.  
  197. readInt :: Int -> (Char -> Bool) -> (Char -> Int) -> ReadS Int
  198. readInt radix isDig digToInt s =
  199.     [(foldl1 (\n d -> n * radix + d) (map (fromInteger . digToInt) ds), r)
  200.     | (ds,r) <- nonnull isDig s ]
  201.  
  202. readSigned:: ReadS Int -> ReadS Int
  203. readSigned readPos = readParen False read'
  204.              where read' r  = read'' r ++
  205.                       [(-x,t) | ("-",s) <- lex r,
  206.                         (x,t)   <- read'' s]
  207.                read'' r = [(n,s)  | (str,s) <- lex r,
  208.                               (n,"")  <- readPos str]
  209.  
  210.