diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright (c) 2016 The Inchworm Development Team + + Permission is hereby granted, free of charge, to any person + obtaining a copy of this software and associated documentation + files (the "Software"), to deal in the Software without + restriction, including without limitation the rights to use, + copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the + Software is furnished to do so, subject to the following + condition: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/Lexer/Inchworm.hs b/Text/Lexer/Inchworm.hs new file mode 100644 --- /dev/null +++ b/Text/Lexer/Inchworm.hs @@ -0,0 +1,123 @@ + +-- | Parser combinator framework specialized to lexical analysis. +-- Tokens can be specified via simple fold functions, +-- and we include baked in source location handling. +-- +-- If you want to parse expressions instead of performing lexical +-- analysis then try the @parsec@ or @attoparsec@ packages, which +-- have more general purpose combinators. +-- +-- Matchers for standard tokens like comments and strings +-- are in the "Text.Lexer.Inchworm.Char" module. +-- +-- No dependencies other than the Haskell 'base' library. +-- +-- __ Minimal example __ +-- +-- The following code demonstrates how to perform lexical analysis +-- of a simple LISP-like language. We use two separate name classes, +-- one for variables that start with a lower-case letter, +-- and one for constructors that start with an upper case letter. +-- +-- Integers are scanned using the `scanInteger` function from the +-- "Text.Lexer.Inchworm.Char" module. +-- +-- The result of @scanStringIO@ contains the list of leftover input +-- characters that could not be parsed. In a real lexer you should +-- check that this is empty to ensure there has not been a lexical +-- error. +-- +-- @ +-- import Text.Lexer.Inchworm.Char +-- import qualified Data.Char as Char +-- +-- -- | A source token. +-- data Token +-- = KBra | KKet | KVar String | KCon String | KInt Integer +-- deriving Show +-- +-- -- | A thing with attached location information. +-- data Located a +-- = Located FilePath Location a +-- deriving Show +-- +-- -- | Scanner for a lispy language. +-- scanner :: FilePath +-- -> Scanner IO Location [Char] (Located Token) +-- scanner fileName +-- = skip Char.isSpace +-- $ alts [ fmap (stamp id) $ accept '(' KBra +-- , fmap (stamp id) $ accept ')' KKet +-- , fmap (stamp KInt) $ scanInteger +-- , fmap (stamp KVar) +-- $ munchWord (\\ix c -> if ix == 0 then Char.isLower c +-- else Char.isAlpha c) +-- , fmap (stamp KCon) +-- $ munchWord (\\ix c -> if ix == 0 then Char.isUpper c +-- else Char.isAlpha c) +-- ] +-- where -- Stamp a token with source location information. +-- stamp k (l, t) +-- = Located fileName l (k t) +-- +-- main +-- = do let fileName = "Source.lispy" +-- let source = "(some (Lispy like) 26 Program 93 (for you))" +-- toks <- scanStringIO source (scanner fileName) +-- print toks +-- @ +-- +module Text.Lexer.Inchworm + ( -- * Basic Types + Source + , Scanner + + -- * Generic Scanning + , scanListIO + + -- ** Source Construction + , makeListSourceIO + + -- ** Scanner Evaluation + , scanSourceToList + + -- * Combinators + + -- ** Basic + , satisfies, skip + + -- ** Accept + , accept, accepts + + -- ** From + , from, froms + + -- ** Alternation + , alt, alts + + -- ** Munching + , munchPred, munchWord, munchFold) +where +import Text.Lexer.Inchworm.Source +import Text.Lexer.Inchworm.Scanner +import Text.Lexer.Inchworm.Combinator + + +-- | Scan a list of generic input tokens in the IO monad, +-- returning the source location of the final input token, +-- along with the remaining input. +-- +-- NOTE: If you just want to scan a `String` of characters +-- use @scanStringIO@ from "Text.Lexer.Inchworm.Char" +-- +scanListIO + :: Eq i + => loc -- ^ Starting source location. + -> (i -> loc -> loc) -- ^ Function to bump the current location by one input token. + -> [i] -- ^ List of input tokens. + -> Scanner IO loc [i] a -- ^ Scanner to apply. + -> IO ([a], loc, [i]) + +scanListIO loc bump input scanner + = do src <- makeListSourceIO loc bump input + scanSourceToList src scanner diff --git a/Text/Lexer/Inchworm/Char.hs b/Text/Lexer/Inchworm/Char.hs new file mode 100644 --- /dev/null +++ b/Text/Lexer/Inchworm/Char.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE BangPatterns #-} +-- | Character based scanners. +module Text.Lexer.Inchworm.Char + ( module Text.Lexer.Inchworm + + -- * Driver + , scanStringIO + + -- * Locations + , Location (..) + , bumpLocationWithChar + + -- * Scanners + , scanInteger + , scanHaskellChar + , scanHaskellString + , scanHaskellCommentBlock + , scanHaskellCommentLine) +where +import Text.Lexer.Inchworm +import Text.Lexer.Inchworm.Source +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Numeric as Numeric + + +-- Driver --------------------------------------------------------------------- +-- | Scan a string in the IO monad. +scanStringIO + :: String + -> Scanner IO Location String a + -> IO ([a], Location, String) + +scanStringIO str scanner + = scanListIO + (Location 1 1) + bumpLocationWithChar + str scanner + + +-- Locations ------------------------------------------------------------------ +-- | Bump a location using the given character, +-- updating the line and column number as appropriate. +-- +bumpLocationWithChar :: Char -> Location -> Location +bumpLocationWithChar c (Location line col) + = case c of + '\n' -> Location (line + 1) 1 + _ -> Location line (col + 1) + + +-- Integers ------------------------------------------------------------------- +-- | Scan a decimal integer, with optional @-@ and @+@ sign specifiers. +scanInteger + :: Monad m + => Scanner m loc [Char] (loc, Integer) + +scanInteger + = munchPred Nothing matchInt acceptInt + where + matchInt 0 !c + = c == '-' || c == '+' || Char.isDigit c + + matchInt _ !c = Char.isDigit c + + acceptInt ('+' : cs) + | null cs = Nothing + + acceptInt ('-' : cs) + | null cs = Nothing + + acceptInt cs = Just $ read cs + +{-# SPECIALIZE INLINE + scanInteger + :: Scanner IO Location [Char] (Location, Integer) + #-} + +-- Strings -------------------------------------------------------------------- +-- | Scan a literal string, enclosed in double quotes. +-- +-- We handle the escape codes listed in Section 2.6 of the Haskell Report, +-- but not string gaps or the @&@ terminator. +-- +scanHaskellString + :: Monad m + => Scanner m loc [Char] (loc, String) + +scanHaskellString + = munchFold Nothing matchC (' ', True) acceptC + where + matchC 0 '\"' _ = Just ('\"', True) + matchC _ _ (_, False) = Nothing + + matchC ix c (cPrev, True) + | ix < 1 = Nothing + | c == '"' && cPrev == '\\' = Just ('"', True) + | c == '"' = Just (c, False) + | otherwise = Just (c, True) + + acceptC ('"' : cs) + = case decodeString cs of + (str, ('"' : [])) -> Just str + _ -> Nothing + + acceptC _ = Nothing + +{-# SPECIALIZE INLINE + scanHaskellString + :: Scanner IO Location [Char] (Location, String) + #-} + + +-- Characters ----------------------------------------------------------------- +-- | Scan a literal character, enclosed in single quotes. +-- +-- We handle the escape codes listed in Section 2.6 of the Haskell Report. +-- +scanHaskellChar + :: Monad m + => Scanner m loc [Char] (loc, Char) + +scanHaskellChar + = munchFold Nothing matchC (' ', True) acceptC + where + matchC 0 '\'' _ = Just ('\'', True) + matchC _ _ (_, False) = Nothing + + matchC ix c (cPrev, True) + | ix < 1 = Nothing + | c == '\'' && cPrev == '\\' = Just ('\'', True) + | c == '\'' = Just (c, False) + | otherwise = Just (c, True) + + acceptC ('\'' : cs) + = case readChar cs of + Just (c, "\'") -> Just c + _ -> Nothing + + acceptC _ = Nothing + +{-# SPECIALIZE INLINE + scanHaskellChar + :: Scanner IO Location [Char] (Location, Char) + #-} + + +-- Comments ------------------------------------------------------------------- +-- | Scan a Haskell block comment. +scanHaskellCommentBlock + :: Monad m + => Scanner m loc [Char] (loc, String) + +scanHaskellCommentBlock + = munchFold Nothing matchC (' ', True) acceptC + where + matchC 0 '{' _ = Just ('{', True) + matchC 1 '-' ('{', True) = Just ('-', True) + + matchC _ _ (_, False) = Nothing + + matchC ix c (cPrev, True) + | ix < 2 = Nothing + | cPrev == '-' && c == '}' = Just ('}', False) + | otherwise = Just (c, True) + + acceptC cc@('{' : '-' : _) = Just cc + acceptC _ = Nothing + +{-# SPECIALIZE INLINE + scanHaskellCommentBlock + :: Scanner IO Location [Char] (Location, String) + #-} + + +-- | Scan a Haskell line comment. +scanHaskellCommentLine + :: Monad m + => Scanner m loc [Char] (loc, String) + +scanHaskellCommentLine + = munchPred Nothing matchC acceptC + where + matchC 0 '-' = True + matchC 1 '-' = True + matchC _ '\n' = False + matchC ix _ + | ix < 2 = False + | otherwise = True + + acceptC cs = Just cs + +{-# SPECIALIZE INLINE + scanHaskellCommentLine + :: Scanner IO Location [Char] (Location, String) + #-} + + +------------------------------------------------------------------------------- +-- | Decode escape codes in a string. +decodeString :: String -> (String, String) +decodeString ss0 + = go [] ss0 + where + go !acc [] + = (reverse acc, []) + + go !acc ss@('\"' : _) + = (reverse acc, ss) + + go !acc ss@(c : cs) + = case readChar ss of + Just (c', cs') -> go (c' : acc) cs' + Nothing -> go (c : acc) cs + + +-- | Read a character literal, handling escape codes. +readChar :: String -> Maybe (Char, String) + +-- Control characters defined by hex escape codes. +readChar ('\\' : 'x' : cs) + | [(x, rest)] <- Numeric.readHex cs = Just (Char.chr x, rest) + | otherwise = Nothing + +-- Control characters defined by octal escape codes. +readChar ('\\' : 'o' : cs) + | [(x, rest)] <- Numeric.readOct cs = Just (Char.chr x, rest) + | otherwise = Nothing + +-- Control characters defined by carret characters, like \^G +readChar ('\\' : '^' : c : rest) + | c >= 'A' && c <= 'Z' = Just (Char.chr (Char.ord c - 1), rest) + | c == '@' = Just (Char.chr 0, rest) + | c == '[' = Just (Char.chr 27, rest) + | c == '\\' = Just (Char.chr 28, rest) + | c == ']' = Just (Char.chr 29, rest) + | c == '^' = Just (Char.chr 30, rest) + | c == '_' = Just (Char.chr 31, rest) + +-- Control characters defined by decimal escape codes. +readChar ('\\' : cs) + | (csDigits, csRest) <- List.span Char.isDigit cs + , not $ null csDigits + = Just (Char.chr (read csDigits), csRest) + +-- Control characters defined by ASCII escape codes. +readChar ('\\' : cs) + = let go [] = Nothing + go ((str, c) : moar) + = case List.stripPrefix str cs of + Nothing -> go moar + Just rest -> Just (c, rest) + + in go escapedChars + +-- Just a regular character. +readChar (c : rest) = Just (c, rest) + +-- Nothing to read. +readChar _ = Nothing + +escapedChars :: [(String, Char)] +escapedChars + = [ ("a", '\a'), ("b", '\b'), ("f", '\f'), ("n", '\n') + , ("r", '\r'), ("t", '\t'), ("v", '\v'), ("\\", '\\') + , ("\"", '\"'), ("\'", '\'') + , ("NUL", '\NUL'), ("SOH", '\SOH'), ("STX", '\STX'), ("ETX", '\ETX') + , ("EOT", '\EOT'), ("ENQ", '\ENQ'), ("ACK", '\ACK'), ("BEL", '\BEL') + , ("BS", '\BS'), ("HT", '\HT'), ("LF", '\LF'), ("VT", '\VT') + , ("FF", '\FF'), ("CR", '\CR'), ("SO", '\SO'), ("SI", '\SI') + , ("DLE", '\DLE'), ("DC1", '\DC1'), ("DC2", '\DC2'), ("DC3", '\DC3') + , ("DC4", '\DC4'), ("NAK", '\NAK'), ("SYN", '\SYN'), ("ETB", '\ETB') + , ("CAN", '\CAN'), ("EM", '\EM'), ("SUB", '\SUB'), ("ESC", '\ESC') + , ("FS", '\FS'), ("GS", '\GS'), ("RS", '\RS'), ("US", '\US') + , ("SP", '\SP'), ("DEL", '\DEL')] + diff --git a/Text/Lexer/Inchworm/Combinator.hs b/Text/Lexer/Inchworm/Combinator.hs new file mode 100644 --- /dev/null +++ b/Text/Lexer/Inchworm/Combinator.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE FlexibleContexts #-} +module Text.Lexer.Inchworm.Combinator + ( satisfies, skip + , accept, accepts + , from, froms + , alt, alts + , munchPred, munchWord, munchFold) +where +import Text.Lexer.Inchworm.Source +import Text.Lexer.Inchworm.Scanner +import Prelude hiding (length) + + +------------------------------------------------------------------------------- +-- | Accept the next token if it matches the given predicate, +-- returning that token as the result. +satisfies + :: Monad m + => (Elem input -> Bool) + -> Scanner m loc input (loc, Elem input) + +satisfies fPred + = Scanner $ \ss + -> sourcePull ss fPred +{-# INLINE satisfies #-} + + +------------------------------------------------------------------------------- +-- | Skip tokens that match the given predicate, +-- before applying the given argument scanner. +-- +-- When lexing most source languages you can use this to skip whitespace. +-- +skip :: Monad m + => (Elem input -> Bool) -> Scanner m loc input a + -> Scanner m loc input a +skip fPred (Scanner scan1) + = Scanner $ \ss + -> do sourceSkip ss fPred + scan1 ss +{-# INLINE skip #-} + + +------------------------------------------------------------------------------- +-- | Accept the next input token if it is equal to the given one, +-- and return a result of type @a@. +accept :: (Monad m, Eq (Elem input)) + => Elem input -> a + -> Scanner m loc input (loc, a) +accept i a + = from (\i' -> if i == i' + then Just a + else Nothing) +{-# INLINE accept #-} + + +-- | Accept a fixed length sequence of tokens that match the +-- given sequence, and return a result of type @a@. +accepts :: (Monad m, Sequence input, Eq input) + => input -> a + -> Scanner m loc input (loc, a) +accepts is a + = froms (Just (length is)) + (\is' -> if is == is' + then Just a + else Nothing) +{-# INLINE accepts #-} + + +------------------------------------------------------------------------------- +-- | Use the given function to check whether to accept the next token, +-- returning the result it produces. +from :: Monad m + => (Elem input -> Maybe a) + -> Scanner m loc input (loc, a) + +from fAccept + = Scanner $ \ss + -> sourceTry ss + $ do mx <- sourcePull ss (const True) + case mx of + Nothing -> return Nothing + Just (l, x) + -> case fAccept x of + Nothing -> return Nothing + Just y -> return $ Just (l, y) +{-# INLINE from #-} + + +-- | Use the given function to check whether to accept +-- a fixed length sequence of tokens, +-- returning the result it produces. +froms :: Monad m + => Maybe Int -> (input -> Maybe a) + -> Scanner m loc input (loc, a) + +froms mLen fAccept + = Scanner $ \ss + -> sourceTry ss + $ do mx <- sourcePulls ss mLen (\_ _ _ -> Just ()) () + case mx of + Nothing -> return Nothing + Just (l, xs) + -> case fAccept xs of + Nothing -> return Nothing + Just y -> return $ Just (l, y) +{-# INLINE froms #-} + + +------------------------------------------------------------------------------- +-- | Combine two argument scanners into a result scanner, +-- where the first argument scanner is tried before the second. +alt :: Monad m + => Scanner m loc input a -> Scanner m loc input a + -> Scanner m loc input a +alt (Scanner scan1) (Scanner scan2) + = Scanner $ \ss + -> do mx <- sourceTry ss (scan1 ss) + case mx of + Nothing -> scan2 ss + Just r -> return (Just r) +{-# INLINE alt #-} + + +-- | Combine a list of argumenet scanners a result scanner, +-- where each argument scanner is tried in turn until we find +-- one that matches (or not). +alts :: Monad m + => [Scanner m loc input a] -> Scanner m loc input a +alts [] + = Scanner $ \_ -> return Nothing + +alts (Scanner scan1 : xs) + = Scanner $ \ss + -> do mx <- sourceTry ss (scan1 ss) + case mx of + Nothing -> runScanner (alts xs) ss + Just r -> return (Just r) +{-# INLINE alts #-} + +------------------------------------------------------------------------------- +-- | Munch input tokens, using a predicate to select the prefix to consider. +-- +-- Given @munch (Just n) match accept@, we select a contiguous sequence +-- of tokens up to length n using the predicate @match@, then pass +-- that sequence to @accept@ to make a result value out of it. +-- If @match@ selects no tokens, or @accept@ returns `Nothing` +-- then the scanner fails and no tokens are consumed from the source. +-- +-- For example, to scan natural numbers use: +-- +-- @ +-- scanNat :: Monad m => Scanner m loc [Char] (loc, Integer) +-- scanNat = munchPred Nothing match accept +-- where match _ c = isDigit c +-- accept cs = Just (read cs) +-- @ +-- +-- To match Haskell style constructor names use: +-- +-- @ +-- scanCon :: Monad m => Scanner m loc [Char] (loc, String) +-- scanCon = munchPred Nothing match accept +-- where match 0 c = isUpper c +-- match _ c = isAlphaNum c +-- accept cs = Just cs +-- @ +-- +-- If you want to detect built-in constructor names like @Int@ and @Float@ +-- then you can do it in the @accept@ function and produce a different +-- result constructor for each one. +-- +munchPred + :: Monad m + => Maybe Int + -- ^ Maximum number of tokens to consider, + -- or `Nothing` for no maximum. + -> (Int -> Elem input -> Bool) + -- ^ Predicate to decide whether to consider the next + -- input token, also passed the index of the token + -- in the prefix. + + -> (input -> Maybe a) + -- ^ Take the prefix of input tokens and decide + -- whether to produce a result value. + + -> Scanner m loc input (loc, a) + -- ^ Scan a prefix of tokens of type @is@, + -- and produce a result of type @a@ if it matches. + +munchPred mLenMax fPred fAccept + = munchFold + mLenMax + (\ix i s -> if fPred ix i then Just s else Nothing) + () + fAccept +{-# INLINE munchPred #-} + + +------------------------------------------------------------------------------- +-- | Like `munchPred`, but we accept prefixes of any length, +-- and always accept the input tokens that match. +-- +munchWord + :: Monad m + => (Int -> Elem input -> Bool) + -- ^ Predicate to decide whether to accept the next + -- input token, also passed the index of the token + -- in the prefix. + -> Scanner m loc input (loc, input) + +munchWord fPred + = munchFold + Nothing + (\ix i s -> if fPred ix i then Just s else Nothing) + () + Just +{-# INLINE munchWord #-} + + +------------------------------------------------------------------------------- +-- | Like `munchPred`, but we can use a fold function to select the +-- prefix of tokens to consider. This is useful when lexing comments, +-- and string literals where consecutive tokens can have special meaning +-- (ie escaped quote characters). +-- +-- See the source of @scanHaskellChar@ in the "Text.Lexer.Inchworm.Char", +-- module for an example of its usage. +-- +munchFold + :: Monad m + => Maybe Int + -- ^ Maximum number of tokens to consider, + -- or `Nothing` for no maximum. + -> (Int -> Elem input -> state -> Maybe state) + -- ^ Fold function to decide whether to consider the next + -- input token. The next token will be considered if + -- the function produces a `Just` with its new state. + -- We stop considering tokens the first time it returns + -- `Nothing`. + -> state -- ^ Initial state for the fold. + -> (input -> Maybe a) + -- ^ Take the prefix of input tokens and decide + -- whether to produce a result value. + -> Scanner m loc input (loc, a) + -- ^ Scan a prefix of tokens of type @is@, + -- and produce a result of type @a@ if it matches. + +munchFold mLenMax work s0 acceptC + = Scanner $ \ss + -> sourceTry ss + $ do mr <- sourcePulls ss mLenMax work s0 + case mr of + Nothing -> return Nothing + Just (l, xs) + -> case acceptC xs of + Nothing -> return Nothing + Just x -> return $ Just (l, x) +{-# INLINE munchFold #-} + diff --git a/Text/Lexer/Inchworm/Scanner.hs b/Text/Lexer/Inchworm/Scanner.hs new file mode 100644 --- /dev/null +++ b/Text/Lexer/Inchworm/Scanner.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE InstanceSigs #-} + +module Text.Lexer.Inchworm.Scanner + ( Scanner (..) + , scanSourceToList) +where +import Text.Lexer.Inchworm.Source + + +-- | Scanner of input tokens that produces a result value +-- of type @a@ when successful. +data Scanner m loc input a + = Scanner + { runScanner :: Source m loc input -> m (Maybe a) } + + +instance Monad m + => Functor (Scanner m loc input) where + fmap f (Scanner load) + = Scanner $ \source + -> do r <- load source + case r of + Nothing -> return Nothing + Just x -> return $ Just $ f x + {-# INLINE fmap #-} + + +instance Monad m + => Applicative (Scanner m loc input) where + pure x + = Scanner $ \_ -> return (Just x) + + (<*>) (Scanner loadF) (Scanner loadX) + = Scanner $ \ss + -> do mf <- loadF ss + case mf of + Nothing + -> return Nothing + + Just f + -> do mx <- loadX ss + case mx of + Nothing -> return Nothing + Just x -> return $ Just (f x) + +instance Monad m + => Monad (Scanner m loc input) where + return x + = Scanner $ \_ -> return (Just x) + + (>>=) (Scanner loadX) f + = Scanner $ \ss + -> do mx <- loadX ss + case mx of + Nothing -> return Nothing + Just x -> runScanner (f x) ss + + +-- | Apply a scanner to a source of input tokens, +-- where the tokens are represented as a lazy list. +-- +-- The result values are also produced in a lazy list. +-- +scanSourceToList + :: Monad m + => Source m loc [i] -> Scanner m loc [i] a + -> m ([a], loc, [i]) + +scanSourceToList ss (Scanner load) + = go [] + where go acc + = load ss >>= \result + -> case result of + Just x -> go (x : acc) + Nothing + -> do (loc, src') <- sourceRemaining ss + return (reverse acc, loc, src') + +{-# SPECIALIZE INLINE + scanSourceToList + :: Source IO Location [Char] + -> Scanner IO Location [Char] a + -> IO ([a], Location, [Char]) + #-} diff --git a/Text/Lexer/Inchworm/Source.hs b/Text/Lexer/Inchworm/Source.hs new file mode 100644 --- /dev/null +++ b/Text/Lexer/Inchworm/Source.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE BangPatterns, RankNTypes, TypeFamilies, FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Text.Lexer.Inchworm.Source + ( Source (..), Location (..) + , Sequence (..) + , makeListSourceIO) +where +import Data.IORef +import qualified Data.List as List +import Prelude hiding (length) + + +--------------------------------------------------------------------------------------------------- +-- | Class of sequences of things. +class Sequence is where + -- | An element of a sequence. + type Elem is + + -- | Yield the length of a sequence. + length :: is -> Int + + +instance Sequence [a] where + type Elem [a] = a + length = List.length + + + +-- | An abstract source of input tokens that we want to perform lexical analysis on. +-- +-- Each token is associated with a source location @loc@. +-- A a sequence of tokens has type @input@, and a single token type (`Elem` input). +-- +data Source m loc input + = Source + { -- | Skip over values from the source that match the given predicate. + sourceSkip :: (Elem input -> Bool) -> m () + + -- | Try to evaluate the given computation that may pull values + -- from the source. If it returns Nothing then rewind the + -- source to the original position. + , sourceTry :: forall a. m (Maybe a) -> m (Maybe a) + + -- | Pull a value from the source, + -- provided it matches the given predicate. + , sourcePull :: (Elem input -> Bool) + -> m (Maybe (loc, Elem input)) + + -- | Use a fold function to select a some consecutive tokens from the source + -- that we want to process, also passing the current index to the fold function. + -- + -- The maximum number of tokens to select is set by the first argument, + -- which can be set to `Nothing` for no maximum. + , sourcePulls :: forall s + . Maybe Int + -> (Int -> Elem input -> s -> Maybe s) + -> s + -> m (Maybe (loc, input)) + + -- | Bump the source location using the given element. + , sourceBumpLoc :: Elem input -> loc -> loc + + -- | Get the remaining input. + , sourceRemaining :: m (loc, input) + } + + +--------------------------------------------------------------------------------------------------- +-- | Make a source from a list of input tokens, +-- maintaining the state in the IO monad. +makeListSourceIO + :: forall i loc + . Eq i + => loc -- ^ Starting source location. + -> (i -> loc -> loc) -- ^ Function to bump the current location by one input token. + -> [i] -- ^ List of input tokens. + -> IO (Source IO loc [i]) + +makeListSourceIO loc00 bumpLoc cs0 + = do refLoc <- newIORef loc00 + refSrc <- newIORef cs0 + return + $ Source + (skipListSourceIO refLoc refSrc) + (tryListSourceIO refLoc refSrc) + (pullListSourceIO refLoc refSrc) + (pullsListSourceIO refLoc refSrc) + (bumpLoc) + (remainingSourceIO refLoc refSrc) + where + -- Skip values from the source. + skipListSourceIO refLoc refSrc fPred + = do + loc0 <- readIORef refLoc + cc0 <- readIORef refSrc + + let eat !loc !cc + = case cc of + [] + -> do writeIORef refLoc loc + writeIORef refSrc [] + return () + + c : cs + | fPred c + -> eat (bumpLoc c loc) cs + + | otherwise + -> do writeIORef refLoc loc + writeIORef refSrc (c : cs) + return () + + eat loc0 cc0 + + + -- Try to run the given computation, + -- reverting source state changes if it returns Nothing. + tryListSourceIO refLoc refSrc comp + = do loc <- readIORef refLoc + cc <- readIORef refSrc + mx <- comp + case mx of + Just i + -> return (Just i) + + Nothing + -> do writeIORef refLoc loc + writeIORef refSrc cc + return Nothing + + + -- Pull a single value from the source. + pullListSourceIO refLoc refSrc fPred + = do loc <- readIORef refLoc + cc <- readIORef refSrc + case cc of + [] + -> return Nothing + + c : cs + | fPred c + -> do writeIORef refLoc (bumpLoc c loc) + writeIORef refSrc cs + return $ Just (loc, c) + + | otherwise + -> return Nothing + + + -- Pull a vector of values that match the given predicate + -- from the source. + pullsListSourceIO + :: IORef loc -> IORef [i] + -> Maybe Int -> (Int -> i -> s -> Maybe s) + -> s -> IO (Maybe (loc, [i])) + + pullsListSourceIO refLoc refSrc mLenMax work s0 + = do loc0 <- readIORef refLoc + cc0 <- readIORef refSrc + + let eat !ix !(l :: loc) !cc !acc !s + | Just mx <- mLenMax + , ix >= mx + = return (ix, l, cc, reverse acc) + + | otherwise + = case cc of + [] + -> return (ix, l, cc, reverse acc) + + c : cs + -> case work ix c s of + Nothing -> return (ix, l, cc, reverse acc) + Just s' -> eat (ix + 1) (bumpLoc c l) + cs (c : acc) s' + + (len, loc', cc', acc) + <- eat 0 loc0 cc0 [] s0 + + case len of + 0 -> return Nothing + _ -> do writeIORef refLoc loc' + writeIORef refSrc cc' + return $ Just (loc0, acc) + + -- Get the remaining input. + remainingSourceIO + :: IORef loc -> IORef [i] + -> IO (loc, [i]) + + remainingSourceIO refLoc refSrc + = do loc <- readIORef refLoc + src <- readIORef refSrc + return (loc, src) + + +------------------------------------------------------------------------------- +-- | A location in a source file. +--- +-- We define this here so that we can use it to specialize +-- makeListSourceIO. +-- +data Location + = Location + !Int -- Line. + !Int -- Column. + deriving Show + + +{-# SPECIALIZE INLINE + makeListSourceIO + :: Location + -> (Char -> Location -> Location) + -> [Char] + -> IO (Source IO Location [Char]) + #-} diff --git a/inchworm.cabal b/inchworm.cabal new file mode 100644 --- /dev/null +++ b/inchworm.cabal @@ -0,0 +1,60 @@ +name: inchworm +version: 1.0.0.1 +license: MIT +license-file: LICENSE +author: The Inchworm Development Team +maintainer: Ben Lippmeier +build-Type: Simple +cabal-Version: >=1.6 +stability: experimental +homepage: https://github.com/DDCSF/inchworm +category: Parsing +synopsis: Inchworm Lexer Framework + +description: Parser combinator framework specialized to lexical analysis. + Tokens can be specified via simple fold functions, + and we include baked in source location handling. + + If you want to parse expressions instead of tokens then try + try the @parsec@ or @attoparsec@ packages, which have more + general purpose combinators. + + Comes with matchers for standard lexemes like integers, + comments, and Haskell style strings with escape handling. + + No dependencies other than the Haskell 'base' library. + + +source-repository head + type: git + location: https://github.com/DDCSF/inchworm.git + + +library + build-Depends: + base >= 4.8 && < 4.10 + + exposed-modules: + Text.Lexer.Inchworm.Char + Text.Lexer.Inchworm.Scanner + Text.Lexer.Inchworm.Source + Text.Lexer.Inchworm + + other-modules: + Text.Lexer.Inchworm.Combinator + + + ghc-options: + -Wall + -fno-warn-orphans + -fno-warn-type-defaults + -fno-warn-missing-methods + -fno-warn-redundant-constraints + + extensions: + ParallelListComp + PatternGuards + RankNTypes + FlexibleContexts + KindSignatures + BangPatterns