hmp3-1.4: Lexers.hs
-- Compiler Toolkit: Self-optimizing lexers
--
-- Author : Manuel M. T. Chakravarty
-- Created: 24 February 95, 2 March 99
--
-- Version $Revision: 1.1 $ from $Date: 2002/07/28 03:35:20 $
--
-- Copyright (c) [1995..2000] Manuel M. T. Chakravarty
-- Copyright (c) 2004-2008 Don Stewart
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Library General Public
-- License as published by the Free Software Foundation; either
-- version 2 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Library General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
-- Self-optimizing lexer combinators.
--
-- For detailed information, see ``Lazy Lexing is Fast'', Manuel
-- M. T. Chakravarty, in A. Middeldorp and T. Sato, editors, Proceedings of
-- Fourth Fuji International Symposium on Functional and Logic Programming,
-- Springer-Verlag, LNCS 1722, 1999. (See my Web page for details.)
--
-- http://www.cse.unsw.edu.au/~chak/papers/Cha99.html
--
-- Thanks to Simon L. Peyton Jones <simonpj@microsoft.com> and Roman
-- Lechtchinsky <wolfro@cs.tu-berlin.de> for their helpful suggestions that
-- improved the design of this library.
--
--- DOCU ----------------------------------------------------------------------
--
-- language: Haskell 98
--
-- The idea is to combine the benefits of off-line generators with
-- combinators like in `Parsers.hs' (which builds on Swierstra/Duponcheel's
-- technique for self-optimizing parser combinators). In essence, a state
-- transition graph representing a lexer table is computed on the fly, to
-- make lexing deterministic and based on cheap table lookups.
--
-- Regular expression map to Haskell expressions as follows. If `x' and `y'
-- are regular expressions,
--
-- -> epsilon
-- xy -> x +> y
-- x*y -> x `star` y
-- x+y -> x `plus` y
-- x?y -> x `quest` y
--
-- Given such a Haskelized regular expression `hre', we can use
--
-- (1) hre `lexaction` \lexeme -> Nothing
-- (2) hre `lexaction` \lexeme -> Just token
-- (3) hre `lexmeta` \lexeme pos s -> (res, pos', s', Nothing)
-- (4) hre `lexmeta` \lexeme pos s -> (res, pos', s', Just l)
--
-- where `epsilon' is required at the end of `hre' if it otherwise ends on
-- `star', `plus', or `quest', and then, we have
--
-- (1) discards `lexeme' accepted by `hre',
-- (2) turns the `lexeme' accepted by `hre' into a token,
-- (3) while discarding the lexeme accepted by `hre', transforms the
-- position and/or user state, and
-- (4) while discarding the lexeme accepted by `hre', transforms the
-- position and/or user state and returns a lexer to be used for the
-- next lexeme.
--
-- The component `res' in case of a meta action, can be `Nothing', `Just
-- (Left err)', or `Just (Right token)' to return nothing, an error, or a
-- token from a meta action, respectively.
--
-- * This module makes essential use of graphical data structures (for
-- representing the state transition graph) and laziness (for maintaining
-- the last action in `execLexer'.
--
-- NOTES:
--
-- * In this implementation, the combinators `quest`, `star`, and `plus` are
-- *right* associative - this was different in the ``Lazy Lexing is Fast''
-- paper. This change was made on a suggestion by Martin Norbäck
-- <d95mback@dtek.chalmers.se>.
--
--- TODO ----------------------------------------------------------------------
--
-- * error correction is missing
--
-- * in (>||<) in the last case, `(addBoundsNum bn bn')' is too simple, as
-- the number of outgoing edges is not the sum of the numbers of the
-- individual states when there are conflicting edges, ie, ones labeled
-- with the same character; however, the number is only used to decide a
-- heuristic, so it is questionable whether it is worth spending the
-- additional effort of computing the accurate number
--
-- * Unicode posses a problem as the character domain becomes too big for
-- using arrays to represent transition tables and even sparse structures
-- will posse a significant overhead when character ranges are naively
-- represented. So, it might be time for finite maps again.
--
-- Regarding the character ranges, there seem to be at least two
-- possibilities. Doaitse explicitly uses ranges and avoids expanding
-- them. The problem with this approach is that we may only have
-- predicates such as `isAlphaNum' to determine whether a givne character
-- belongs to some character class. From this representation it is
-- difficult to efficiently compute a range. The second approach, as
-- proposed by Tom Pledger <Tom.Pledger@peace.com> (on the Haskell list)
-- would be to actually use predicates directly and make the whole business
-- efficient by caching predicate queries. In other words, for any given
-- character after we have determined (in a given state) once what the
-- following state on accepting that character is, we need not consult the
-- predicates again if we memorise the successor state the first time
-- around.
--
module Lexers (
Regexp, Lexer, Action, Meta, Error,
epsilon, char, (+>),
lexaction, lexactionErr, lexmeta, action, meta,
(>|<), (>||<),
star, plus, quest, alt, string, with, LexerState, execLexer
) where
import Prelude hiding (last)
import Data.Maybe (fromMaybe)
import Data.Array (Array, (!), assocs, accumArray)
infixr 4 `quest`, `star`, `plus`
infixl 3 +>, `lexaction`, `lexmeta`, `action`, `meta`
infixl 2 >|<, >||<
-- constants
-- ---------
-- we use the dense representation if a table has at least the given number of
-- (non-error) elements
--
denseMin :: Int
denseMin = 20
-- data structures
-- ---------------
-- represents the number of (non-error) elements and the bounds of a table
--
type BoundsNum = (Int, Char, Char)
-- empty bounds
--
-- nullBoundsNum :: BoundsNum
-- nullBoundsNum = (0, maxBound, minBound)
-- combine two bounds
--
addBoundsNum :: BoundsNum -> BoundsNum -> BoundsNum
addBoundsNum (n, lc, hc) (n', lc', hc') = (n + n', min lc lc', max hc hc')
-- check whether a character is in the bounds
--
inBounds :: Char -> BoundsNum -> Bool
inBounds c (_, lc, hc) = c >= lc && c <= hc
-- Lexer errors
type Error = String
-- Lexical actions take a lexeme with its position and may return a token; in
-- a variant, an error can be returned (EXPORTED)
--
-- * if there is no token returned, the current lexeme is discarded lexing
-- continues looking for a token
--
type Action t = String -> Maybe t
type ActionErr t = String -> Either Error t
-- Meta actions transform the lexeme, and a user-defined state; they
-- may return a lexer, which is then used for accepting the next token
-- (this is important to implement non-regular behaviour like nested
-- comments) (EXPORTED)
--
type Meta s t = String -> s -> (Maybe (Either Error t), -- err/tok?
s, -- state
Maybe (Lexer s t)) -- lexer?
-- tree structure used to represent the lexer table (EXPORTED ABSTRACTLY)
--
-- * each node in the tree corresponds to a state of the lexer; the associated
-- actions are those that apply when the corresponding state is reached
--
data Lexer s t = Lexer (LexAction s t) (Cont s t)
-- represent the continuation of a lexer
--
data Cont s t = -- on top of the tree, where entries are dense, we use arrays
--
Dense BoundsNum (Array Char (Lexer s t))
--
-- further down, where the valid entries are sparse, we
-- use association lists, to save memory (the first argument
-- is the length of the list)
--
| Sparse BoundsNum [(Char, Lexer s t)]
--
-- end of a automaton
--
| Done
-- lexical action (EXPORTED ABSTRACTLY)
--
data LexAction s t = Action (Meta s t)
| NoAction
-- a regular expression (EXPORTED)
--
type Regexp s t = Lexer s t -> Lexer s t
-- basic combinators
-- -----------------
-- Empty lexeme (EXPORTED)
--
epsilon :: Regexp s t
epsilon = id
-- One character regexp (EXPORTED)
--
char :: Char -> Regexp s t
char c = \l -> Lexer NoAction (Sparse (1, c, c) [(c, l)])
-- Concatenation of regexps (EXPORTED)
--
(+>) :: Regexp s t -> Regexp s t -> Regexp s t
(+>) = (.)
-- Close a regular expression with an action that converts the lexeme into a
-- token (EXPORTED)
--
-- * Note: After the application of the action, the position is advanced
-- according to the length of the lexeme. This implies that normal
-- actions should not be used in the case where a lexeme might contain
-- control characters that imply non-standard changes of the position,
-- such as newlines or tabs.
--
action :: Regexp s t -> Action t -> Lexer s t
action = lexaction
lexaction :: Regexp s t -> Action t -> Lexer s t
lexaction re a = re `lexmeta` a'
where
a' lexeme s =
case a lexeme of
Nothing -> (Nothing, s, Nothing)
Just t -> (Just (Right t), s, Nothing)
-- Variant for actions that may returns an error (EXPORTED)
--
lexactionErr :: Regexp s t -> ActionErr t -> Lexer s t
lexactionErr re a = re `lexmeta` a'
where
a' lexeme s = (Just (a lexeme), s, Nothing)
-- Close a regular expression with a meta action (EXPORTED)
--
-- * Note: Meta actions have to advance the position in dependence of the
-- lexeme by themselves.
--
meta :: Regexp s t -> Meta s t -> Lexer s t
meta = lexmeta
lexmeta :: Regexp s t -> Meta s t -> Lexer s t
lexmeta re a = re (Lexer (Action a) Done)
-- useful for building meta actions
with :: b -> Maybe (Either a b)
with a = Just (Right a)
-- disjunctive combination of two regexps (EXPORTED)
--
(>|<) :: Regexp s t -> Regexp s t -> Regexp s t
re >|< re' = \l -> re l >||< re' l
-- disjunctive combination of two lexers (EXPORTED)
--
(>||<) :: Lexer s t -> Lexer s t -> Lexer s t
(Lexer a c) >||< (Lexer a' c') = Lexer (joinActions a a') (joinConts c c')
-- combine two disjunctive continuations
--
joinConts :: Cont s t -> Cont s t -> Cont s t
joinConts Done c' = c'
joinConts c Done = c
joinConts c c' = let (bn , cls ) = listify c
(bn', cls') = listify c'
in
-- note: `addsBoundsNum' can, at this point, only
-- approx. the number of *non-overlapping* cases;
-- however, the bounds are correct
--
aggregate (addBoundsNum bn bn') (cls ++ cls')
where
listify (Dense n arr) = (n, assocs arr)
listify (Sparse n cls) = (n, cls)
listify _ = error "Lexers.listify: Impossible argument!"
-- combine two actions. Use the latter in case of overlap (!)
--
joinActions :: LexAction s t -> LexAction s t -> LexAction s t
joinActions NoAction a' = a'
joinActions a NoAction = a
joinActions _ a' = a' -- error "Lexers.>||<: Overlapping actions!"
-- Note: `n' is only an upper bound of the number of non-overlapping cases
--
aggregate :: BoundsNum -> ([(Char, Lexer s t)]) -> Cont s t
aggregate bn@(n, lc, hc) cls
| n >= denseMin = Dense bn (accumArray (>||<) noLexer (lc, hc) cls)
| otherwise = Sparse bn (accum (>||<) cls)
where
noLexer = Lexer NoAction Done
-- combine the elements in the association list that have the same key
--
accum :: Eq a => (b -> b -> b) -> [(a, b)] -> [(a, b)]
accum _ [] = []
accum f ((c, el):ces) =
let (ce, ces') = gather c el ces
in ce : accum f ces'
where
gather k e [] = ((k, e), [])
gather k e (ke'@(k', e'):kes) | k == k' = gather k (f e e') kes
| otherwise = let
(ke'', kes') = gather k e kes
in
(ke'', ke':kes')
-- non-basic combinators
-- ---------------------
-- x `star` y corresponds to the regular expression x*y (EXPORTED)
--
star :: Regexp s t -> Regexp s t -> Regexp s t
--
-- The definition used below can be obtained by equational reasoning from this
-- one (which is much easier to understand):
--
-- star re1 re2 = let self = (re1 +> self >|< epsilon) in self +> re2
--
-- However, in the above, `self' is of type `Regexp s t' (ie, a functional),
-- whereas below it is of type `Lexer s t'. Thus, below we have a graphical
-- body (finite representation of an infinite structure), which doesn't grow
-- with the size of the accepted lexeme - in contrast to the definition using
-- the functional recursion.
--
star re1 re2 = \l -> let self = re1 self >||< re2 l
in
self
-- x `plus` y corresponds to the regular expression x+y (EXPORTED)
--
plus :: Regexp s t -> Regexp s t -> Regexp s t
plus re1 re2 = re1 +> (re1 `star` re2)
-- x `quest` y corresponds to the regular expression x?y (EXPORTED)
--
quest :: Regexp s t -> Regexp s t -> Regexp s t
quest re1 re2 = (re1 +> re2) >|< re2
-- accepts a non-empty set of alternative characters (EXPORTED)
--
alt :: [Char] -> Regexp s t
--
-- Equiv. to `(foldr1 (>|<) . map char) cs', but much faster
--
alt [] = error "Lexers.alt: Empty character set!"
alt cs = \l -> let bnds = (length cs, minimum cs, maximum cs)
in
Lexer NoAction (aggregate bnds [(c, l) | c <- cs])
-- accept a character sequence (EXPORTED)
--
string :: String -> Regexp s t
string [] = error "Lexers.string: Empty character set!"
string cs = (foldr1 (+>) . map char) cs
-- execution of a lexer
-- --------------------
-- threaded top-down during lexing (current input, meta state) (EXPORTED)
--
type LexerState s = (String, s)
-- apply a lexer, yielding a token sequence and a list of errors (EXPORTED)
--
-- * Currently, all errors are fatal; thus, the result is undefined in case of
-- an error (this changes when error correction is added).
--
-- * The final lexer state is returned.
--
-- * The order of the error messages is undefined.
--
execLexer :: Lexer s t -> LexerState s -> ([t], LexerState s, [Error])
--
-- * the following is moderately tuned
--
execLexer _ st@([], _) = ([], st, [])
execLexer l st =
case lexOne l st of
(Nothing , _ , st') -> execLexer l st'
(Just res, l', st') -> let (ts, final, allErrs) = execLexer l' st'
in case res of
(Left err) -> (ts , final, err:allErrs)
(Right t ) -> (t:ts, final, allErrs)
where
-- accept a single lexeme
--
-- lexOne :: Lexer s t -> LexerState s t
-- -> (Either Error (Maybe t), Lexer s t, LexerState s t)
lexOne l0 st' = oneLexeme l0 st' zeroDL lexErr
where
-- the result triple of `lexOne' that signals a lexical error;
-- the result state is advanced by one character for error correction
--
lexErr = let (cs, s) = st'
err = "Lexical error!\n" ++
"The character " ++ show (head cs)
++ " does not fit here; skipping it."
in
(Just (Left err), l, (tail cs, s))
--
-- we take an open list of characters down, where we accumulate the
-- lexeme; this function returns maybe a token, the next lexer to use
-- (can be altered by a meta action), the new lexer state, and a list
-- of errors
--
-- we implement the "principle of the longest match" by taking a
-- potential result quadruple down (in the last argument); the
-- potential result quadruple is updated whenever we pass by an action
-- (different from `NoAction'); initially it is an error result
--
-- (dons): from the paper "we have to take the last possible
-- action before the automaton gets stuck. .. when no further
-- transition is possible, we execute the last action on the
-- associated lexeme." This means that even once all possible
-- actions have been looked at, we currently then wait till the
-- _next_ char, before returning the last action we're carrying
-- around. For interactive use, we instead need to execute the
-- last action once we encounter it, not once we've gone past
-- it. Hmm...
--
-- oneLexeme :: Lexer s t
-- -> LexerState
-- -> DList Char
-- -> (Maybe (Either Error t), Maybe (Lexer s t),
-- LexerState s t)
-- -> (Maybe (Either Error t), Maybe (Lexer s t),
-- LexerState s t)
--
oneLexeme (Lexer a cont) state@(cs, s) csDL last =
let last' = doaction a csDL state last
in case cs of
[] -> last' -- at end, has to be this action
(c:cs') -> oneChar cont c (cs', s) csDL last' -- keep looking
--
-- There are more chars. Look at the next one
--
-- Now, if the next tbl is Done, then there is no more
-- transition, so immediately execute our action
--
oneChar tbl c state csDL last =
case peek tbl c of
Nothing -> last
Just (Lexer a Done) -> doaction a (csDL `snocDL` c) state last
Just l' -> continue l' c state csDL last
--
-- Do the lookup.
--
peek Done _ = Nothing
peek (Dense bn arr) c | c `inBounds` bn = Just $ arr ! c
peek (Sparse bn cls) c | c `inBounds` bn = lookup c cls
peek _ _ = Nothing
--
-- continue within the current lexeme
--
continue l' c state csDL last =
oneLexeme l' state (csDL `snocDL` c) last
--
-- execute the action if present and finalise the current lexeme
--
doaction (Action f) csDL (cs, s) _last =
case f (closeDL csDL) s of
(Nothing, s', l')
| not . null $ cs -> lexOne (fromMaybe l0 l') (cs, s')
(res, s', l') -> (res, (fromMaybe l0 l'), (cs, s'))
doaction NoAction _csDL _state last = last -- no change
------------------------------------------------------------------------
--
-- This module provides the functional equivalent of the difference lists
-- from logic programming. They provide an O(1) append.
--
-- | a difference list is a function that given a list returns the original
-- contents of the difference list prepended at the given list (EXPORTED)
type DList a = [a] -> [a]
-- | open a list for use as a difference list (EXPORTED)
{-
openDL :: [a] -> DList a
openDL = (++)
-}
-- | create a difference list containing no elements (EXPORTED)
zeroDL :: DList a
zeroDL = id
-- | create difference list with given single element (EXPORTED)
{-
unitDL :: a -> DList a
unitDL = (:)
-}
-- | append a single element at a difference list (EXPORTED)
snocDL :: DList a -> a -> DList a
snocDL dl x = \l -> dl (x:l)
-- | appending difference lists (EXPORTED)
{-
joinDL :: DList a -> DList a -> DList a
joinDL = (.)
-}
-- | closing a difference list into a normal list (EXPORTED)
closeDL :: DList a -> [a]
closeDL = ($[])