diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,12 @@ +## Changes in 3.2.4: + + * Remove dependency on QuickCheck + * Change the way that bootstrapping is done: see README.md for build + instructions + ## Changes in 3.2.3: - * fix issue when using ccphs (#116) + * fix issue when using cpphs (#116) ## Changes in 3.2.2: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,15 +5,9 @@ Alex is a Lex-like tool for generating Haskell scanners. For complete documentation, see the doc directory. - http://www.haskell.org/alex/ - - http://hackage.haskell.org/package/alex - -Alex is built using Cabal. First install GHC and cabal-install, then: +- - $ cabal configure - $ cabal build - $ cabal install +- Alex version 2.0 has changed fairly considerably since version 1.x, and the syntax is almost completely different. For a detailed list of @@ -28,6 +22,66 @@ The source code in the 'src' and 'examples' directories is intended for a Haskell 98 compiler with hierarchical modules. It should work with GHC >= 5.04. + +## Build Instructions + +If you just want to *use* Alex, you can download or install (via +`cabal install alex`) an +[Alex release from Hackage](https://hackage.haskell.org/package/alex); also note that +distributions such as the +[Haskell Platform](https://www.haskell.org/platform/) and other package +manager-based distributions provide packages for Alex. Moreover, +recent versions of `cabal` will automatically install the required +version of `alex` based on +[`build-tools`/`build-tool-depends` declarations](http://cabal.readthedocs.io/en/latest/developing-packages.html#pkg-field-build-tool-depends). + +Read on if you want to build Alex directly from Git. + +Alex is built using GHC & Cabal; so first install +[GHC](https://www.haskell.org/ghc) and +[`cabal-install-2.0`](https://www.haskell.org/cabal) (or later). + +Since Alex itself is implemented in terms of an Alex scanner, +bootstrapping Alex is a bit tricky: + +You need to have the build-tools `alex` and `happy` manually +installed; either via your system package manager distribution, the +Haskell Platform, or e.g. via (run this outside the Git repository!): + + $ cabal install alex happy + +which installs them into `${HOME}/.cabal/bin` by default (make sure +they're in your `$PATH` for the next steps!). + +### Variant A + +First you need to generate the pre-processed templates via + + $ cabal new-run gen-alex-sdist + +(otherwise `cabal install` will complain about +"`data/AlexTemplate: copyFile: does not exist (No such file or directory)`") + +And then you can install `alex` simply by invoking + + $ cabal install + +from inside the Git folder. + +### Variant B + +Alternatively, you can use the `Makefile` which automates the steps of +producing a self-contained pre-bootstrapped source distribution with +pre-generated lexer/scanners (and which also performs the `cabal +new-run gen-alex-sdist` pre-preprocessing step): + + $ make sdist + $ cabal install dist/alex-*.tar.gz + +For convenience, there's also a `make sdist-test` target which builds the +source source tarball and runs the test-suite from within the source dist. + +## Contributing & Reporting Issues Please report any bugs or comments at https://github.com/simonmar/alex/issues 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/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,99 +0,0 @@ -#!/usr/bin/runhaskell - -\begin{code} -module Main where - -import Distribution.Verbosity -import Distribution.PackageDescription (PackageDescription(..)) -import Distribution.Simple.Setup ( BuildFlags(..), buildVerbosity, fromFlagOrDefault ) -import Distribution.Simple ( defaultMainWithHooks, simpleUserHooks, UserHooks(..) ) -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) -import Distribution.Simple.Program - -import System.FilePath (()) -import Control.Exception ( IOException, try ) -import System.Directory (removeFile) -import Data.Char - -main :: IO () -main = defaultMainWithHooks simpleUserHooks{ postBuild = myPostBuild, - postClean = myPostClean, - copyHook = myCopy, - instHook = myInstall } - --- hack to turn cpp-style '# 27 "GenericTemplate.hs"' into --- '{-# LINE 27 "GenericTemplate.hs" #-}'. -mungeLinePragma line = case symbols line of - syms | Just prag <- getLinePrag syms -> prag - -- Also convert old-style CVS lines, no idea why we do this... - ("--":"$":"Id":":":_) -> filter (/='$') line - ( "$":"Id":":":_) -> filter (/='$') line - _ -> line - -getLinePrag :: [String] -> Maybe String -getLinePrag ("#" : n : string : rest) - | length rest <= 1 -- clang puts an extra field - , length string >= 2 && head string == '"' && last string == '"' - , all isDigit n - = Just $ "{-# LINE " ++ n ++ " " ++ string ++ " #-}" -getLinePrag other = Nothing - -symbols :: String -> [String] -symbols cs = case lex cs of - (sym, cs'):_ | not (null sym) -> sym : symbols cs' - _ -> [] - -myPostBuild _ flags _ lbi = do - let verbosity = fromFlagOrDefault normal (buildVerbosity flags) - runProgram p = rawSystemProgramConf verbosity p (withPrograms lbi) - cpp_template src dst opts = do - let tmp = dst ++ ".tmp" - runProgram ghcProgram (["-o", tmp, "-E", "-cpp", "templates" src] ++ opts) - writeFile dst . unlines . map mungeLinePragma . lines =<< readFile tmp - removeFile tmp - - sequence_ ([ cpp_template "GenericTemplate.hs" dst opts | (dst,opts) <- templates ] ++ - [ cpp_template "wrappers.hs" dst opts | (dst,opts) <- wrappers ]) - -myPostClean _ _ _ _ = let try' = try :: IO a -> IO (Either IOException a) - in mapM_ (try' . removeFile) all_template_files - -myInstall pkg_descr lbi hooks flags = - instHook simpleUserHooks pkg_descr' lbi hooks flags - where pkg_descr' = pkg_descr { - dataFiles = dataFiles pkg_descr ++ all_template_files - } - -myCopy pkg_descr lbi hooks copy_flags = - copyHook simpleUserHooks pkg_descr' lbi hooks copy_flags - where pkg_descr' = pkg_descr { - dataFiles = dataFiles pkg_descr ++ all_template_files - } - -all_template_files :: [FilePath] -all_template_files = map fst (templates ++ wrappers) - -templates :: [(FilePath,[String])] -templates = [ - ("AlexTemplate", []), - ("AlexTemplate-ghc", ["-DALEX_GHC"]), - ("AlexTemplate-ghc-nopred",["-DALEX_GHC", "-DALEX_NOPRED"]), - ("AlexTemplate-ghc-debug", ["-DALEX_GHC","-DALEX_DEBUG"]), - ("AlexTemplate-debug", ["-DALEX_DEBUG"]) - ] - -wrappers :: [(FilePath,[String])] -wrappers = [ - ("AlexWrapper-basic", ["-DALEX_BASIC"]), - ("AlexWrapper-basic-bytestring", ["-DALEX_BASIC_BYTESTRING"]), - ("AlexWrapper-strict-bytestring", ["-DALEX_STRICT_BYTESTRING"]), - ("AlexWrapper-posn", ["-DALEX_POSN"]), - ("AlexWrapper-posn-bytestring", ["-DALEX_POSN_BYTESTRING"]), - ("AlexWrapper-monad", ["-DALEX_MONAD"]), - ("AlexWrapper-monad-bytestring", ["-DALEX_MONAD_BYTESTRING"]), - ("AlexWrapper-monadUserState", ["-DALEX_MONAD", "-DALEX_MONAD_USER_STATE"]), - ("AlexWrapper-monadUserState-bytestring", ["-DALEX_MONAD_BYTESTRING", "-DALEX_MONAD_USER_STATE"]), - ("AlexWrapper-gscan", ["-DALEX_GSCAN"]) - ] - -\end{code} diff --git a/alex.cabal b/alex.cabal --- a/alex.cabal +++ b/alex.cabal @@ -1,5 +1,6 @@ +cabal-version: >= 1.8 name: alex -version: 3.2.3 +version: 3.2.4 -- don't forget updating changelog.md! license: BSD3 license-file: LICENSE @@ -18,9 +19,27 @@ lex or flex for C/C++. category: Development -cabal-version: >= 1.8 -build-type: Custom +build-type: Simple +data-dir: data/ + +data-files: + AlexTemplate + AlexTemplate-ghc + AlexTemplate-ghc-nopred + AlexTemplate-ghc-debug + AlexTemplate-debug + AlexWrapper-basic + AlexWrapper-basic-bytestring + AlexWrapper-strict-bytestring + AlexWrapper-posn + AlexWrapper-posn-bytestring + AlexWrapper-monad + AlexWrapper-monad-bytestring + AlexWrapper-monadUserState + AlexWrapper-monadUserState-bytestring + AlexWrapper-gscan + extra-source-files: CHANGELOG.md README.md @@ -50,7 +69,7 @@ src/Parser.y.boot src/Scan.x.boot src/ghc_hooks.c - templates/GenericTemplate.hs + templates/GenericTemplate.hs templates/wrappers.hs tests/Makefile tests/simple.x @@ -95,8 +114,6 @@ build-depends: base >= 1.0 build-depends: base < 5 - -- build-depends: Ranged-sets - build-depends: QuickCheck >=2 extensions: CPP ghc-options: -Wall -rtsopts @@ -110,6 +127,7 @@ Map NFA Output + Paths_alex Parser ParseMonad Scan @@ -125,4 +143,7 @@ test-suite tests type: exitcode-stdio-1.0 main-is: test.hs + -- This line is important as it ensures that the local `exe:alex` component declared above is built before the test-suite component is invoked, as well as making sure that `alex` is made available on $PATH and `$alex_datadir` is set accordingly before invoking `test.hs` + build-tools: alex + build-depends: base, process diff --git a/data/AlexTemplate b/data/AlexTemplate new file mode 100644 --- /dev/null +++ b/data/AlexTemplate @@ -0,0 +1,237 @@ +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +alexIndexInt16OffAddr arr off = arr ! off + + + + + + + + + + + + + + + + + + + + +alexIndexInt32OffAddr arr off = arr ! off + + + + + + + + + + + +quickIndex arr i = arr ! i + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input__ (sc) + = alexScanUser undefined input__ (sc) + +alexScanUser user__ input__ (sc) + = case alex_scan_tkn user__ input__ (0) input__ sc AlexNone of + (AlexNone, input__') -> + case alexGetByte input__ of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input__' + + (AlexLastSkip input__'' len, _) -> + + + + AlexSkip input__'' len + + (AlexLastAcc k input__''' len, _) -> + + + + AlexToken input__''' len (alex_actions ! k) + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user__ orig_input len input__ s last_acc = + input__ `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` (s))) + in + new_acc `seq` + case alexGetByte input__ of + Nothing -> (new_acc, input__) + Just (c, new_input) -> + + + + case fromIntegral c of { (ord_c) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = (base + ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if (offset >= (0)) && (check == ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + (-1) -> (new_acc, input__) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len + (1)) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input__ (len) + check_accs (AlexAccSkip) = AlexLastSkip input__ (len) + + check_accs (AlexAccPred a predx rest) + | predx user__ orig_input (len) input__ + = AlexLastAcc a input__ (len) + | otherwise + = check_accs rest + check_accs (AlexAccSkipPred predx rest) + | predx user__ orig_input (len) input__ + = AlexLastSkip input__ (len) + | otherwise + = check_accs rest + + +data AlexLastAcc + = AlexNone + | AlexLastAcc !Int !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc user + = AlexAccNone + | AlexAcc Int + | AlexAccSkip + + | AlexAccPred Int (AlexAccPred user) (AlexAcc user) + | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user__ in1 len in2 + = p1 user__ in1 len in2 && p2 user__ in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ + +alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (sc) user__ _ _ input__ = + case alex_scan_tkn user__ input__ (0) input__ sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + diff --git a/data/AlexTemplate-debug b/data/AlexTemplate-debug new file mode 100644 --- /dev/null +++ b/data/AlexTemplate-debug @@ -0,0 +1,237 @@ +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +alexIndexInt16OffAddr arr off = arr ! off + + + + + + + + + + + + + + + + + + + + +alexIndexInt32OffAddr arr off = arr ! off + + + + + + + + + + + +quickIndex arr i = arr ! i + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input__ (sc) + = alexScanUser undefined input__ (sc) + +alexScanUser user__ input__ (sc) + = case alex_scan_tkn user__ input__ (0) input__ sc AlexNone of + (AlexNone, input__') -> + case alexGetByte input__ of + Nothing -> + + trace ("End of input.") $ + + AlexEOF + Just _ -> + + trace ("Error.") $ + + AlexError input__' + + (AlexLastSkip input__'' len, _) -> + + trace ("Skipping.") $ + + AlexSkip input__'' len + + (AlexLastAcc k input__''' len, _) -> + + trace ("Accept.") $ + + AlexToken input__''' len (alex_actions ! k) + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user__ orig_input len input__ s last_acc = + input__ `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` (s))) + in + new_acc `seq` + case alexGetByte input__ of + Nothing -> (new_acc, input__) + Just (c, new_input) -> + + trace ("State: " ++ show (s) ++ ", char: " ++ show c) $ + + case fromIntegral c of { (ord_c) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = (base + ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if (offset >= (0)) && (check == ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + (-1) -> (new_acc, input__) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len + (1)) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input__ (len) + check_accs (AlexAccSkip) = AlexLastSkip input__ (len) + + check_accs (AlexAccPred a predx rest) + | predx user__ orig_input (len) input__ + = AlexLastAcc a input__ (len) + | otherwise + = check_accs rest + check_accs (AlexAccSkipPred predx rest) + | predx user__ orig_input (len) input__ + = AlexLastSkip input__ (len) + | otherwise + = check_accs rest + + +data AlexLastAcc + = AlexNone + | AlexLastAcc !Int !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc user + = AlexAccNone + | AlexAcc Int + | AlexAccSkip + + | AlexAccPred Int (AlexAccPred user) (AlexAcc user) + | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user__ in1 len in2 + = p1 user__ in1 len in2 && p2 user__ in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ + +alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (sc) user__ _ _ input__ = + case alex_scan_tkn user__ input__ (0) input__ sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + diff --git a/data/AlexTemplate-ghc b/data/AlexTemplate-ghc new file mode 100644 --- /dev/null +++ b/data/AlexTemplate-ghc @@ -0,0 +1,237 @@ +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + + + + + + + + + + + + + + + + + +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ > 706 +#define GTE(n,m) (tagToEnum# (n >=# m)) +#define EQ(n,m) (tagToEnum# (n ==# m)) +#else +#define GTE(n,m) (n >=# m) +#define EQ(n,m) (n ==# m) +#endif + + + + + + + + + + + + + + + + + + + +data AlexAddr = AlexA# Addr# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else + indexInt16OffAddr# arr off +#endif + + + + + +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else + indexInt32OffAddr# arr off +#endif + + + + + + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input__ (I# (sc)) + = alexScanUser undefined input__ (I# (sc)) + +alexScanUser user__ input__ (I# (sc)) + = case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of + (AlexNone, input__') -> + case alexGetByte input__ of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input__' + + (AlexLastSkip input__'' len, _) -> + + + + AlexSkip input__'' len + + (AlexLastAcc k input__''' len, _) -> + + + + AlexToken input__''' len (alex_actions ! k) + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user__ orig_input len input__ s last_acc = + input__ `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) + in + new_acc `seq` + case alexGetByte input__ of + Nothing -> (new_acc, input__) + Just (c, new_input) -> + + + + case fromIntegral c of { (I# (ord_c)) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = (base +# ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if GTE(offset,0#) && EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + -1# -> (new_acc, input__) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input__ (I# (len)) + check_accs (AlexAccSkip) = AlexLastSkip input__ (I# (len)) + + check_accs (AlexAccPred a predx rest) + | predx user__ orig_input (I# (len)) input__ + = AlexLastAcc a input__ (I# (len)) + | otherwise + = check_accs rest + check_accs (AlexAccSkipPred predx rest) + | predx user__ orig_input (I# (len)) input__ + = AlexLastSkip input__ (I# (len)) + | otherwise + = check_accs rest + + +data AlexLastAcc + = AlexNone + | AlexLastAcc !Int !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc user + = AlexAccNone + | AlexAcc Int + | AlexAccSkip + + | AlexAccPred Int (AlexAccPred user) (AlexAcc user) + | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user__ in1 len in2 + = p1 user__ in1 len in2 && p2 user__ in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ + +alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (I# (sc)) user__ _ _ input__ = + case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + diff --git a/data/AlexTemplate-ghc-debug b/data/AlexTemplate-ghc-debug new file mode 100644 --- /dev/null +++ b/data/AlexTemplate-ghc-debug @@ -0,0 +1,237 @@ +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + + + + + + + + + + + + + + + + + +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ > 706 +#define GTE(n,m) (tagToEnum# (n >=# m)) +#define EQ(n,m) (tagToEnum# (n ==# m)) +#else +#define GTE(n,m) (n >=# m) +#define EQ(n,m) (n ==# m) +#endif + + + + + + + + + + + + + + + + + + + +data AlexAddr = AlexA# Addr# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else + indexInt16OffAddr# arr off +#endif + + + + + +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else + indexInt32OffAddr# arr off +#endif + + + + + + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input__ (I# (sc)) + = alexScanUser undefined input__ (I# (sc)) + +alexScanUser user__ input__ (I# (sc)) + = case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of + (AlexNone, input__') -> + case alexGetByte input__ of + Nothing -> + + trace ("End of input.") $ + + AlexEOF + Just _ -> + + trace ("Error.") $ + + AlexError input__' + + (AlexLastSkip input__'' len, _) -> + + trace ("Skipping.") $ + + AlexSkip input__'' len + + (AlexLastAcc k input__''' len, _) -> + + trace ("Accept.") $ + + AlexToken input__''' len (alex_actions ! k) + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user__ orig_input len input__ s last_acc = + input__ `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) + in + new_acc `seq` + case alexGetByte input__ of + Nothing -> (new_acc, input__) + Just (c, new_input) -> + + trace ("State: " ++ show (I# (s)) ++ ", char: " ++ show c) $ + + case fromIntegral c of { (I# (ord_c)) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = (base +# ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if GTE(offset,0#) && EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + -1# -> (new_acc, input__) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input__ (I# (len)) + check_accs (AlexAccSkip) = AlexLastSkip input__ (I# (len)) + + check_accs (AlexAccPred a predx rest) + | predx user__ orig_input (I# (len)) input__ + = AlexLastAcc a input__ (I# (len)) + | otherwise + = check_accs rest + check_accs (AlexAccSkipPred predx rest) + | predx user__ orig_input (I# (len)) input__ + = AlexLastSkip input__ (I# (len)) + | otherwise + = check_accs rest + + +data AlexLastAcc + = AlexNone + | AlexLastAcc !Int !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc user + = AlexAccNone + | AlexAcc Int + | AlexAccSkip + + | AlexAccPred Int (AlexAccPred user) (AlexAcc user) + | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user__ in1 len in2 + = p1 user__ in1 len in2 && p2 user__ in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ + +alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (I# (sc)) user__ _ _ input__ = + case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + diff --git a/data/AlexTemplate-ghc-nopred b/data/AlexTemplate-ghc-nopred new file mode 100644 --- /dev/null +++ b/data/AlexTemplate-ghc-nopred @@ -0,0 +1,237 @@ +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + + + + + + + + + + + + + + + + + +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ > 706 +#define GTE(n,m) (tagToEnum# (n >=# m)) +#define EQ(n,m) (tagToEnum# (n ==# m)) +#else +#define GTE(n,m) (n >=# m) +#define EQ(n,m) (n ==# m) +#endif + + + + + + + + + + + + + + + + + + + +data AlexAddr = AlexA# Addr# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else + indexInt16OffAddr# arr off +#endif + + + + + +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else + indexInt32OffAddr# arr off +#endif + + + + + + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input__ (I# (sc)) + = alexScanUser undefined input__ (I# (sc)) + +alexScanUser user__ input__ (I# (sc)) + = case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of + (AlexNone, input__') -> + case alexGetByte input__ of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input__' + + (AlexLastSkip input__'' len, _) -> + + + + AlexSkip input__'' len + + (AlexLastAcc k input__''' len, _) -> + + + + AlexToken input__''' len (alex_actions ! k) + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user__ orig_input len input__ s last_acc = + input__ `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) + in + new_acc `seq` + case alexGetByte input__ of + Nothing -> (new_acc, input__) + Just (c, new_input) -> + + + + case fromIntegral c of { (I# (ord_c)) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = (base +# ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if GTE(offset,0#) && EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + -1# -> (new_acc, input__) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input__ (I# (len)) + check_accs (AlexAccSkip) = AlexLastSkip input__ (I# (len)) + + + + + + + + + + + + + +data AlexLastAcc + = AlexNone + | AlexLastAcc !Int !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc user + = AlexAccNone + | AlexAcc Int + | AlexAccSkip + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/data/AlexWrapper-basic b/data/AlexWrapper-basic new file mode 100644 --- /dev/null +++ b/data/AlexWrapper-basic @@ -0,0 +1,493 @@ +{-# LINE 1 "templates/wrappers.hs" #-} +-- ----------------------------------------------------------------------------- +-- Alex wrapper code. +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + + + + + + +import Data.Word (Word8) + + + + + + + + + + + + + + + + +import Data.Char (ord) +import qualified Data.Bits + +-- | Encode a Haskell String to a list of Word8 values, in UTF8 format. +utf8Encode :: Char -> [Word8] +utf8Encode = map fromIntegral . go . ord + where + go oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) + , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + + +type Byte = Word8 + +-- ----------------------------------------------------------------------------- +-- The input type + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Token positions + +-- `Posn' records the location of a token in the input text. It has three +-- fields: the address (number of chacaters preceding the token), line number +-- and column of a token within the file. `start_pos' gives the position of the +-- start of the file and `eof_pos' a standard encoding for the end of file. +-- `move_pos' calculates the new position after traversing a given character, +-- assuming the usual eight character tab stops. + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Default monad + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Monad (with ByteString input) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper + + +type AlexInput = (Char,[Byte],String) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (c,_,_) = c + +-- alexScanTokens :: String -> [token] +alexScanTokens str = go ('\n',[],str) + where go inp__@(_,_bs,s) = + case alexScan inp__ 0 of + AlexEOF -> [] + AlexError _ -> error "lexical error" + AlexSkip inp__' _ln -> go inp__' + AlexToken inp__' len act -> act (take len s) : go inp__' + +alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) +alexGetByte (c,(b:bs),s) = Just (b,(c,bs,s)) +alexGetByte (_,[],[]) = Nothing +alexGetByte (_,[],(c:s)) = case utf8Encode c of + (b:bs) -> Just (b, (c, bs, s)) + [] -> Nothing + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper, ByteString version + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper + +-- Adds text positions to the basic model. + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper, ByteString version + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- GScan wrapper + +-- For compatibility with previous versions of Alex, and because we can. + + + + + + + + + + + + + + diff --git a/data/AlexWrapper-basic-bytestring b/data/AlexWrapper-basic-bytestring new file mode 100644 --- /dev/null +++ b/data/AlexWrapper-basic-bytestring @@ -0,0 +1,493 @@ +{-# LINE 1 "templates/wrappers.hs" #-} +-- ----------------------------------------------------------------------------- +-- Alex wrapper code. +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + + + + + + +import Data.Word (Word8) + + +import Data.Int (Int64) +import qualified Data.Char +import qualified Data.ByteString.Lazy as ByteString +import qualified Data.ByteString.Internal as ByteString (w2c) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +type Byte = Word8 + +-- ----------------------------------------------------------------------------- +-- The input type + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +data AlexInput = AlexInput { alexChar :: {-# UNPACK #-} !Char, -- previous char + alexStr :: !ByteString.ByteString, -- current input string + alexBytePos :: {-# UNPACK #-} !Int64} -- bytes consumed so far + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar = alexChar + +alexGetByte (AlexInput {alexStr=cs,alexBytePos=n}) = + case ByteString.uncons cs of + Nothing -> Nothing + Just (c, rest) -> + Just (c, AlexInput { + alexChar = ByteString.w2c c, + alexStr = rest, + alexBytePos = n+1}) + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Token positions + +-- `Posn' records the location of a token in the input text. It has three +-- fields: the address (number of chacaters preceding the token), line number +-- and column of a token within the file. `start_pos' gives the position of the +-- start of the file and `eof_pos' a standard encoding for the end of file. +-- `move_pos' calculates the new position after traversing a given character, +-- assuming the usual eight character tab stops. + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Default monad + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Monad (with ByteString input) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper, ByteString version + + + +-- alexScanTokens :: ByteString.ByteString -> [token] +alexScanTokens str = go (AlexInput '\n' str 0) + where go inp__ = + case alexScan inp__ 0 of + AlexEOF -> [] + AlexError _ -> error "lexical error" + AlexSkip inp__' _len -> go inp__' + AlexToken inp__' _ act -> + let len = alexBytePos inp__' - alexBytePos inp__ in + act (ByteString.take len (alexStr inp__)) : go inp__' + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper + +-- Adds text positions to the basic model. + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper, ByteString version + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- GScan wrapper + +-- For compatibility with previous versions of Alex, and because we can. + + + + + + + + + + + + + + diff --git a/data/AlexWrapper-gscan b/data/AlexWrapper-gscan new file mode 100644 --- /dev/null +++ b/data/AlexWrapper-gscan @@ -0,0 +1,493 @@ +{-# LINE 1 "templates/wrappers.hs" #-} +-- ----------------------------------------------------------------------------- +-- Alex wrapper code. +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + + + + + + +import Data.Word (Word8) + + + + + + + + + + + + + + + + +import Data.Char (ord) +import qualified Data.Bits + +-- | Encode a Haskell String to a list of Word8 values, in UTF8 format. +utf8Encode :: Char -> [Word8] +utf8Encode = map fromIntegral . go . ord + where + go oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) + , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + + +type Byte = Word8 + +-- ----------------------------------------------------------------------------- +-- The input type + + +type AlexInput = (AlexPosn, -- current position, + Char, -- previous char + [Byte], -- pending bytes on current char + String) -- current input string + +ignorePendingBytes :: AlexInput -> AlexInput +ignorePendingBytes (p,c,_ps,s) = (p,c,[],s) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (_p,c,_bs,_s) = c + +alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) +alexGetByte (p,c,(b:bs),s) = Just (b,(p,c,bs,s)) +alexGetByte (_,_,[],[]) = Nothing +alexGetByte (p,_,[],(c:s)) = let p' = alexMove p c + (b:bs) = utf8Encode c + in p' `seq` Just (b, (p', c, bs, s)) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Token positions + +-- `Posn' records the location of a token in the input text. It has three +-- fields: the address (number of chacaters preceding the token), line number +-- and column of a token within the file. `start_pos' gives the position of the +-- start of the file and `eof_pos' a standard encoding for the end of file. +-- `move_pos' calculates the new position after traversing a given character, +-- assuming the usual eight character tab stops. + + +data AlexPosn = AlexPn !Int !Int !Int + deriving (Eq,Show) + +alexStartPos :: AlexPosn +alexStartPos = AlexPn 0 1 1 + +alexMove :: AlexPosn -> Char -> AlexPosn +alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+alex_tab_size-1) `div` alex_tab_size)*alex_tab_size+1) +alexMove (AlexPn a l _) '\n' = AlexPn (a+1) (l+1) 1 +alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) + + +-- ----------------------------------------------------------------------------- +-- Default monad + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Monad (with ByteString input) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper, ByteString version + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper + +-- Adds text positions to the basic model. + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper, ByteString version + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- GScan wrapper + +-- For compatibility with previous versions of Alex, and because we can. + + +alexGScan stop__ state__ inp__ = + alex_gscan stop__ alexStartPos '\n' [] inp__ (0,state__) + +alex_gscan stop__ p c bs inp__ (sc,state__) = + case alexScan (p,c,bs,inp__) sc of + AlexEOF -> stop__ p c inp__ (sc,state__) + AlexError _ -> stop__ p c inp__ (sc,state__) + AlexSkip (p',c',bs',inp__') _len -> + alex_gscan stop__ p' c' bs' inp__' (sc,state__) + AlexToken (p',c',bs',inp__') len k -> + k p c inp__ len (\scs -> alex_gscan stop__ p' c' bs' inp__' scs) (sc,state__) + diff --git a/data/AlexWrapper-monad b/data/AlexWrapper-monad new file mode 100644 --- /dev/null +++ b/data/AlexWrapper-monad @@ -0,0 +1,493 @@ +{-# LINE 1 "templates/wrappers.hs" #-} +-- ----------------------------------------------------------------------------- +-- Alex wrapper code. +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + + +import Control.Applicative as App (Applicative (..)) +import qualified Control.Monad (ap) + + +import Data.Word (Word8) + + + + + + + + + + + + + + + + +import Data.Char (ord) +import qualified Data.Bits + +-- | Encode a Haskell String to a list of Word8 values, in UTF8 format. +utf8Encode :: Char -> [Word8] +utf8Encode = map fromIntegral . go . ord + where + go oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) + , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + + +type Byte = Word8 + +-- ----------------------------------------------------------------------------- +-- The input type + + +type AlexInput = (AlexPosn, -- current position, + Char, -- previous char + [Byte], -- pending bytes on current char + String) -- current input string + +ignorePendingBytes :: AlexInput -> AlexInput +ignorePendingBytes (p,c,_ps,s) = (p,c,[],s) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (_p,c,_bs,_s) = c + +alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) +alexGetByte (p,c,(b:bs),s) = Just (b,(p,c,bs,s)) +alexGetByte (_,_,[],[]) = Nothing +alexGetByte (p,_,[],(c:s)) = let p' = alexMove p c + (b:bs) = utf8Encode c + in p' `seq` Just (b, (p', c, bs, s)) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Token positions + +-- `Posn' records the location of a token in the input text. It has three +-- fields: the address (number of chacaters preceding the token), line number +-- and column of a token within the file. `start_pos' gives the position of the +-- start of the file and `eof_pos' a standard encoding for the end of file. +-- `move_pos' calculates the new position after traversing a given character, +-- assuming the usual eight character tab stops. + + +data AlexPosn = AlexPn !Int !Int !Int + deriving (Eq,Show) + +alexStartPos :: AlexPosn +alexStartPos = AlexPn 0 1 1 + +alexMove :: AlexPosn -> Char -> AlexPosn +alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+alex_tab_size-1) `div` alex_tab_size)*alex_tab_size+1) +alexMove (AlexPn a l _) '\n' = AlexPn (a+1) (l+1) 1 +alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) + + +-- ----------------------------------------------------------------------------- +-- Default monad + + +data AlexState = AlexState { + alex_pos :: !AlexPosn, -- position at current input location + alex_inp :: String, -- the current input + alex_chr :: !Char, -- the character before the input + alex_bytes :: [Byte], + alex_scd :: !Int -- the current startcode + + + + } + +-- Compile with -funbox-strict-fields for best results! + +runAlex :: String -> Alex a -> Either String a +runAlex input__ (Alex f) + = case f (AlexState {alex_pos = alexStartPos, + alex_inp = input__, + alex_chr = '\n', + alex_bytes = [], + + + + alex_scd = 0}) of Left msg -> Left msg + Right ( _, a ) -> Right a + +newtype Alex a = Alex { unAlex :: AlexState -> Either String (AlexState, a) } + +instance Functor Alex where + fmap f a = Alex $ \s -> case unAlex a s of + Left msg -> Left msg + Right (s', a') -> Right (s', f a') + +instance Applicative Alex where + pure a = Alex $ \s -> Right (s, a) + fa <*> a = Alex $ \s -> case unAlex fa s of + Left msg -> Left msg + Right (s', f) -> case unAlex a s' of + Left msg -> Left msg + Right (s'', b) -> Right (s'', f b) + +instance Monad Alex where + m >>= k = Alex $ \s -> case unAlex m s of + Left msg -> Left msg + Right (s',a) -> unAlex (k a) s' + return = App.pure + +alexGetInput :: Alex AlexInput +alexGetInput + = Alex $ \s@AlexState{alex_pos=pos,alex_chr=c,alex_bytes=bs,alex_inp=inp__} -> + Right (s, (pos,c,bs,inp__)) + +alexSetInput :: AlexInput -> Alex () +alexSetInput (pos,c,bs,inp__) + = Alex $ \s -> case s{alex_pos=pos,alex_chr=c,alex_bytes=bs,alex_inp=inp__} of + state__@(AlexState{}) -> Right (state__, ()) + +alexError :: String -> Alex a +alexError message = Alex $ const $ Left message + +alexGetStartCode :: Alex Int +alexGetStartCode = Alex $ \s@AlexState{alex_scd=sc} -> Right (s, sc) + +alexSetStartCode :: Int -> Alex () +alexSetStartCode sc = Alex $ \s -> Right (s{alex_scd=sc}, ()) + + + + + + + + + +alexMonadScan = do + inp__ <- alexGetInput + sc <- alexGetStartCode + case alexScan inp__ sc of + AlexEOF -> alexEOF + AlexError ((AlexPn _ line column),_,_,_) -> alexError $ "lexical error at line " ++ (show line) ++ ", column " ++ (show column) + AlexSkip inp__' _len -> do + alexSetInput inp__' + alexMonadScan + AlexToken inp__' len action -> do + alexSetInput inp__' + action (ignorePendingBytes inp__) len + +-- ----------------------------------------------------------------------------- +-- Useful token actions + +type AlexAction result = AlexInput -> Int -> Alex result + +-- just ignore this token and scan another one +-- skip :: AlexAction result +skip _input _len = alexMonadScan + +-- ignore this token, but set the start code to a new value +-- begin :: Int -> AlexAction result +begin code _input _len = do alexSetStartCode code; alexMonadScan + +-- perform an action for this token, and set the start code to a new value +andBegin :: AlexAction result -> Int -> AlexAction result +(action `andBegin` code) input__ len = do + alexSetStartCode code + action input__ len + +token :: (AlexInput -> Int -> token) -> AlexAction token +token t input__ len = return (t input__ len) + + + +-- ----------------------------------------------------------------------------- +-- Monad (with ByteString input) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper, ByteString version + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper + +-- Adds text positions to the basic model. + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper, ByteString version + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- GScan wrapper + +-- For compatibility with previous versions of Alex, and because we can. + + + + + + + + + + + + + + diff --git a/data/AlexWrapper-monad-bytestring b/data/AlexWrapper-monad-bytestring new file mode 100644 --- /dev/null +++ b/data/AlexWrapper-monad-bytestring @@ -0,0 +1,493 @@ +{-# LINE 1 "templates/wrappers.hs" #-} +-- ----------------------------------------------------------------------------- +-- Alex wrapper code. +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + + +import Control.Applicative as App (Applicative (..)) +import qualified Control.Monad (ap) + + +import Data.Word (Word8) + + +import Data.Int (Int64) +import qualified Data.Char +import qualified Data.ByteString.Lazy as ByteString +import qualified Data.ByteString.Internal as ByteString (w2c) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +type Byte = Word8 + +-- ----------------------------------------------------------------------------- +-- The input type + + + + + + + + + + + + + + + + + + + + + + +type AlexInput = (AlexPosn, -- current position, + Char, -- previous char + ByteString.ByteString, -- current input string + Int64) -- bytes consumed so far + +ignorePendingBytes :: AlexInput -> AlexInput +ignorePendingBytes i = i -- no pending bytes when lexing bytestrings + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (_,c,_,_) = c + +alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) +alexGetByte (p,_,cs,n) = + case ByteString.uncons cs of + Nothing -> Nothing + Just (b, cs') -> + let c = ByteString.w2c b + p' = alexMove p c + n' = n+1 + in p' `seq` cs' `seq` n' `seq` Just (b, (p', c, cs',n')) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Token positions + +-- `Posn' records the location of a token in the input text. It has three +-- fields: the address (number of chacaters preceding the token), line number +-- and column of a token within the file. `start_pos' gives the position of the +-- start of the file and `eof_pos' a standard encoding for the end of file. +-- `move_pos' calculates the new position after traversing a given character, +-- assuming the usual eight character tab stops. + + +data AlexPosn = AlexPn !Int !Int !Int + deriving (Eq,Show) + +alexStartPos :: AlexPosn +alexStartPos = AlexPn 0 1 1 + +alexMove :: AlexPosn -> Char -> AlexPosn +alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+alex_tab_size-1) `div` alex_tab_size)*alex_tab_size+1) +alexMove (AlexPn a l _) '\n' = AlexPn (a+1) (l+1) 1 +alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) + + +-- ----------------------------------------------------------------------------- +-- Default monad + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Monad (with ByteString input) + + +data AlexState = AlexState { + alex_pos :: !AlexPosn, -- position at current input location + alex_bpos:: !Int64, -- bytes consumed so far + alex_inp :: ByteString.ByteString, -- the current input + alex_chr :: !Char, -- the character before the input + alex_scd :: !Int -- the current startcode + + + + } + +-- Compile with -funbox-strict-fields for best results! + +runAlex :: ByteString.ByteString -> Alex a -> Either String a +runAlex input__ (Alex f) + = case f (AlexState {alex_pos = alexStartPos, + alex_bpos = 0, + alex_inp = input__, + alex_chr = '\n', + + + + alex_scd = 0}) of Left msg -> Left msg + Right ( _, a ) -> Right a + +newtype Alex a = Alex { unAlex :: AlexState -> Either String (AlexState, a) } + +instance Functor Alex where + fmap f m = do x <- m; return (f x) + +instance Applicative Alex where + pure a = Alex $ \s -> Right (s,a) + (<*>) = Control.Monad.ap + +instance Monad Alex where + m >>= k = Alex $ \s -> case unAlex m s of + Left msg -> Left msg + Right (s',a) -> unAlex (k a) s' + return = App.pure + +alexGetInput :: Alex AlexInput +alexGetInput + = Alex $ \s@AlexState{alex_pos=pos,alex_bpos=bpos,alex_chr=c,alex_inp=inp__} -> + Right (s, (pos,c,inp__,bpos)) + +alexSetInput :: AlexInput -> Alex () +alexSetInput (pos,c,inp__,bpos) + = Alex $ \s -> case s{alex_pos=pos, + alex_bpos=bpos, + alex_chr=c, + alex_inp=inp__} of + state__@(AlexState{}) -> Right (state__, ()) + +alexError :: String -> Alex a +alexError message = Alex $ const $ Left message + +alexGetStartCode :: Alex Int +alexGetStartCode = Alex $ \s@AlexState{alex_scd=sc} -> Right (s, sc) + +alexSetStartCode :: Int -> Alex () +alexSetStartCode sc = Alex $ \s -> Right (s{alex_scd=sc}, ()) + +alexMonadScan = do + inp__@(_,_,_,n) <- alexGetInput + sc <- alexGetStartCode + case alexScan inp__ sc of + AlexEOF -> alexEOF + AlexError ((AlexPn _ line column),_,_,_) -> alexError $ "lexical error at line " ++ (show line) ++ ", column " ++ (show column) + AlexSkip inp__' _len -> do + alexSetInput inp__' + alexMonadScan + AlexToken inp__'@(_,_,_,n') _ action -> do + alexSetInput inp__' + action (ignorePendingBytes inp__) len + where + len = n'-n + +-- ----------------------------------------------------------------------------- +-- Useful token actions + +type AlexAction result = AlexInput -> Int64 -> Alex result + +-- just ignore this token and scan another one +-- skip :: AlexAction result +skip _input _len = alexMonadScan + +-- ignore this token, but set the start code to a new value +-- begin :: Int -> AlexAction result +begin code _input _len = do alexSetStartCode code; alexMonadScan + +-- perform an action for this token, and set the start code to a new value +andBegin :: AlexAction result -> Int -> AlexAction result +(action `andBegin` code) input__ len = do + alexSetStartCode code + action input__ len + +token :: (AlexInput -> Int64 -> token) -> AlexAction token +token t input__ len = return (t input__ len) + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper, ByteString version + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper + +-- Adds text positions to the basic model. + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper, ByteString version + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- GScan wrapper + +-- For compatibility with previous versions of Alex, and because we can. + + + + + + + + + + + + + + diff --git a/data/AlexWrapper-monadUserState b/data/AlexWrapper-monadUserState new file mode 100644 --- /dev/null +++ b/data/AlexWrapper-monadUserState @@ -0,0 +1,493 @@ +{-# LINE 1 "templates/wrappers.hs" #-} +-- ----------------------------------------------------------------------------- +-- Alex wrapper code. +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + + +import Control.Applicative as App (Applicative (..)) +import qualified Control.Monad (ap) + + +import Data.Word (Word8) + + + + + + + + + + + + + + + + +import Data.Char (ord) +import qualified Data.Bits + +-- | Encode a Haskell String to a list of Word8 values, in UTF8 format. +utf8Encode :: Char -> [Word8] +utf8Encode = map fromIntegral . go . ord + where + go oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) + , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + + +type Byte = Word8 + +-- ----------------------------------------------------------------------------- +-- The input type + + +type AlexInput = (AlexPosn, -- current position, + Char, -- previous char + [Byte], -- pending bytes on current char + String) -- current input string + +ignorePendingBytes :: AlexInput -> AlexInput +ignorePendingBytes (p,c,_ps,s) = (p,c,[],s) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (_p,c,_bs,_s) = c + +alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) +alexGetByte (p,c,(b:bs),s) = Just (b,(p,c,bs,s)) +alexGetByte (_,_,[],[]) = Nothing +alexGetByte (p,_,[],(c:s)) = let p' = alexMove p c + (b:bs) = utf8Encode c + in p' `seq` Just (b, (p', c, bs, s)) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Token positions + +-- `Posn' records the location of a token in the input text. It has three +-- fields: the address (number of chacaters preceding the token), line number +-- and column of a token within the file. `start_pos' gives the position of the +-- start of the file and `eof_pos' a standard encoding for the end of file. +-- `move_pos' calculates the new position after traversing a given character, +-- assuming the usual eight character tab stops. + + +data AlexPosn = AlexPn !Int !Int !Int + deriving (Eq,Show) + +alexStartPos :: AlexPosn +alexStartPos = AlexPn 0 1 1 + +alexMove :: AlexPosn -> Char -> AlexPosn +alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+alex_tab_size-1) `div` alex_tab_size)*alex_tab_size+1) +alexMove (AlexPn a l _) '\n' = AlexPn (a+1) (l+1) 1 +alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) + + +-- ----------------------------------------------------------------------------- +-- Default monad + + +data AlexState = AlexState { + alex_pos :: !AlexPosn, -- position at current input location + alex_inp :: String, -- the current input + alex_chr :: !Char, -- the character before the input + alex_bytes :: [Byte], + alex_scd :: !Int -- the current startcode + + , alex_ust :: AlexUserState -- AlexUserState will be defined in the user program + + } + +-- Compile with -funbox-strict-fields for best results! + +runAlex :: String -> Alex a -> Either String a +runAlex input__ (Alex f) + = case f (AlexState {alex_pos = alexStartPos, + alex_inp = input__, + alex_chr = '\n', + alex_bytes = [], + + alex_ust = alexInitUserState, + + alex_scd = 0}) of Left msg -> Left msg + Right ( _, a ) -> Right a + +newtype Alex a = Alex { unAlex :: AlexState -> Either String (AlexState, a) } + +instance Functor Alex where + fmap f a = Alex $ \s -> case unAlex a s of + Left msg -> Left msg + Right (s', a') -> Right (s', f a') + +instance Applicative Alex where + pure a = Alex $ \s -> Right (s, a) + fa <*> a = Alex $ \s -> case unAlex fa s of + Left msg -> Left msg + Right (s', f) -> case unAlex a s' of + Left msg -> Left msg + Right (s'', b) -> Right (s'', f b) + +instance Monad Alex where + m >>= k = Alex $ \s -> case unAlex m s of + Left msg -> Left msg + Right (s',a) -> unAlex (k a) s' + return = App.pure + +alexGetInput :: Alex AlexInput +alexGetInput + = Alex $ \s@AlexState{alex_pos=pos,alex_chr=c,alex_bytes=bs,alex_inp=inp__} -> + Right (s, (pos,c,bs,inp__)) + +alexSetInput :: AlexInput -> Alex () +alexSetInput (pos,c,bs,inp__) + = Alex $ \s -> case s{alex_pos=pos,alex_chr=c,alex_bytes=bs,alex_inp=inp__} of + state__@(AlexState{}) -> Right (state__, ()) + +alexError :: String -> Alex a +alexError message = Alex $ const $ Left message + +alexGetStartCode :: Alex Int +alexGetStartCode = Alex $ \s@AlexState{alex_scd=sc} -> Right (s, sc) + +alexSetStartCode :: Int -> Alex () +alexSetStartCode sc = Alex $ \s -> Right (s{alex_scd=sc}, ()) + + +alexGetUserState :: Alex AlexUserState +alexGetUserState = Alex $ \s@AlexState{alex_ust=ust} -> Right (s,ust) + +alexSetUserState :: AlexUserState -> Alex () +alexSetUserState ss = Alex $ \s -> Right (s{alex_ust=ss}, ()) + + +alexMonadScan = do + inp__ <- alexGetInput + sc <- alexGetStartCode + case alexScan inp__ sc of + AlexEOF -> alexEOF + AlexError ((AlexPn _ line column),_,_,_) -> alexError $ "lexical error at line " ++ (show line) ++ ", column " ++ (show column) + AlexSkip inp__' _len -> do + alexSetInput inp__' + alexMonadScan + AlexToken inp__' len action -> do + alexSetInput inp__' + action (ignorePendingBytes inp__) len + +-- ----------------------------------------------------------------------------- +-- Useful token actions + +type AlexAction result = AlexInput -> Int -> Alex result + +-- just ignore this token and scan another one +-- skip :: AlexAction result +skip _input _len = alexMonadScan + +-- ignore this token, but set the start code to a new value +-- begin :: Int -> AlexAction result +begin code _input _len = do alexSetStartCode code; alexMonadScan + +-- perform an action for this token, and set the start code to a new value +andBegin :: AlexAction result -> Int -> AlexAction result +(action `andBegin` code) input__ len = do + alexSetStartCode code + action input__ len + +token :: (AlexInput -> Int -> token) -> AlexAction token +token t input__ len = return (t input__ len) + + + +-- ----------------------------------------------------------------------------- +-- Monad (with ByteString input) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper, ByteString version + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper + +-- Adds text positions to the basic model. + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper, ByteString version + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- GScan wrapper + +-- For compatibility with previous versions of Alex, and because we can. + + + + + + + + + + + + + + diff --git a/data/AlexWrapper-monadUserState-bytestring b/data/AlexWrapper-monadUserState-bytestring new file mode 100644 --- /dev/null +++ b/data/AlexWrapper-monadUserState-bytestring @@ -0,0 +1,493 @@ +{-# LINE 1 "templates/wrappers.hs" #-} +-- ----------------------------------------------------------------------------- +-- Alex wrapper code. +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + + +import Control.Applicative as App (Applicative (..)) +import qualified Control.Monad (ap) + + +import Data.Word (Word8) + + +import Data.Int (Int64) +import qualified Data.Char +import qualified Data.ByteString.Lazy as ByteString +import qualified Data.ByteString.Internal as ByteString (w2c) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +type Byte = Word8 + +-- ----------------------------------------------------------------------------- +-- The input type + + + + + + + + + + + + + + + + + + + + + + +type AlexInput = (AlexPosn, -- current position, + Char, -- previous char + ByteString.ByteString, -- current input string + Int64) -- bytes consumed so far + +ignorePendingBytes :: AlexInput -> AlexInput +ignorePendingBytes i = i -- no pending bytes when lexing bytestrings + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (_,c,_,_) = c + +alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) +alexGetByte (p,_,cs,n) = + case ByteString.uncons cs of + Nothing -> Nothing + Just (b, cs') -> + let c = ByteString.w2c b + p' = alexMove p c + n' = n+1 + in p' `seq` cs' `seq` n' `seq` Just (b, (p', c, cs',n')) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Token positions + +-- `Posn' records the location of a token in the input text. It has three +-- fields: the address (number of chacaters preceding the token), line number +-- and column of a token within the file. `start_pos' gives the position of the +-- start of the file and `eof_pos' a standard encoding for the end of file. +-- `move_pos' calculates the new position after traversing a given character, +-- assuming the usual eight character tab stops. + + +data AlexPosn = AlexPn !Int !Int !Int + deriving (Eq,Show) + +alexStartPos :: AlexPosn +alexStartPos = AlexPn 0 1 1 + +alexMove :: AlexPosn -> Char -> AlexPosn +alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+alex_tab_size-1) `div` alex_tab_size)*alex_tab_size+1) +alexMove (AlexPn a l _) '\n' = AlexPn (a+1) (l+1) 1 +alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) + + +-- ----------------------------------------------------------------------------- +-- Default monad + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Monad (with ByteString input) + + +data AlexState = AlexState { + alex_pos :: !AlexPosn, -- position at current input location + alex_bpos:: !Int64, -- bytes consumed so far + alex_inp :: ByteString.ByteString, -- the current input + alex_chr :: !Char, -- the character before the input + alex_scd :: !Int -- the current startcode + + , alex_ust :: AlexUserState -- AlexUserState will be defined in the user program + + } + +-- Compile with -funbox-strict-fields for best results! + +runAlex :: ByteString.ByteString -> Alex a -> Either String a +runAlex input__ (Alex f) + = case f (AlexState {alex_pos = alexStartPos, + alex_bpos = 0, + alex_inp = input__, + alex_chr = '\n', + + alex_ust = alexInitUserState, + + alex_scd = 0}) of Left msg -> Left msg + Right ( _, a ) -> Right a + +newtype Alex a = Alex { unAlex :: AlexState -> Either String (AlexState, a) } + +instance Functor Alex where + fmap f m = do x <- m; return (f x) + +instance Applicative Alex where + pure a = Alex $ \s -> Right (s,a) + (<*>) = Control.Monad.ap + +instance Monad Alex where + m >>= k = Alex $ \s -> case unAlex m s of + Left msg -> Left msg + Right (s',a) -> unAlex (k a) s' + return = App.pure + +alexGetInput :: Alex AlexInput +alexGetInput + = Alex $ \s@AlexState{alex_pos=pos,alex_bpos=bpos,alex_chr=c,alex_inp=inp__} -> + Right (s, (pos,c,inp__,bpos)) + +alexSetInput :: AlexInput -> Alex () +alexSetInput (pos,c,inp__,bpos) + = Alex $ \s -> case s{alex_pos=pos, + alex_bpos=bpos, + alex_chr=c, + alex_inp=inp__} of + state__@(AlexState{}) -> Right (state__, ()) + +alexError :: String -> Alex a +alexError message = Alex $ const $ Left message + +alexGetStartCode :: Alex Int +alexGetStartCode = Alex $ \s@AlexState{alex_scd=sc} -> Right (s, sc) + +alexSetStartCode :: Int -> Alex () +alexSetStartCode sc = Alex $ \s -> Right (s{alex_scd=sc}, ()) + +alexMonadScan = do + inp__@(_,_,_,n) <- alexGetInput + sc <- alexGetStartCode + case alexScan inp__ sc of + AlexEOF -> alexEOF + AlexError ((AlexPn _ line column),_,_,_) -> alexError $ "lexical error at line " ++ (show line) ++ ", column " ++ (show column) + AlexSkip inp__' _len -> do + alexSetInput inp__' + alexMonadScan + AlexToken inp__'@(_,_,_,n') _ action -> do + alexSetInput inp__' + action (ignorePendingBytes inp__) len + where + len = n'-n + +-- ----------------------------------------------------------------------------- +-- Useful token actions + +type AlexAction result = AlexInput -> Int64 -> Alex result + +-- just ignore this token and scan another one +-- skip :: AlexAction result +skip _input _len = alexMonadScan + +-- ignore this token, but set the start code to a new value +-- begin :: Int -> AlexAction result +begin code _input _len = do alexSetStartCode code; alexMonadScan + +-- perform an action for this token, and set the start code to a new value +andBegin :: AlexAction result -> Int -> AlexAction result +(action `andBegin` code) input__ len = do + alexSetStartCode code + action input__ len + +token :: (AlexInput -> Int64 -> token) -> AlexAction token +token t input__ len = return (t input__ len) + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper, ByteString version + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper + +-- Adds text positions to the basic model. + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper, ByteString version + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- GScan wrapper + +-- For compatibility with previous versions of Alex, and because we can. + + + + + + + + + + + + + + diff --git a/data/AlexWrapper-posn b/data/AlexWrapper-posn new file mode 100644 --- /dev/null +++ b/data/AlexWrapper-posn @@ -0,0 +1,493 @@ +{-# LINE 1 "templates/wrappers.hs" #-} +-- ----------------------------------------------------------------------------- +-- Alex wrapper code. +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + + + + + + +import Data.Word (Word8) + + + + + + + + + + + + + + + + +import Data.Char (ord) +import qualified Data.Bits + +-- | Encode a Haskell String to a list of Word8 values, in UTF8 format. +utf8Encode :: Char -> [Word8] +utf8Encode = map fromIntegral . go . ord + where + go oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) + , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + + +type Byte = Word8 + +-- ----------------------------------------------------------------------------- +-- The input type + + +type AlexInput = (AlexPosn, -- current position, + Char, -- previous char + [Byte], -- pending bytes on current char + String) -- current input string + +ignorePendingBytes :: AlexInput -> AlexInput +ignorePendingBytes (p,c,_ps,s) = (p,c,[],s) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (_p,c,_bs,_s) = c + +alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) +alexGetByte (p,c,(b:bs),s) = Just (b,(p,c,bs,s)) +alexGetByte (_,_,[],[]) = Nothing +alexGetByte (p,_,[],(c:s)) = let p' = alexMove p c + (b:bs) = utf8Encode c + in p' `seq` Just (b, (p', c, bs, s)) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Token positions + +-- `Posn' records the location of a token in the input text. It has three +-- fields: the address (number of chacaters preceding the token), line number +-- and column of a token within the file. `start_pos' gives the position of the +-- start of the file and `eof_pos' a standard encoding for the end of file. +-- `move_pos' calculates the new position after traversing a given character, +-- assuming the usual eight character tab stops. + + +data AlexPosn = AlexPn !Int !Int !Int + deriving (Eq,Show) + +alexStartPos :: AlexPosn +alexStartPos = AlexPn 0 1 1 + +alexMove :: AlexPosn -> Char -> AlexPosn +alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+alex_tab_size-1) `div` alex_tab_size)*alex_tab_size+1) +alexMove (AlexPn a l _) '\n' = AlexPn (a+1) (l+1) 1 +alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) + + +-- ----------------------------------------------------------------------------- +-- Default monad + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Monad (with ByteString input) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper, ByteString version + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper + +-- Adds text positions to the basic model. + + +--alexScanTokens :: String -> [token] +alexScanTokens str0 = go (alexStartPos,'\n',[],str0) + where go inp__@(pos,_,_,str) = + case alexScan inp__ 0 of + AlexEOF -> [] + AlexError ((AlexPn _ line column),_,_,_) -> error $ "lexical error at line " ++ (show line) ++ ", column " ++ (show column) + AlexSkip inp__' _ln -> go inp__' + AlexToken inp__' len act -> act pos (take len str) : go inp__' + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper, ByteString version + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- GScan wrapper + +-- For compatibility with previous versions of Alex, and because we can. + + + + + + + + + + + + + + diff --git a/data/AlexWrapper-posn-bytestring b/data/AlexWrapper-posn-bytestring new file mode 100644 --- /dev/null +++ b/data/AlexWrapper-posn-bytestring @@ -0,0 +1,493 @@ +{-# LINE 1 "templates/wrappers.hs" #-} +-- ----------------------------------------------------------------------------- +-- Alex wrapper code. +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + + + + + + +import Data.Word (Word8) + + +import Data.Int (Int64) +import qualified Data.Char +import qualified Data.ByteString.Lazy as ByteString +import qualified Data.ByteString.Internal as ByteString (w2c) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +type Byte = Word8 + +-- ----------------------------------------------------------------------------- +-- The input type + + + + + + + + + + + + + + + + + + + + + + +type AlexInput = (AlexPosn, -- current position, + Char, -- previous char + ByteString.ByteString, -- current input string + Int64) -- bytes consumed so far + +ignorePendingBytes :: AlexInput -> AlexInput +ignorePendingBytes i = i -- no pending bytes when lexing bytestrings + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (_,c,_,_) = c + +alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) +alexGetByte (p,_,cs,n) = + case ByteString.uncons cs of + Nothing -> Nothing + Just (b, cs') -> + let c = ByteString.w2c b + p' = alexMove p c + n' = n+1 + in p' `seq` cs' `seq` n' `seq` Just (b, (p', c, cs',n')) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Token positions + +-- `Posn' records the location of a token in the input text. It has three +-- fields: the address (number of chacaters preceding the token), line number +-- and column of a token within the file. `start_pos' gives the position of the +-- start of the file and `eof_pos' a standard encoding for the end of file. +-- `move_pos' calculates the new position after traversing a given character, +-- assuming the usual eight character tab stops. + + +data AlexPosn = AlexPn !Int !Int !Int + deriving (Eq,Show) + +alexStartPos :: AlexPosn +alexStartPos = AlexPn 0 1 1 + +alexMove :: AlexPosn -> Char -> AlexPosn +alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+alex_tab_size-1) `div` alex_tab_size)*alex_tab_size+1) +alexMove (AlexPn a l _) '\n' = AlexPn (a+1) (l+1) 1 +alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) + + +-- ----------------------------------------------------------------------------- +-- Default monad + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Monad (with ByteString input) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper, ByteString version + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper + +-- Adds text positions to the basic model. + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper, ByteString version + + +--alexScanTokens :: ByteString.ByteString -> [token] +alexScanTokens str0 = go (alexStartPos,'\n',str0,0) + where go inp__@(pos,_,str,n) = + case alexScan inp__ 0 of + AlexEOF -> [] + AlexError ((AlexPn _ line column),_,_,_) -> error $ "lexical error at line " ++ (show line) ++ ", column " ++ (show column) + AlexSkip inp__' _len -> go inp__' + AlexToken inp__'@(_,_,_,n') _ act -> + act pos (ByteString.take (n'-n) str) : go inp__' + + + +-- ----------------------------------------------------------------------------- +-- GScan wrapper + +-- For compatibility with previous versions of Alex, and because we can. + + + + + + + + + + + + + + diff --git a/data/AlexWrapper-strict-bytestring b/data/AlexWrapper-strict-bytestring new file mode 100644 --- /dev/null +++ b/data/AlexWrapper-strict-bytestring @@ -0,0 +1,493 @@ +{-# LINE 1 "templates/wrappers.hs" #-} +-- ----------------------------------------------------------------------------- +-- Alex wrapper code. +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + + + + + + +import Data.Word (Word8) + + + + + + + + + +import qualified Data.Char +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Internal as ByteString hiding (ByteString) +import qualified Data.ByteString.Unsafe as ByteString + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +type Byte = Word8 + +-- ----------------------------------------------------------------------------- +-- The input type + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +data AlexInput = AlexInput { alexChar :: {-# UNPACK #-} !Char, + alexStr :: {-# UNPACK #-} !ByteString.ByteString, + alexBytePos :: {-# UNPACK #-} !Int} + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar = alexChar + +alexGetByte (AlexInput {alexStr=cs,alexBytePos=n}) = + case ByteString.uncons cs of + Nothing -> Nothing + Just (c, rest) -> + Just (c, AlexInput { + alexChar = ByteString.w2c c, + alexStr = rest, + alexBytePos = n+1}) + + +-- ----------------------------------------------------------------------------- +-- Token positions + +-- `Posn' records the location of a token in the input text. It has three +-- fields: the address (number of chacaters preceding the token), line number +-- and column of a token within the file. `start_pos' gives the position of the +-- start of the file and `eof_pos' a standard encoding for the end of file. +-- `move_pos' calculates the new position after traversing a given character, +-- assuming the usual eight character tab stops. + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Default monad + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Monad (with ByteString input) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper + + + + + + + + + + + + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper, ByteString version + + + + + + + + + + + + + + + + + + +-- alexScanTokens :: ByteString.ByteString -> [token] +alexScanTokens str = go (AlexInput '\n' str 0) + where go inp__ = + case alexScan inp__ 0 of + AlexEOF -> [] + AlexError _ -> error "lexical error" + AlexSkip inp__' _len -> go inp__' + AlexToken inp__' _ act -> + let len = alexBytePos inp__' - alexBytePos inp__ in + act (ByteString.take len (alexStr inp__)) : go inp__' + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper + +-- Adds text positions to the basic model. + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper, ByteString version + + + + + + + + + + + + + + +-- ----------------------------------------------------------------------------- +-- GScan wrapper + +-- For compatibility with previous versions of Alex, and because we can. + + + + + + + + + + + + + + diff --git a/src/Data/Ranged/Boundaries.hs b/src/Data/Ranged/Boundaries.hs --- a/src/Data/Ranged/Boundaries.hs +++ b/src/Data/Ranged/Boundaries.hs @@ -19,9 +19,8 @@ (/>/) ) where -import Data.Ratio -import Data.Word -import Test.QuickCheck +import Data.Ratio +import Data.Word infix 4 />/ @@ -168,10 +167,10 @@ -- | True if the value is above the boundary, false otherwise. above :: Ord v => Boundary v -> v -> Bool -above (BoundaryAbove b) v = v > b -above (BoundaryBelow b) v = v >= b -above BoundaryAboveAll _ = False -above BoundaryBelowAll _ = True +above (BoundaryAbove b) v = v > b +above (BoundaryBelow b) v = v >= b +above BoundaryAboveAll _ = False +above BoundaryBelowAll _ = True -- | Same as 'above', but with the arguments reversed for more intuitive infix -- usage. @@ -210,26 +209,8 @@ BoundaryAboveAll -> case boundary2 of BoundaryAboveAll -> EQ - _ -> GT + _ -> GT BoundaryBelowAll -> case boundary2 of BoundaryBelowAll -> EQ - _ -> LT - --- QuickCheck Generator - -instance Arbitrary a => Arbitrary (Boundary a) where - arbitrary = frequency [ - (1, return BoundaryAboveAll), - (1, return BoundaryBelowAll), - (18, do - v <- arbitrary - oneof [return $ BoundaryAbove v, return $ BoundaryBelow v] - )] - -instance CoArbitrary a => CoArbitrary (Boundary a) where - coarbitrary BoundaryBelowAll = variant (0 :: Int) - coarbitrary BoundaryAboveAll = variant (1 :: Int) - coarbitrary (BoundaryBelow v) = variant (2 :: Int) . coarbitrary v - coarbitrary (BoundaryAbove v) = variant (3 :: Int) . coarbitrary v - + _ -> LT diff --git a/src/Data/Ranged/RangedSet.hs b/src/Data/Ranged/RangedSet.hs --- a/src/Data/Ranged/RangedSet.hs +++ b/src/Data/Ranged/RangedSet.hs @@ -23,37 +23,6 @@ -- ** Useful Sets rSetEmpty, rSetFull, - -- ** QuickCheck Properties - -- *** Construction - prop_validNormalised, - prop_has, - prop_unfold, - -- *** Basic Operations - prop_union, - prop_intersection, - prop_difference, - prop_negation, - prop_not_empty, - -- *** Some Identities and Inequalities - -- $ConstructionProperties - -- $BasicOperationProperties - -- $SomeIdentitiesAndInequalities - prop_empty, - prop_full, - prop_empty_intersection, - prop_full_union, - prop_union_superset, - prop_intersection_subset, - prop_diff_intersect, - prop_subset, - prop_strict_subset, - prop_union_strict_superset, - prop_intersection_commutes, - prop_union_commutes, - prop_intersection_associates, - prop_union_associates, - prop_de_morgan_intersection, - prop_de_morgan_union, ) where import Data.Ranged.Boundaries @@ -65,7 +34,6 @@ #endif import Data.List -import Test.QuickCheck infixl 7 -/\- infixl 6 -\/-, -!- @@ -256,244 +224,3 @@ : case succFunc b of Just b2 -> ranges1 b2 Nothing -> [] - - --- QuickCheck Generators - -instance (Arbitrary v, DiscreteOrdered v) => - Arbitrary (RSet v) - where - arbitrary = frequency [ - (1, return rSetEmpty), - (1, return rSetFull), - (18, do - ls <- arbitrary - return $ makeRangedSet $ rangeList $ sort ls - )] - where - -- Arbitrary lists of ranges don't give many interesting sets after - -- normalisation. So instead generate a sorted list of boundaries - -- and pair them off. Odd boundaries are dropped. - rangeList (b1:b2:bs) = Range b1 b2 : rangeList bs - rangeList _ = [] - -instance (CoArbitrary v, DiscreteOrdered v) => - CoArbitrary (RSet v) - where - coarbitrary (RSet ls) = variant (0 :: Int) . coarbitrary ls - --- ================================================================== --- QuickCheck Properties --- ================================================================== - ---------------------------------------------------------------------- --- Construction properties ---------------------------------------------------------------------- - --- | A normalised range list is valid for unsafeRangedSet --- --- > prop_validNormalised ls = validRangeList $ normaliseRangeList ls -prop_validNormalised :: (DiscreteOrdered a) => [Range a] -> Bool -prop_validNormalised ls = validRangeList $ normaliseRangeList ls - - --- | Iff a value is in a range list then it is in a ranged set --- constructed from that list. --- --- > prop_has ls v = (ls `rangeListHas` v) == makeRangedSet ls -?- v -prop_has :: (DiscreteOrdered a) => [Range a] -> a -> Bool -prop_has ls v = (ls `rangeListHas` v) == makeRangedSet ls -?- v - - --- | Verifies the correct membership of a set containing all integers --- starting with the digit \"1\" up to 19999. --- --- > prop_unfold = (v <= 99999 && head (show v) == '1') == (initial1 -?- v) --- > where --- > initial1 = rSetUnfold (BoundaryBelow 1) addNines times10 --- > addNines (BoundaryBelow n) = BoundaryAbove $ n * 2 - 1 --- > times10 (BoundaryBelow n) = --- > if n <= 1000 then Just $ BoundaryBelow $ n * 10 else Nothing - -prop_unfold :: Integer -> Bool -prop_unfold v = (v <= 99999 && head (show v) == '1') == (initial1 -?- v) - where - initial1 = rSetUnfold (BoundaryBelow 1) addNines times10 - addNines (BoundaryBelow n) = BoundaryAbove $ n * 2 - 1 - addNines _ = error "Can't happen" - times10 (BoundaryBelow n) = - if n <= 10000 then Just $ BoundaryBelow $ n * 10 else Nothing - times10 _ = error "Can't happen" - ---------------------------------------------------------------------- --- Basic operation properties ---------------------------------------------------------------------- - --- | Iff a value is in either of two ranged sets then it is in the union of --- those two sets. --- --- > prop_union rs1 rs2 v = --- > (rs1 -?- v || rs2 -?- v) == ((rs1 -\/- rs2) -?- v) -prop_union :: (DiscreteOrdered a ) => RSet a -> RSet a -> a -> Bool -prop_union rs1 rs2 v = (rs1 -?- v || rs2 -?- v) == ((rs1 -\/- rs2) -?- v) - --- | Iff a value is in both of two ranged sets then it is n the intersection --- of those two sets. --- --- > prop_intersection rs1 rs2 v = --- > (rs1 -?- v && rs2 -?- v) == ((rs1 -/\- rs2) -?- v) -prop_intersection :: (DiscreteOrdered a) => RSet a -> RSet a -> a -> Bool -prop_intersection rs1 rs2 v = - (rs1 -?- v && rs2 -?- v) == ((rs1 -/\- rs2) -?- v) - --- | Iff a value is in ranged set 1 and not in ranged set 2 then it is in the --- difference of the two. --- --- > prop_difference rs1 rs2 v = --- > (rs1 -?- v && not (rs2 -?- v)) == ((rs1 -!- rs2) -?- v) -prop_difference :: (DiscreteOrdered a) => RSet a -> RSet a -> a -> Bool -prop_difference rs1 rs2 v = - (rs1 -?- v && not (rs2 -?- v)) == ((rs1 -!- rs2) -?- v) - --- | Iff a value is not in a ranged set then it is in its negation. --- --- > prop_negation rs v = rs -?- v == not (rSetNegation rs -?- v) -prop_negation :: (DiscreteOrdered a) => RSet a -> a -> Bool -prop_negation rs v = rs -?- v == not (rSetNegation rs -?- v) - --- | A set that contains a value is not empty --- --- > prop_not_empty rs v = (rs -?- v) ==> not (rSetIsEmpty rs) -prop_not_empty :: (DiscreteOrdered a) => RSet a -> a -> Property -prop_not_empty rs v = (rs -?- v) ==> not (rSetIsEmpty rs) - ---------------------------------------------------------------------- --- Some identities and inequalities of sets ---------------------------------------------------------------------- - --- | The empty set has no members. --- --- > prop_empty v = not (rSetEmpty -?- v) -prop_empty :: (DiscreteOrdered a) => a -> Bool -prop_empty v = not (rSetEmpty -?- v) - --- | The full set has every member. --- --- > prop_full v = rSetFull -?- v -prop_full :: (DiscreteOrdered a) => a -> Bool -prop_full v = rSetFull -?- v - --- | The intersection of a set with its negation is empty. --- --- > prop_empty_intersection rs = --- > rSetIsEmpty (rs -/\- rSetNegation rs) -prop_empty_intersection :: (DiscreteOrdered a) => RSet a -> Bool -prop_empty_intersection rs = - rSetIsEmpty (rs -/\- rSetNegation rs) - --- | The union of a set with its negation is full. --- --- > prop_full_union rs v = --- > rSetIsFull (rs -\/- rSetNegation rs) -prop_full_union :: (DiscreteOrdered a) => RSet a -> Bool -prop_full_union rs = - rSetIsFull (rs -\/- rSetNegation rs) - --- | The union of two sets is the non-strict superset of both. --- --- > prop_union_superset rs1 rs2 = --- > rs1 -<=- u && rs2 -<=- u --- > where --- > u = rs1 -\/- rs2 -prop_union_superset :: (DiscreteOrdered a) => RSet a -> RSet a -> Bool -prop_union_superset rs1 rs2 = - rs1 -<=- u && rs2 -<=- u - where - u = rs1 -\/- rs2 - --- | The intersection of two sets is the non-strict subset of both. --- --- > prop_intersection_subset rs1 rs2 = --- > i -<=- rs1 && i -<=- rs2 --- > where --- > i = rs1 -/\- rs2 -prop_intersection_subset :: (DiscreteOrdered a) => RSet a -> RSet a -> Bool -prop_intersection_subset rs1 rs2 = i -<=- rs1 && i -<=- rs2 - where - i = rs1 -/\- rs2 - --- | The difference of two sets intersected with the subtractand is empty. --- --- > prop_diff_intersect rs1 rs2 = --- > rSetIsEmpty ((rs1 -!- rs2) -/\- rs2) -prop_diff_intersect :: (DiscreteOrdered a) => RSet a -> RSet a -> Bool -prop_diff_intersect rs1 rs2 = rSetIsEmpty ((rs1 -!- rs2) -/\- rs2) - --- | A set is the non-strict subset of itself. --- --- > prop_subset rs = rs -<=- rs -prop_subset :: (DiscreteOrdered a) => RSet a -> Bool -prop_subset rs = rs -<=- rs - --- | A set is not the strict subset of itself. --- --- > prop_strict_subset rs = not (rs -<- rs) -prop_strict_subset :: (DiscreteOrdered a) => RSet a -> Bool -prop_strict_subset rs = not (rs -<- rs) - --- | If rs1 - rs2 is not empty then the union of rs1 and rs2 will be a strict --- superset of rs2. --- --- > prop_union_strict_superset rs1 rs2 = --- > (not $ rSetIsEmpty (rs1 -!- rs2)) --- > ==> (rs2 -<- (rs1 -\/- rs2)) -prop_union_strict_superset :: (DiscreteOrdered a) => RSet a -> RSet a -> Property -prop_union_strict_superset rs1 rs2 = - (not $ rSetIsEmpty (rs1 -!- rs2)) ==> (rs2 -<- (rs1 -\/- rs2)) - --- | Intersection commutes. --- --- > prop_intersection_commutes rs1 rs2 = (rs1 -/\- rs2) == (rs2 -/\- rs1) -prop_intersection_commutes :: (DiscreteOrdered a) => RSet a -> RSet a -> Bool -prop_intersection_commutes rs1 rs2 = (rs1 -/\- rs2) == (rs2 -/\- rs1) - --- | Union commutes. --- --- > prop_union_commutes rs1 rs2 = (rs1 -\/- rs2) == (rs2 -\/- rs1) -prop_union_commutes :: (DiscreteOrdered a) => RSet a -> RSet a -> Bool -prop_union_commutes rs1 rs2 = (rs1 -\/- rs2) == (rs2 -\/- rs1) - --- | Intersection associates. --- --- > prop_intersection_associates rs1 rs2 rs3 = --- > ((rs1 -/\- rs2) -/\- rs3) == (rs1 -/\- (rs2 -/\- rs3)) -prop_intersection_associates :: (DiscreteOrdered a) => - RSet a -> RSet a -> RSet a -> Bool -prop_intersection_associates rs1 rs2 rs3 = - ((rs1 -/\- rs2) -/\- rs3) == (rs1 -/\- (rs2 -/\- rs3)) - --- | Union associates. --- --- > prop_union_associates rs1 rs2 rs3 = --- > ((rs1 -\/- rs2) -\/- rs3) == (rs1 -\/- (rs2 -\/- rs3)) -prop_union_associates :: (DiscreteOrdered a) => - RSet a -> RSet a -> RSet a -> Bool -prop_union_associates rs1 rs2 rs3 = - ((rs1 -\/- rs2) -\/- rs3) == (rs1 -\/- (rs2 -\/- rs3)) - --- | De Morgan's Law for Intersection. --- --- > prop_de_morgan_intersection rs1 rs2 = --- > rSetNegation (rs1 -/\- rs2) == (rSetNegation rs1 -\/- rSetNegation rs2) -prop_de_morgan_intersection :: (DiscreteOrdered a) => RSet a -> RSet a -> Bool -prop_de_morgan_intersection rs1 rs2 = - rSetNegation (rs1 -/\- rs2) == (rSetNegation rs1 -\/- rSetNegation rs2) - --- | De Morgan's Law for Union. --- --- > prop_de_morgan_union rs1 rs2 = --- > rSetNegation (rs1 -\/- rs2) == (rSetNegation rs1 -/\- rSetNegation rs2) - -prop_de_morgan_union :: (DiscreteOrdered a) => RSet a -> RSet a -> Bool -prop_de_morgan_union rs1 rs2 = - rSetNegation (rs1 -\/- rs2) == (rSetNegation rs1 -/\- rSetNegation rs2) diff --git a/src/Data/Ranged/Ranges.hs b/src/Data/Ranged/Ranges.hs --- a/src/Data/Ranged/Ranges.hs +++ b/src/Data/Ranged/Ranges.hs @@ -29,26 +29,9 @@ rangeIntersection, rangeUnion, rangeDifference, - -- ** QuickCheck properties - prop_unionRange, - prop_unionRangeLength, - prop_intersectionRange, - prop_differenceRange, - prop_intersectionOverlap, - prop_enclosureUnion, - prop_singletonRangeHas, - prop_singletonRangeHasOnly, - prop_singletonRangeConverse, - prop_emptyNonSingleton, - prop_fullNonSingleton, - prop_nonSingleton, - prop_intSingleton ) where -import Control.Monad -import Data.Ranged.Boundaries -import Data.Maybe -import Test.QuickCheck +import Data.Ranged.Boundaries -- | A Range has upper and lower boundaries. data Range v = Range {rangeLower, rangeUpper :: Boundary v} @@ -211,150 +194,3 @@ [r1] where intersects = (max lower1 lower2) < (min upper1 upper2) - - --- QuickCheck generators - -instance (Arbitrary v, DiscreteOrdered v) => - Arbitrary (Range v) where - - arbitrary = frequency [ - (17, do -- Ordinary range - b1 <- arbitrary - b2 <- arbitrary - if b1 < b2 - then return $ Range b1 b2 - else return $ Range b2 b1 - ), - (1, do -- Singleton range - v <- arbitrary - return $ singletonRange v - ), - (1, return emptyRange), - (1, return fullRange) - ] - -instance (CoArbitrary v, DiscreteOrdered v) => - CoArbitrary (Range v) where - - coarbitrary (Range lower upper) = - variant (0 :: Int) . coarbitrary lower . coarbitrary upper - - - --- QuickCheck Properties - --- | The union of two ranges has a value iff either range has it. --- --- > prop_unionRange r1 r2 n = --- > (r1 `rangeHas` n || r2 `rangeHas` n) --- > == (r1 `rangeUnion` r2) `rangeListHas` n -prop_unionRange :: (DiscreteOrdered a) => Range a -> Range a -> a -> Bool -prop_unionRange r1 r2 n = - (r1 `rangeHas` n || r2 `rangeHas` n) - == (r1 `rangeUnion` r2) `rangeListHas` n - --- | The union of two ranges always contains one or two ranges. --- --- > prop_unionRangeLength r1 r2 = (n == 1) || (n == 2) --- > where n = length $ rangeUnion r1 r2 -prop_unionRangeLength :: (DiscreteOrdered a) => Range a -> Range a -> Bool -prop_unionRangeLength r1 r2 = (n == 1) || (n == 2) - where n = length $ rangeUnion r1 r2 - --- | The intersection of two ranges has a value iff both ranges have it. --- --- > prop_intersectionRange r1 r2 n = --- > (r1 `rangeHas` n && r2 `rangeHas` n) --- > == (r1 `rangeIntersection` r2) `rangeHas` n -prop_intersectionRange :: (DiscreteOrdered a) => Range a -> Range a -> a -> Bool -prop_intersectionRange r1 r2 n = - (r1 `rangeHas` n && r2 `rangeHas` n) - == (r1 `rangeIntersection` r2) `rangeHas` n - --- | The difference of two ranges has a value iff the first range has it and --- the second does not. --- --- > prop_differenceRange r1 r2 n = --- > (r1 `rangeHas` n && not (r2 `rangeHas` n)) --- > == (r1 `rangeDifference` r2) `rangeListHas` n -prop_differenceRange :: (DiscreteOrdered a) => Range a -> Range a -> a -> Bool -prop_differenceRange r1 r2 n = - (r1 `rangeHas` n && not (r2 `rangeHas` n)) - == (r1 `rangeDifference` r2) `rangeListHas` n - --- | Iff two ranges overlap then their intersection is non-empty. --- --- > prop_intersectionOverlap r1 r2 = --- > (rangeIsEmpty $ rangeIntersection r1 r2) == (rangeOverlap r1 r2) -prop_intersectionOverlap :: (DiscreteOrdered a) => Range a -> Range a -> Bool -prop_intersectionOverlap r1 r2 = - (rangeIsEmpty $ rangeIntersection r1 r2) == not (rangeOverlap r1 r2) - --- | Range enclosure makes union an identity function. --- --- > prop_enclosureUnion r1 r2 = --- > rangeEncloses r1 r2 == (rangeUnion r1 r2 == [r1]) -prop_enclosureUnion :: (DiscreteOrdered a) => Range a -> Range a -> Bool -prop_enclosureUnion r1 r2 = rangeEncloses r1 r2 == (rangeUnion r1 r2 == [r1]) - --- | Range Singleton has its member. --- --- > prop_singletonRangeHas v = singletonRange v `rangeHas` v -prop_singletonRangeHas :: (DiscreteOrdered a) => a -> Bool -prop_singletonRangeHas v = singletonRange v `rangeHas` v - --- | Range Singleton has only its member. --- --- > prop_singletonHasOnly v1 v2 = --- > (v1 == v2) == (singletonRange v1 `rangeHas` v2) -prop_singletonRangeHasOnly :: (DiscreteOrdered a) => a -> a -> Bool -prop_singletonRangeHasOnly v1 v2 = - (v1 == v2) == (singletonRange v1 `rangeHas` v2) - --- | A singleton range can have its value extracted. --- --- > prop_singletonRangeConverse v = --- > rangeSingletonValue (singletonRange v) == Just v -prop_singletonRangeConverse:: (DiscreteOrdered a) => a -> Bool -prop_singletonRangeConverse v = - rangeSingletonValue (singletonRange v) == Just v - --- | The empty range is not a singleton. --- --- > prop_emptyNonSingleton = rangeSingletonValue emptyRange == Nothing -prop_emptyNonSingleton :: Bool -prop_emptyNonSingleton = - rangeSingletonValue (emptyRange :: Range Int) == Nothing - --- | The full range is not a singleton. --- --- > prop_fullNonSingleton = rangeSingletonValue fullRange == Nothing -prop_fullNonSingleton :: Bool -prop_fullNonSingleton = - rangeSingletonValue (fullRange :: Range Int) == Nothing - --- | For real x and y, @x < y@ implies that any range between them is a --- non-singleton. -prop_nonSingleton :: Double -> Double -> Property -prop_nonSingleton x y = (x < y) ==> null $ mapMaybe rangeSingletonValue rs - where rs = [ - Range (BoundaryBelow x) (BoundaryBelow y), - Range (BoundaryAbove x) (BoundaryBelow y), - Range (BoundaryBelow x) (BoundaryAbove y), - Range (BoundaryAbove x) (BoundaryAbove y)] - - --- | For all integers x and y, any range formed from boundaries on either side --- of x and y is a singleton iff it contains exactly one integer. -prop_intSingleton :: Integer -> Integer -> Property -prop_intSingleton x y = forAll (rangeAround x y) $ \r -> - case filter (rangeHas r) [x-1 .. y+1] of - [v] -> rangeSingletonValue r == Just v - _ -> rangeSingletonValue r == Nothing - where - rangeAround v1 v2 = return Range `ap` genBound v1 `ap` genBound v2 - genBound v = elements [BoundaryAbove v, BoundaryBelow v] - - - diff --git a/tests/Makefile b/tests/Makefile --- a/tests/Makefile +++ b/tests/Makefile @@ -1,4 +1,6 @@ -ALEX=../dist/build/alex/alex +# NOTE: `cabal` will take care to build the local `alex` executable and place it into $PATH for us to pick up +ALEX:=$(shell which alex) +# NOTE: This assumes that a working `ghc` is on $PATH; this may not necessarily be the same GHC used by `cabal` for building `alex`. HC=ghc HC_OPTS=-Wall -fno-warn-missing-signatures -fno-warn-unused-imports -fno-warn-tabs -Werror @@ -36,7 +38,9 @@ tokens_strict_bytestring.x \ unicode.x -TEST_ALEX_OPTS = --template=.. +# NOTE: `cabal` will set the `alex_datadir` env-var accordingly before invoking the test-suite +#TEST_ALEX_OPTS = --template=../data/ +TEST_ALEX_OPTS= %.n.hs : %.x $(ALEX) $(TEST_ALEX_OPTS) $< -o $@ @@ -62,6 +66,7 @@ clean: rm -f $(CLEAN_FILES) +# NOTE: The `../dist` path belows don't aren't accurate anymore for recent cabals interact: ghci -cpp -i../src -i../dist/build/autogen -i../dist/build/alex/alex-tmp Main -fbreak-on-exception # -args='--template=.. simple.x -o simple.n.hs'