{-# OPTIONS -cpp #-} {-# LINE 3 "LexBNF.x" #-} {-# OPTIONS -fno-warn-incomplete-patterns #-} module Language.LBNF.LexBNF where #if __GLASGOW_HASKELL__ >= 603 #include "ghcconfig.h" #elif defined(__GLASGOW_HASKELL__) #include "config.h" #endif #if __GLASGOW_HASKELL__ >= 503 import Data.Array import Data.Char (ord) import Data.Array.Base (unsafeAt) #else import Array import Char (ord) #endif alex_base :: Array Int Int alex_base = listArray (0,30) [1,56,57,23,24,0,68,69,25,26,27,66,0,15,13,156,364,0,279,487,213,0,41,157,211,53,231,33,242,285,439] alex_table :: Array Int Int alex_table = listArray (0,742) [0,-1,-1,-1,-1,-1,-1,-1,-1,-1,11,11,11,11,11,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,11,-1,18,-1,12,-1,-1,23,12,12,12,12,12,3,12,-1,25,25,25,25,25,25,25,25,25,25,13,12,-1,12,-1,12,-1,-1,-1,1,7,7,7,8,14,12,11,11,11,11,11,21,27,27,27,27,27,27,27,27,27,27,0,12,-1,12,-1,12,-1,11,28,0,25,25,25,25,25,25,25,25,25,25,0,0,7,6,0,0,0,0,0,0,0,0,0,10,12,12,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,4,5,16,-1,0,0,0,0,0,0,0,16,16,16,16,16,16,16,16,16,16,0,0,-1,0,0,0,0,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,19,-1,24,22,16,19,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,26,26,26,26,26,26,26,26,26,26,-1,26,26,26,26,26,26,26,26,26,26,0,0,0,22,0,19,0,0,0,0,0,0,0,17,0,0,0,0,0,0,0,22,0,19,0,0,0,22,0,19,30,0,29,27,27,27,27,27,27,27,27,27,27,0,0,0,0,0,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,20,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,0,0,0,0,0,0,0,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,0,0,0,0,16,0,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,27,27,27,27,27,27,27,27,27,27,-1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,17,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,20,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,0,16,16,16,16,16,16,16,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] alex_check :: Array Int Int alex_check = listArray (0,742) [-1,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,10,10,45,45,45,45,45,58,61,9,10,11,12,13,39,48,49,50,51,52,53,54,55,56,57,-1,91,92,93,94,95,96,32,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,45,45,-1,-1,-1,-1,-1,-1,-1,-1,-1,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,125,125,39,39,-1,-1,-1,-1,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,215,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,34,247,92,39,95,39,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,48,49,50,51,52,53,54,55,56,57,10,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,92,-1,92,-1,-1,-1,-1,-1,-1,-1,34,-1,-1,-1,-1,-1,-1,-1,110,-1,110,-1,-1,-1,116,-1,116,45,-1,101,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,92,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,39,248,249,250,251,252,253,254,255,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,48,49,50,51,52,53,54,55,56,57,10,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,34,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,92,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,-1,248,249,250,251,252,253,254,255,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1] alex_deflt :: Array Int Int alex_deflt = listArray (0,30) [15,2,2,-1,9,-1,9,9,9,9,-1,-1,-1,-1,-1,-1,-1,-1,19,19,-1,-1,-1,22,-1,-1,-1,-1,-1,-1,-1] alex_accept = listArray (0::Int,30) [[],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAccSkip)],[],[],[],[],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[],[],[],[(AlexAcc (alex_action_6))],[],[],[],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_8))],[],[],[]] {-# LINE 34 "LexBNF.x" #-} tok f p s = f p s share :: String -> String share = id data Tok = TS !String -- reserved words and symbols | TL !String -- string literals | TI !String -- integer literals | TV !String -- identifiers | TD !String -- double precision float literals | TC !String -- character literals deriving (Eq,Show,Ord) data Token = PT Posn Tok | Err Posn deriving (Eq,Show,Ord) tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l tokenPos (Err (Pn _ l _) :_) = "line " ++ show l tokenPos _ = "end of file" posLineCol (Pn _ l c) = (l,c) mkPosToken t@(PT p _) = (posLineCol p, prToken t) prToken t = case t of PT _ (TS s) -> s PT _ (TI s) -> s PT _ (TV s) -> s PT _ (TD s) -> s PT _ (TC s) -> s _ -> show t data BTree = N | B String Tok BTree BTree deriving (Show) eitherResIdent :: (String -> Tok) -> String -> Tok eitherResIdent tv s = treeFind resWords where treeFind N = tv s treeFind (B a t left right) | s < a = treeFind left | s > a = treeFind right | s == a = t resWords = b "letter" (b "digit" (b "coercions" (b "char" (b "antiquote" N N) N) (b "define" (b "comment" N N) N)) (b "external" (b "eps" (b "entrypoints" N N) N) (b "layout" (b "internal" N N) N))) (b "stop" (b "position" (b "nonempty" (b "lower" N N) N) (b "separator" (b "rules" N N) N)) (b "toplevel" (b "token" (b "terminator" N N) N) (b "views" (b "upper" N N) N))) where b s = B s (TS s) unescapeInitTail :: String -> String unescapeInitTail = unesc . tail where unesc s = case s of '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs '\\':'n':cs -> '\n' : unesc cs '\\':'t':cs -> '\t' : unesc cs '"':[] -> [] c:cs -> c : unesc cs _ -> [] ------------------------------------------------------------------- -- Alex wrapper code. -- A modified "posn" wrapper. ------------------------------------------------------------------- data Posn = Pn !Int !Int !Int deriving (Eq, Show,Ord) alexStartPos :: Posn alexStartPos = Pn 0 1 1 alexMove :: Posn -> Char -> Posn alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 alexMove (Pn a l c) _ = Pn (a+1) l (c+1) type AlexInput = (Posn, -- current position, Char, -- previous char String) -- current input string tokens :: String -> [Token] tokens str = go (alexStartPos, '\n', str) where go :: (Posn, Char, String) -> [Token] go inp@(pos, _, str) = case alexScan inp 0 of AlexEOF -> [] AlexError (pos, _, _) -> [Err pos] AlexSkip inp' len -> go inp' AlexToken inp' len act -> act pos (take len str) : (go inp') alexGetChar :: AlexInput -> Maybe (Char,AlexInput) alexGetChar (p, c, []) = Nothing alexGetChar (p, _, (c:s)) = let p' = alexMove p c in p' `seq` Just (c, (p', c, s)) alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (p, c, s) = c alex_action_3 = tok (\p s -> PT p (TS $ share s)) alex_action_4 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) alex_action_5 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) alex_action_6 = tok (\p s -> PT p (TC $ share s)) alex_action_7 = tok (\p s -> PT p (TI $ share s)) alex_action_8 = tok (\p s -> PT p (TD $ share s)) {-# LINE 1 "templates\GenericTemplate.hs" #-} {-# LINE 1 "templates\\GenericTemplate.hs" #-} {-# LINE 1 "" #-} {-# LINE 1 "" #-} {-# 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 {-# LINE 37 "templates\\GenericTemplate.hs" #-} {-# LINE 47 "templates\\GenericTemplate.hs" #-} {-# LINE 68 "templates\\GenericTemplate.hs" #-} alexIndexInt16OffAddr arr off = arr ! off {-# LINE 89 "templates\\GenericTemplate.hs" #-} alexIndexInt32OffAddr arr off = arr ! off {-# LINE 100 "templates\\GenericTemplate.hs" #-} 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 alexGetChar 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` (s)) in new_acc `seq` case alexGetChar input of Nothing -> (new_acc, input) Just (c, new_input) -> let (base) = alexIndexInt32OffAddr alex_base s ((ord_c)) = ord 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 (len + (1)) new_input new_s new_acc where check_accs [] = 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) check_accs (AlexAccSkipPred predx : rest) | predx user orig_input (len) input = AlexLastSkip input (len) check_accs (_ : rest) = check_accs rest data AlexLastAcc a = AlexNone | AlexLastAcc a !AlexInput !Int | AlexLastSkip !AlexInput !Int 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 --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. -- used by wrappers iUnbox (i) = i