alex-meta-0.3.0.2: src/Text/Alex/AlexTemplate.hs
{-#Language QuasiQuotes#-}
module Text.Alex.AlexTemplate where
import AbsSyn
import Text.Alex.Verbatim
alexTemplate GhcTarget = [verbatim|
-- -----------------------------------------------------------------------------
-- 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
{-# LINE 37 "templates\\GenericTemplate.hs" #-}
{-# LINE 47 "templates\\GenericTemplate.hs" #-}
data AlexAddr = AlexA# Addr#
-- Never happens
-- #if __GLASGOW_HASKELL__ < 503
-- uncheckedShiftL# = shiftL#
-- #endif
{-# INLINE alexIndexInt16OffAddr #-}
alexIndexInt16OffAddr (AlexA# arr) off = |] ++
#ifdef WORDS_BIGENDIAN
[verbatim|
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
[verbatim|
indexInt16OffAddr# arr off
|]
#endif
++ [verbatim|
{-# INLINE alexIndexInt32OffAddr #-}
alexIndexInt32OffAddr (AlexA# arr) off = |] ++
#ifdef WORDS_BIGENDIAN
[verbatim|
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
[verbatim|
indexInt32OffAddr# arr off
|]
#endif
++ [verbatim|
-- Never happens
-- #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 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) ->
let
(base) = alexIndexInt32OffAddr alex_base s
((I# (ord_c))) = fromIntegral c
(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 [] = 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))
check_accs (AlexAccSkipPred predx : rest)
| predx user orig_input (I# (len)) input
= AlexLastSkip input (I# (len))
check_accs (_ : rest) = check_accs rest
data AlexLastAcc a
= AlexNone
| AlexLastAcc a !AlexInput !Int
| AlexLastSkip !AlexInput !Int
instance Functor AlexLastAcc where
fmap f AlexNone = AlexNone
fmap f (AlexLastAcc x y z) = AlexLastAcc (f x) y z
fmap f (AlexLastSkip x y) = AlexLastSkip x y
data AlexAcc a user
= AlexAcc a
| AlexAccSkip
| AlexAccPred a (AlexAccPred user)
| AlexAccSkipPred (AlexAccPred 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.
-- used by wrappers
iUnbox (I# (i)) = i
|]
-- This code is in the PUBLIC DOMAIN; you may copy it freely and use
-- it for any purpose whatsoever.
alexTemplate _ = unlines[
"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",
"\t(AlexNone, input') ->",
"\t\tcase alexGetByte input of",
"\t\t\tNothing -> ",
"",
"",
"",
"\t\t\t\t AlexEOF",
"\t\t\tJust _ ->",
"",
"",
"",
"\t\t\t\t AlexError input'",
"",
"\t(AlexLastSkip input'' len, _) ->",
"",
"",
"",
"\t\tAlexSkip input'' len",
"",
"\t(AlexLastAcc k input''' len, _) ->",
"",
"",
"",
"\t\tAlexToken input''' len 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 ",
"\tnew_acc = (check_accs (alex_accept `quickIndex` (s)))",
" in",
" new_acc `seq`",
" case alexGetByte input of",
" Nothing -> (new_acc, input)",
" Just (c, new_input) -> ",
"",
"",
"",
"\tlet",
"\t\t(base) = alexIndexInt32OffAddr alex_base s",
"\t\t((ord_c)) = fromIntegral c",
"\t\t(offset) = (base + ord_c)",
"\t\t(check) = alexIndexInt16OffAddr alex_check offset",
"\t\t",
"\t\t(new_s) = if (offset >= (0)) && (check == ord_c)",
"\t\t\t then alexIndexInt16OffAddr alex_table offset",
"\t\t\t else alexIndexInt16OffAddr alex_deflt s",
"\tin",
"\tcase new_s of ",
"\t (-1) -> (new_acc, input)",
"\t\t-- on an error, we want to keep the input *before* the",
"\t\t-- character that failed, not after.",
" \t _ -> 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)",
"\t\t\tnew_input new_s new_acc",
"",
" where",
"\tcheck_accs [] = last_acc",
"\tcheck_accs (AlexAcc a : _) = AlexLastAcc a input (len)",
"\tcheck_accs (AlexAccSkip : _) = AlexLastSkip input (len)",
"\tcheck_accs (AlexAccPred a predx : rest)",
"\t | predx user orig_input (len) input",
"\t = AlexLastAcc a input (len)",
"\tcheck_accs (AlexAccSkipPred predx : rest)",
"\t | predx user orig_input (len) input",
"\t = AlexLastSkip input (len)",
"\tcheck_accs (_ : rest) = check_accs rest",
"",
"data AlexLastAcc a",
" = AlexNone",
" | AlexLastAcc a !AlexInput !Int",
" | AlexLastSkip !AlexInput !Int",
"",
"instance Functor AlexLastAcc where",
" fmap f AlexNone = AlexNone",
" fmap f (AlexLastAcc x y z) = AlexLastAcc (f x) y z",
" fmap f (AlexLastSkip x y) = AlexLastSkip x y",
"",
"data AlexAcc a user",
" = AlexAcc a",
" | AlexAccSkip",
" | AlexAccPred a (AlexAccPred user)",
" | AlexAccSkipPred (AlexAccPred 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",
"\t (AlexNone, _) -> False",
"\t _ -> True",
"\t-- TODO: there's no need to find the longest",
"\t-- match when checking the right context, just",
"\t-- the first match will do.",
"",
"-- used by wrappers",
"iUnbox (i) = i"
]