alex 3.1.4 → 3.1.5
raw patch · 23 files changed
+695/−639 lines, 23 filessetup-changed
Files
- ANNOUNCE +1/−1
- Setup.lhs +4/−4
- alex.cabal +39/−34
- doc/alex.xml +1/−1
- examples/Makefile +5/−2
- src/AbsSyn.hs +37/−37
- src/CharSet.hs +4/−9
- src/DFA.hs +47/−47
- src/DFS.hs +24/−24
- src/Data/Ranged/Boundaries.hs +6/−0
- src/Data/Ranged/RangedSet.hs +2/−0
- src/Info.hs +9/−9
- src/Main.hs +107/−92
- src/NFA.hs +49/−47
- src/Output.hs +127/−127
- src/ParseMonad.hs +27/−25
- src/Scan.hs +71/−71
- src/Sort.hs +11/−11
- templates/GenericTemplate.hs +46/−49
- templates/wrappers.hs +75/−46
- tests/Makefile +1/−1
- tests/tokens_monadUserState_bytestring.x +1/−1
- tests/tokens_monad_bytestring.x +1/−1
ANNOUNCE view
@@ -15,7 +15,7 @@ old 8-bit behaviour is still available via the --latin1 option. - * Alex source files are asumed to be in UTF-8, like Haskell+ * Alex source files are assumed to be in UTF-8, like Haskell source files. The lexer specification can use Unicode characters and ranges.
Setup.lhs view
@@ -21,7 +21,7 @@ copyHook = myCopy, instHook = myInstall } --- hack to turn cpp-style '# 27 "GenericTemplate.hs"' into +-- 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@@ -53,7 +53,7 @@ removeFile tmp sequence_ ([ cpp_template "GenericTemplate.hs" dst opts | (dst,opts) <- templates ] ++- [ cpp_template "wrappers.hs" dst opts | (dst,opts) <- wrappers ])+ [ 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@@ -62,13 +62,13 @@ 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)
alex.cabal view
@@ -1,5 +1,5 @@ name: alex-version: 3.1.4+version: 3.1.5 license: BSD3 license-file: LICENSE copyright: (c) Chis Dornan, Simon Marlow@@ -16,6 +16,11 @@ for scanning text efficiently. It is similar to the tool lex or flex for C/C++. .+ Changes in 3.1.5:+ .+ * Generate less warning-laden code, and suppress other warnings.+ * Bug fixes.+ . Changes in 3.1.4: . * Add Applicative/Functor instances for GHC 7.10@@ -41,43 +46,43 @@ build-type: Custom extra-source-files:- ANNOUNCE- README- TODO- alex.spec- doc/Makefile- doc/aclocal.m4- doc/alex.1.in- doc/alex.xml- doc/config.mk.in- doc/configure.ac- doc/docbook-xml.mk- doc/fptools.css- examples/Makefile- examples/Tokens.x- examples/Tokens_gscan.x- examples/Tokens_posn.x- examples/examples.x- examples/haskell.x- examples/lit.x- examples/pp.x- examples/state.x- examples/tiny.y- examples/tkns.hs- examples/words.x- examples/words_monad.x- examples/words_posn.x- src/Parser.y- src/Scan.hs- src/ghc_hooks.c- templates/GenericTemplate.hs+ ANNOUNCE+ README+ TODO+ alex.spec+ doc/Makefile+ doc/aclocal.m4+ doc/alex.1.in+ doc/alex.xml+ doc/config.mk.in+ doc/configure.ac+ doc/docbook-xml.mk+ doc/fptools.css+ examples/Makefile+ examples/Tokens.x+ examples/Tokens_gscan.x+ examples/Tokens_posn.x+ examples/examples.x+ examples/haskell.x+ examples/lit.x+ examples/pp.x+ examples/state.x+ examples/tiny.y+ examples/tkns.hs+ examples/words.x+ examples/words_monad.x+ examples/words_posn.x+ src/Parser.y+ src/Scan.hs+ src/ghc_hooks.c+ templates/GenericTemplate.hs templates/wrappers.hs- tests/Makefile+ tests/Makefile tests/simple.x tests/null.x tests/tokens.x- tests/tokens_gscan.x- tests/tokens_posn.x+ tests/tokens_gscan.x+ tests/tokens_posn.x tests/tokens_bytestring.x tests/tokens_posn_bytestring.x tests/tokens_strict_bytestring.x
doc/alex.xml view
@@ -69,7 +69,7 @@ </listitem> <listitem> <para>- Alex source files are asumed to be in UTF-8, like+ Alex source files are assumed to be in UTF-8, like Haskell source files. The lexer specification can use Unicode characters and ranges. </para>
examples/Makefile view
@@ -1,5 +1,5 @@ ALEX=../dist/build/alex/alex-HC=ghc -Wall -fno-warn-unused-binds -fno-warn-missing-signatures -fno-warn-unused-matches -fno-warn-name-shadowing -fno-warn-unused-imports+HC=ghc -Wall -fno-warn-unused-binds -fno-warn-missing-signatures -fno-warn-unused-matches -fno-warn-name-shadowing -fno-warn-unused-imports -fno-warn-tabs HAPPY=happy HAPPY_OPTS=-agc@@ -10,7 +10,7 @@ exeext= endif -PROGS = lit Tokens Tokens_gscan words words_posn words_monad tiny haskell+PROGS = lit Tokens Tokens_gscan words words_posn words_monad tiny haskell tiger ALEX_OPTS = --template=.. -g # ALEX_OPTS = --template=..@@ -51,6 +51,9 @@ haskell$(exeext) : haskell.hs $(HC) $(HC_OPTS) -o $@ $^++tiger$(exeext) : tiger.hs+ $(HC) $(HC_OPTS) -main-is TigerLexer -o $@ $^ .PHONY: clean clean:
src/AbsSyn.hs view
@@ -39,7 +39,7 @@ type Code = String data Directive- = WrapperDirective String -- use this wrapper+ = WrapperDirective String -- use this wrapper -- TODO: update this comment --@@ -54,15 +54,15 @@ -- converted to DFAs; see the DFA section of the Scan module for details. data Scanner = Scanner { scannerName :: String,- scannerTokens :: [RECtx] }+ scannerTokens :: [RECtx] } deriving Show data RECtx = RECtx { reCtxStartCodes :: [(String,StartCode)],- reCtxPreCtx :: Maybe CharSet,- reCtxRE :: RExp,- reCtxPostCtx :: RightContext RExp,- reCtxCode :: Maybe Code- }+ reCtxPreCtx :: Maybe CharSet,+ reCtxRE :: RExp,+ reCtxPostCtx :: RightContext RExp,+ reCtxCode :: Maybe Code+ } data RightContext r = NoRightContext @@ -72,7 +72,7 @@ instance Show RECtx where showsPrec _ (RECtx scs _ r rctx code) = - showStarts scs . shows r . showRCtx rctx . showMaybeCode code+ showStarts scs . shows r . showRCtx rctx . showMaybeCode code showMaybeCode :: Maybe String -> String -> String showMaybeCode Nothing = id@@ -106,9 +106,9 @@ data Accept a = Acc { accPrio :: Int,- accAction :: Maybe a,- accLeftCtx :: Maybe CharSet, -- cannot be converted to byteset at this point.- accRightCtx :: RightContext SNum+ accAction :: Maybe a,+ accLeftCtx :: Maybe CharSet, -- cannot be converted to byteset at this point.+ accRightCtx :: RightContext SNum } deriving (Eq,Ord) @@ -155,7 +155,7 @@ | RExp :| RExp | Star RExp | Plus RExp- | Ques RExp + | Ques RExp instance Show RExp where showsPrec _ Eps = showString "()"@@ -167,7 +167,7 @@ showsPrec _ (Ques r) = shows r . ('?':) {------------------------------------------------------------------------------- Abstract Regular Expression+ Abstract Regular Expression ------------------------------------------------------------------------------} @@ -179,8 +179,8 @@ recognise:: RExp -> String -> Bool recognise re inp = any (==len) (ap_ar (arexp re) inp)- where- len = length inp+ where+ len = length inp -- `ARexp' provides an regular expressions in abstract format. Here regular@@ -215,7 +215,7 @@ -- Hugs abstract type definition -- not for GHC. type ARexp = String -> [Int]--- in ap_ar, eps_ar, ch_ar, seq_ar, bar_ar+-- in ap_ar, eps_ar, ch_ar, seq_ar, bar_ar ap_ar:: ARexp -> String -> [Int] ap_ar sc = sc@@ -241,31 +241,31 @@ encodeStartCodes:: Scanner -> (Scanner,[StartCode],ShowS) encodeStartCodes scan = (scan', 0 : map snd name_code_pairs, sc_hdr)- where- scan' = scan{ scannerTokens = map mk_re_ctx (scannerTokens scan) }+ where+ scan' = scan{ scannerTokens = map mk_re_ctx (scannerTokens scan) } - mk_re_ctx (RECtx scs lc re rc code)- = RECtx (map mk_sc scs) lc re rc code+ mk_re_ctx (RECtx scs lc re rc code)+ = RECtx (map mk_sc scs) lc re rc code - mk_sc (nm,_) = (nm, if nm=="0" then 0 - else fromJust (Map.lookup nm code_map))+ mk_sc (nm,_) = (nm, if nm=="0" then 0 + else fromJust (Map.lookup nm code_map)) - sc_hdr tl =- case name_code_pairs of- [] -> tl- (nm,_):rst -> "\n" ++ nm ++ foldr f t rst- where- f (nm', _) t' = "," ++ nm' ++ t'- t = " :: Int\n" ++ foldr fmt_sc tl name_code_pairs- where- fmt_sc (nm,sc) t = nm ++ " = " ++ show sc ++ "\n" ++ t+ sc_hdr tl =+ case name_code_pairs of+ [] -> tl+ (nm,_):rst -> "\n" ++ nm ++ foldr f t rst+ where+ f (nm', _) t' = "," ++ nm' ++ t'+ t = " :: Int\n" ++ foldr fmt_sc tl name_code_pairs+ where+ fmt_sc (nm,sc) t = nm ++ " = " ++ show sc ++ "\n" ++ t - code_map = Map.fromList name_code_pairs+ code_map = Map.fromList name_code_pairs - name_code_pairs = zip (nub' (<=) nms) [1..]+ name_code_pairs = zip (nub' (<=) nms) [1..] - nms = [nm | RECtx{reCtxStartCodes = scs} <- scannerTokens scan,- (nm,_) <- scs, nm /= "0"]+ nms = [nm | RECtx{reCtxStartCodes = scs} <- scannerTokens scan,+ (nm,_) <- scs, nm /= "0"] -- Grab the code fragments for the token actions, and replace them@@ -279,9 +279,9 @@ (new_tokens, decls) = unzip (zipWith f (scannerTokens scanner) act_names) f r@RECtx{ reCtxCode = Just code } name- = (r{reCtxCode = Just name}, Just (mkDecl name code))+ = (r{reCtxCode = Just name}, Just (mkDecl name code)) f r@RECtx{ reCtxCode = Nothing } _- = (r{reCtxCode = Nothing}, Nothing)+ = (r{reCtxCode = Nothing}, Nothing) mkDecl fun code = str fun . str " = " . str code . nl
src/CharSet.hs view
@@ -1,5 +1,5 @@ -- -------------------------------------------------------------------------------- +-- -- CharSet.hs, part of Alex -- -- (c) Chris Dornan 1995-2000, Simon Marlow 2003@@ -108,9 +108,9 @@ toUtfRange (Span x y) = fix x y fix :: [Byte] -> [Byte] -> [Span [Byte]]-fix x y +fix x y | length x == length y = [Span x y]- | length x == 1 = Span x [0x7F] : fix [0xC2,0x80] y + | length x == 1 = Span x [0x7F] : fix [0xC2,0x80] y | length x == 2 = Span x [0xDF,0xBF] : fix [0xE0,0x80,0x80] y | length x == 3 = Span x [0xEF,0xBF,0xBF] : fix [0xF0,0x80,0x80,0x80] y | otherwise = error "fix: incorrect input given"@@ -151,14 +151,9 @@ byteSetSingleton :: Byte -> ByteSet byteSetSingleton = rSingleton -instance DiscreteOrdered Word8 where- adjacent x y = x + 1 == y- adjacentBelow 0 = Nothing- adjacentBelow x = Just (x-1)- -- TODO: More efficient generated code! charSetQuote :: CharSet -> String-charSetQuote s = "(\\c -> " ++ foldr (\x y -> x ++ " || " ++ y) "False" (map quoteRange (rSetRanges s)) ++ ")" +charSetQuote s = "(\\c -> " ++ foldr (\x y -> x ++ " || " ++ y) "False" (map quoteRange (rSetRanges s)) ++ ")" where quoteRange (Range l h) = quoteL l ++ " && " ++ quoteH h quoteL (BoundaryAbove a) = "c > " ++ show a quoteL (BoundaryBelow a) = "c >= " ++ show a
src/DFA.hs view
@@ -25,7 +25,7 @@ import Data.Array ( (!) ) import Data.Maybe ( fromJust ) -{- Defined in the Scan Module+{- Defined in the Scan Module -- (This section should logically belong to the DFA module but it has been -- placed here to make this module self-contained.)@@ -94,9 +94,9 @@ nfa2dfa:: [StartCode] -> NFA -> DFA SNum Code nfa2dfa scs nfa = mk_int_dfa nfa (nfa2pdfa nfa pdfa (dfa_start_states pdfa))- where- pdfa = new_pdfa n_starts nfa- n_starts = length scs -- number of start states+ where+ pdfa = new_pdfa n_starts nfa+ n_starts = length scs -- number of start states -- `nfa2pdfa' works by taking the next outstanding state set to be considered -- and and ignoring it if the state is already in the partial DFA, otherwise@@ -113,40 +113,40 @@ where pdfa' = add_pdfa ss (State accs (IntMap.fromList ss_outs)) pdfa - umkd' = rctx_sss ++ map snd ss_outs ++ umkd+ umkd' = rctx_sss ++ map snd ss_outs ++ umkd -- for each character, the set of states that character would take -- us to from the current set of states in the NFA. ss_outs :: [(Int, StateSet)] ss_outs = [ (fromIntegral ch, mk_ss nfa ss')- | ch <- byteSetElems $ setUnions [p | (p,_) <- outs],- let ss' = [ s' | (p,s') <- outs, byteSetElem p ch ],- not (null ss')- ]+ | ch <- byteSetElems $ setUnions [p | (p,_) <- outs],+ let ss' = [ s' | (p,s') <- outs, byteSetElem p ch ],+ not (null ss')+ ] - rctx_sss = [ mk_ss nfa [s]- | Acc _ _ _ (RightContextRExp s) <- accs ]+ rctx_sss = [ mk_ss nfa [s]+ | Acc _ _ _ (RightContextRExp s) <- accs ] outs :: [(ByteSet,SNum)]- outs = [ out | s <- ss, out <- nst_outs (nfa!s) ]+ outs = [ out | s <- ss, out <- nst_outs (nfa!s) ] - accs = sort_accs [acc| s<-ss, acc<-nst_accs (nfa!s)]+ accs = sort_accs [acc| s<-ss, acc<-nst_accs (nfa!s)] -- `sort_accs' sorts a list of accept values into decending order of priority, -- eliminating any elements that follow an unconditional accept value. sort_accs:: [Accept a] -> [Accept a] sort_accs accs = foldr chk [] (msort le accs)- where- chk acc@(Acc _ _ Nothing NoRightContext) _ = [acc]- chk acc rst = acc:rst+ where+ chk acc@(Acc _ _ Nothing NoRightContext) _ = [acc]+ chk acc rst = acc:rst - le (Acc{accPrio = n}) (Acc{accPrio=n'}) = n<=n'+ le (Acc{accPrio = n}) (Acc{accPrio=n'}) = n<=n' {------------------------------------------------------------------------------- State Sets and Partial DFAs+ State Sets and Partial DFAs ------------------------------------------------------------------------------} @@ -166,7 +166,7 @@ dfa_states = Map.empty } where- start_ss = [ msort (<=) (nst_cl(nfa!n)) | n <- [0..(starts-1)]]+ start_ss = [ msort (<=) (nst_cl(nfa!n)) | n <- [0..(starts-1)]] -- starts is the number of start states @@ -186,25 +186,25 @@ mk_int_dfa:: NFA -> DFA StateSet a -> DFA SNum a mk_int_dfa nfa (DFA start_states mp) = DFA [0 .. length start_states-1] - (Map.fromList [ (lookup' st, cnv pds) | (st, pds) <- Map.toAscList mp ])+ (Map.fromList [ (lookup' st, cnv pds) | (st, pds) <- Map.toAscList mp ]) where- mp' = Map.fromList (zip (start_states ++ - (map fst . Map.toAscList) (foldr Map.delete mp start_states)) [0..])+ mp' = Map.fromList (zip (start_states ++ + (map fst . Map.toAscList) (foldr Map.delete mp start_states)) [0..]) - lookup' = fromJust . flip Map.lookup mp'+ lookup' = fromJust . flip Map.lookup mp' - cnv :: State StateSet a -> State SNum a- cnv (State accs as) = State accs' as'- where+ cnv :: State StateSet a -> State SNum a+ cnv (State accs as) = State accs' as'+ where as' = IntMap.mapWithKey (\_ch s -> lookup' s) as - accs' = map cnv_acc accs- cnv_acc (Acc p a lctx rctx) = Acc p a lctx rctx'- where rctx' = - case rctx of- RightContextRExp s -> - RightContextRExp (lookup' (mk_ss nfa [s]))- other -> other+ accs' = map cnv_acc accs+ cnv_acc (Acc p a lctx rctx) = Acc p a lctx rctx'+ where rctx' = + case rctx of+ RightContextRExp s -> + RightContextRExp (lookup' (mk_ss nfa [s]))+ other -> other {- @@ -227,22 +227,22 @@ mk_st:: [Accept Code] -> [(Char,Int)] -> State Code mk_st accs as =- if null as- then St accs (-1) (listArray ('0','0') [-1])- else St accs df (listArray bds [arr!c| c<-range bds])- where- bds = if sz==0 then ('0','0') else bds0+ if null as+ then St accs (-1) (listArray ('0','0') [-1])+ else St accs df (listArray bds [arr!c| c<-range bds])+ where+ bds = if sz==0 then ('0','0') else bds0 - (sz,df,bds0) | sz1 < sz2 = (sz1,df1,bds1)- | otherwise = (sz2,df2,bds2)+ (sz,df,bds0) | sz1 < sz2 = (sz1,df1,bds1)+ | otherwise = (sz2,df2,bds2) - (sz1,df1,bds1) = mk_bds(arr!chr 0)- (sz2,df2,bds2) = mk_bds(arr!chr 255)+ (sz1,df1,bds1) = mk_bds(arr!chr 0)+ (sz2,df2,bds2) = mk_bds(arr!chr 255) - mk_bds df = (t-b, df, (chr b, chr (255-t)))- where- b = length (takeWhile id [arr!c==df| c<-['\0'..'\xff']])- t = length (takeWhile id [arr!c==df| c<-['\xff','\xfe'..'\0']])+ mk_bds df = (t-b, df, (chr b, chr (255-t)))+ where+ b = length (takeWhile id [arr!c==df| c<-['\0'..'\xff']])+ t = length (takeWhile id [arr!c==df| c<-['\xff','\xfe'..'\0']]) - arr = listArray ('\0','\xff') (take 256 (repeat (-1))) // as+ arr = listArray ('\0','\xff') (take 256 (repeat (-1))) // as -}
src/DFS.hs view
@@ -1,5 +1,5 @@ {------------------------------------------------------------------------------- DFS+ DFS This module is a portable version of the ghc-specific `DFS.g.hs', which is itself a straightforward encoding of the Launchbury/King paper on linear graph@@ -36,15 +36,15 @@ postorder:: GForrest -> [Int] postorder ts = po ts []- where- po ts' l = foldr po_tree l ts'+ where+ po ts' l = foldr po_tree l ts' - po_tree (GNode a ts') l = po ts' (a:l)+ po_tree (GNode a ts') l = po ts' (a:l) list_tree:: GTree -> [Int] list_tree t = l_t t []- where- l_t (GNode x ts) l = foldr l_t (x:l) ts+ where+ l_t (GNode x ts) l = foldr l_t (x:l) ts -- Graphs are represented by a pair of an integer, giving the number of nodes@@ -57,8 +57,8 @@ mk_graph:: Int -> [Edge] -> Graph mk_graph sz es = (sz,\v->ar!v)- where- ar = accumArray (flip (:)) [] (0,sz-1) [(v,v')| (v,v')<-es]+ where+ ar = accumArray (flip (:)) [] (0,sz-1) [(v,v')| (v,v')<-es] vertices:: Graph -> [Int] vertices (sz,_) = [0..sz-1]@@ -83,9 +83,9 @@ t_close:: Graph -> Graph t_close g@(sz,_) = (sz,\v->ar!v)- where- ar = listArray (0,sz) ([postorder(dff' [v] g)| v<-vertices g]++[und])- und = error "t_close"+ where+ ar = listArray (0,sz) ([postorder(dff' [v] g)| v<-vertices g]++[und])+ und = error "t_close" scc:: Graph -> GForrest scc g = dff' (reverse (top_sort (reverse_graph g))) g@@ -109,28 +109,28 @@ prune:: GForrest -> GForrest prune ts = snd(chop(empty_int,ts))- where- empty_int:: Set Int- empty_int = Set.empty+ where+ empty_int:: Set Int+ empty_int = Set.empty chop:: (Set Int,GForrest) -> (Set Int,GForrest) chop p@(_, []) = p chop (vstd,GNode v ts:us) =- if v `Set.member` vstd- then chop (vstd,us)- else let vstd1 = Set.insert v vstd- (vstd2,ts') = chop (vstd1,ts)- (vstd3,us') = chop (vstd2,us)- in- (vstd3,GNode v ts' : us')+ if v `Set.member` vstd+ then chop (vstd,us)+ else let vstd1 = Set.insert v vstd+ (vstd2,ts') = chop (vstd1,ts)+ (vstd3,us') = chop (vstd2,us)+ in+ (vstd3,GNode v ts' : us') {-- Some simple test functions test:: Graph Char test = mk_graph (char_bds ('a','h')) (mk_pairs "eefggfgegdhfhged")- where- mk_pairs [] = []- mk_pairs (a:b:l) = (a,b):mk_pairs l+ where+ mk_pairs [] = []+ mk_pairs (a:b:l) = (a,b):mk_pairs l -}
src/Data/Ranged/Boundaries.hs view
@@ -20,6 +20,7 @@ ) where import Data.Ratio+import Data.Word import Test.QuickCheck infix 4 />/@@ -118,6 +119,11 @@ adjacentBelow (x1, x2, x3, x4) = do -- Maybe monad x4' <- adjacentBelow x4 return (x1, x2, x3, x4')++instance DiscreteOrdered Word8 where+ adjacent x y = x + 1 == y+ adjacentBelow 0 = Nothing+ adjacentBelow x = Just (x-1) -- | Check adjacency for sparse enumerated types (i.e. where there
src/Data/Ranged/RangedSet.hs view
@@ -58,7 +58,9 @@ import Data.Ranged.Boundaries import Data.Ranged.Ranges+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid+#endif import Data.List import Test.QuickCheck
src/Info.hs view
@@ -33,10 +33,10 @@ infoState :: State SNum Code -> ShowS infoState (State accs out) = foldr (.) id (map infoAccept accs)- . infoArr out . nl+ . infoArr out . nl infoArr out- = char '\t' . interleave_shows (str "\n\t")+ = char '\t' . interleave_shows (str "\n\t") (map infoTransition (IntMap.toAscList out)) infoAccept (Acc p act lctx rctx)@@ -49,15 +49,15 @@ . nl infoTransition (char',state)- = str (ljustify 8 (show char'))- . str " -> "- . shows state+ = str (ljustify 8 (show char'))+ . str " -> "+ . shows state outputLCtx Nothing- = id+ = id outputLCtx (Just set)- = paren (show set ++) . char '^'+ = paren (show set ++) . char '^' -- outputArr arr- -- = str "Array.array " . shows (bounds arr) . space- -- . shows (assocs arr)+ -- = str "Array.array " . shows (bounds arr) . space+ -- . shows (assocs arr)
src/Main.hs view
@@ -70,18 +70,18 @@ -- `main' decodes the command line arguments and calls `alex'. main:: IO ()-main = do+main = do args <- getArgs case getOpt Permute argInfo args of (cli,_,[]) | DumpHelp `elem` cli -> do- prog <- getProgramName+ prog <- getProgramName bye (usageInfo (usageHeader prog) argInfo) (cli,_,[]) | DumpVersion `elem` cli ->- bye copyright+ bye copyright (cli,[file],[]) -> - runAlex cli file+ runAlex cli file (_,_,errors) -> do- prog <- getProgramName+ prog <- getProgramName die (concat errors ++ usageInfo (usageHeader prog) argInfo) projectVersion :: String@@ -96,8 +96,8 @@ runAlex :: [CLIFlags] -> FilePath -> IO () runAlex cli file = do basename <- case (reverse file) of- 'x':'.':r -> return (reverse r)- _ -> die (file ++ ": filename must end in \'.x\'\n")+ 'x':'.':r -> return (reverse r)+ _ -> die (file ++ ": filename must end in \'.x\'\n") prg <- alexReadFile file script <- parseScript file prg@@ -107,13 +107,13 @@ -> IO (Maybe (AlexPosn,Code), [Directive], Scanner, Maybe (AlexPosn,Code)) parseScript file prg = case runP prg initialParserEnv parse of- Left (Just (AlexPn _ line col),err) -> - die (file ++ ":" ++ show line ++ ":" ++ show col- ++ ": " ++ err ++ "\n")- Left (Nothing, err) ->- die (file ++ ": " ++ err ++ "\n")+ Left (Just (AlexPn _ line col),err) -> + die (file ++ ":" ++ show line ++ ":" ++ show col+ ++ ": " ++ err ++ "\n")+ Left (Nothing, err) ->+ die (file ++ ": " ++ err ++ "\n") - Right script -> return script+ Right script -> return script alex :: [CLIFlags] -> FilePath -> FilePath -> (Maybe (AlexPosn, Code), [Directive], Scanner, Maybe (AlexPosn, Code))@@ -121,36 +121,43 @@ alex cli file basename script = do (put_info, finish_info) <- case [ f | OptInfoFile f <- cli ] of- [] -> return (\_ -> return (), return ())- [Nothing] -> infoStart file (basename ++ ".info")- [Just f] -> infoStart file f- _ -> dieAlex "multiple -i/--info options"+ [] -> return (\_ -> return (), return ())+ [Nothing] -> infoStart file (basename ++ ".info")+ [Just f] -> infoStart file f+ _ -> dieAlex "multiple -i/--info options" o_file <- case [ f | OptOutputFile f <- cli ] of- [] -> return (basename ++ ".hs")- [f] -> return f- _ -> dieAlex "multiple -o/--outfile options"+ [] -> return (basename ++ ".hs")+ [f] -> return f+ _ -> dieAlex "multiple -o/--outfile options" + tab_size <- case [ s | OptTabSize s <- cli ] of+ [] -> return 8+ [s] -> case reads s of+ [(n,"")] -> return n+ _ -> dieAlex "-s/--tab-size option is not a valid integer"+ _ -> dieAlex "multiple -s/--tab-size options"+ let target - | OptGhcTarget `elem` cli = GhcTarget- | otherwise = HaskellTarget+ | OptGhcTarget `elem` cli = GhcTarget+ | otherwise = HaskellTarget let encoding | OptLatin1 `elem` cli = Latin1 | otherwise = UTF8 template_dir <- templateDir getDataDir cli- + -- open the output file; remove it if we encounter an error bracketOnError (alexOpenFile o_file WriteMode)- (\h -> do hClose h; removeFile o_file)- $ \out_h -> do+ (\h -> do hClose h; removeFile o_file)+ $ \out_h -> do let- (maybe_header, directives, scanner1, maybe_footer) = script- (scanner2, scs, sc_hdr) = encodeStartCodes scanner1- (scanner_final, actions) = extractActions scanner2+ (maybe_header, directives, scanner1, maybe_footer) = script+ (scanner2, scs, sc_hdr) = encodeStartCodes scanner1+ (scanner_final, actions) = extractActions scanner2 wrapper_name <- wrapperFile template_dir directives @@ -161,9 +168,13 @@ -- add the wrapper, if necessary when (isJust wrapper_name) $- do str <- alexReadFile (fromJust wrapper_name)- hPutStr out_h str+ do str <- alexReadFile (fromJust wrapper_name)+ hPutStr out_h str + -- Inject the tab size+ hPutStrLn out_h $ "alex_tab_size :: Int"+ hPutStrLn out_h $ "alex_tab_size = " ++ show tab_size+ let dfa = scanner2dfa encoding scanner_final scs min_dfa = minimizeDFA dfa nm = scannerName scanner_final@@ -203,17 +214,20 @@ hPutStrLn hdl code optsToInject :: Target -> [CLIFlags] -> String-optsToInject GhcTarget _ = "{-# LANGUAGE CPP,MagicHash #-}\n"-optsToInject _ _ = "{-# LANGUAGE CPP #-}\n"+optsToInject GhcTarget _ = optNoWarnings ++ "{-# LANGUAGE CPP,MagicHash #-}\n"+optsToInject _ _ = optNoWarnings ++ "{-# LANGUAGE CPP #-}\n" +optNoWarnings :: String+optNoWarnings = "{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-}\n"+ importsToInject :: Target -> [CLIFlags] -> String importsToInject _ cli = always_imports ++ debug_imports ++ glaexts_import where- glaexts_import | OptGhcTarget `elem` cli = import_glaexts- | otherwise = ""+ glaexts_import | OptGhcTarget `elem` cli = import_glaexts+ | otherwise = "" - debug_imports | OptDebugParser `elem` cli = import_debug- | otherwise = ""+ debug_imports | OptDebugParser `elem` cli = import_debug+ | otherwise = "" -- CPP is turned on for -fglasogw-exts, so we can use conditional -- compilation. We need to #include "config.h" to get hold of@@ -221,35 +235,33 @@ always_imports :: String always_imports = "#if __GLASGOW_HASKELL__ >= 603\n" ++- "#include \"ghcconfig.h\"\n" ++- "#elif defined(__GLASGOW_HASKELL__)\n" ++- "#include \"config.h\"\n" ++- "#endif\n" ++- "#if __GLASGOW_HASKELL__ >= 503\n" ++- "import Data.Array\n" ++- "import Data.Char (ord)\n" ++- "import Data.Array.Base (unsafeAt)\n" ++- "#else\n" ++- "import Array\n" ++- "import Char (ord)\n" ++- "#endif\n"+ "#include \"ghcconfig.h\"\n" +++ "#elif defined(__GLASGOW_HASKELL__)\n" +++ "#include \"config.h\"\n" +++ "#endif\n" +++ "#if __GLASGOW_HASKELL__ >= 503\n" +++ "import Data.Array\n" +++ "import Data.Array.Base (unsafeAt)\n" +++ "#else\n" +++ "import Array\n" +++ "#endif\n" import_glaexts :: String import_glaexts = "#if __GLASGOW_HASKELL__ >= 503\n" ++- "import GHC.Exts\n" ++- "#else\n" ++- "import GlaExts\n" ++- "#endif\n"+ "import GHC.Exts\n" +++ "#else\n" +++ "import GlaExts\n" +++ "#endif\n" import_debug :: String import_debug = "#if __GLASGOW_HASKELL__ >= 503\n" ++- "import System.IO\n" ++- "import System.IO.Unsafe\n" ++- "import Debug.Trace\n" ++- "#else\n" ++- "import IO\n" ++- "import IOExts\n" ++- "#endif\n"+ "import System.IO\n" +++ "import System.IO.Unsafe\n" +++ "import Debug.Trace\n" +++ "#else\n" +++ "import IO\n" +++ "import IOExts\n" +++ "#endif\n" templateDir :: IO FilePath -> [CLIFlags] -> IO FilePath templateDir def cli@@ -261,35 +273,35 @@ templateFile dir target usespreds cli = dir ++ "/AlexTemplate" ++ maybe_ghc ++ maybe_debug ++ maybe_nopred where - maybe_ghc = case target of+ maybe_ghc = case target of GhcTarget -> "-ghc" _ -> "" - maybe_debug- | OptDebugParser `elem` cli = "-debug"- | otherwise = ""+ maybe_debug+ | OptDebugParser `elem` cli = "-debug"+ | otherwise = "" - maybe_nopred =- case usespreds of- DoesntUsePreds | not (null maybe_ghc)- && null maybe_debug -> "-nopred"- _ -> ""+ maybe_nopred =+ case usespreds of+ DoesntUsePreds | not (null maybe_ghc)+ && null maybe_debug -> "-nopred"+ _ -> "" wrapperFile :: FilePath -> [Directive] -> IO (Maybe FilePath) wrapperFile dir directives = case [ f | WrapperDirective f <- directives ] of- [] -> return Nothing- [f] -> return (Just (dir ++ "/AlexWrapper-" ++ f))- _many -> dieAlex "multiple %wrapper directives"+ [] -> return Nothing+ [f] -> return (Just (dir ++ "/AlexWrapper-" ++ f))+ _many -> dieAlex "multiple %wrapper directives" infoStart :: FilePath -> FilePath -> IO (String -> IO (), IO ()) infoStart x_file info_file = do bracketOnError- (alexOpenFile info_file WriteMode)- (\h -> do hClose h; removeFile info_file)- (\h -> do infoHeader h x_file- return (hPutStr h, hClose h)- )+ (alexOpenFile info_file WriteMode)+ (\h -> do hClose h; removeFile info_file)+ (\h -> do infoHeader h x_file+ return (hPutStr h, hClose h)+ ) infoHeader :: Handle -> FilePath -> IO () infoHeader h file = do@@ -304,9 +316,9 @@ initSetEnv :: Map String CharSet initSetEnv = Map.fromList [("white", charSet " \t\n\v\f\r"),- ("printable", charSetRange (chr 32) (chr 0x10FFFF)), -- FIXME: Look it up the unicode standard- (".", charSetComplement emptyCharSet - `charSetMinus` charSetSingleton '\n')]+ ("printable", charSetRange (chr 32) (chr 0x10FFFF)), -- FIXME: Look it up the unicode standard+ (".", charSetComplement emptyCharSet + `charSetMinus` charSetSingleton '\n')] initREEnv :: Map String RExp initREEnv = Map.empty@@ -319,6 +331,7 @@ | OptGhcTarget | OptOutputFile FilePath | OptInfoFile (Maybe FilePath)+ | OptTabSize String | OptTemplateDir FilePath | OptLatin1 | DumpHelp@@ -328,21 +341,23 @@ argInfo :: [OptDescr CLIFlags] argInfo = [ Option ['o'] ["outfile"] (ReqArg OptOutputFile "FILE")- "write the output to FILE (default: file.hs)",+ "write the output to FILE (default: file.hs)", Option ['i'] ["info"] (OptArg OptInfoFile "FILE")- "put detailed state-machine info in FILE (or file.info)",+ "put detailed state-machine info in FILE (or file.info)", Option ['t'] ["template"] (ReqArg OptTemplateDir "DIR")- "look in DIR for template files",+ "look in DIR for template files", Option ['g'] ["ghc"] (NoArg OptGhcTarget)- "use GHC extensions",+ "use GHC extensions", Option ['l'] ["latin1"] (NoArg OptLatin1) "generated lexer will use the Latin-1 encoding instead of UTF-8",+ Option ['s'] ["tab-size"] (ReqArg OptTabSize "NUMBER")+ "set tab size to be used in the generated lexer (default: 8)", Option ['d'] ["debug"] (NoArg OptDebugParser)- "produce a debugging scanner",+ "produce a debugging scanner", Option ['?'] ["help"] (NoArg DumpHelp)- "display this help and exit",+ "display this help and exit", Option ['V','v'] ["version"] (NoArg DumpVersion) -- ToDo: -v is deprecated!- "output version information and exit"+ "output version information and exit" ] -- -----------------------------------------------------------------------------@@ -365,16 +380,16 @@ #if __GLASGOW_HASKELL__ < 610 bracketOnError- :: IO a -- ^ computation to run first (\"acquire resource\")- -> (a -> IO b) -- ^ computation to run last (\"release resource\")- -> (a -> IO c) -- ^ computation to run in-between- -> IO c -- returns the value from the in-between computation+ :: IO a -- ^ computation to run first (\"acquire resource\")+ -> (a -> IO b) -- ^ computation to run last (\"release resource\")+ -> (a -> IO c) -- ^ computation to run in-between+ -> IO c -- returns the value from the in-between computation bracketOnError before after thing = block (do a <- before r <- Exception.catch - (unblock (thing a))- (\e -> do { after a; throw e })+ (unblock (thing a))+ (\e -> do { after a; throw e }) return r ) #endif
src/NFA.hs view
@@ -23,7 +23,9 @@ import qualified Map hiding ( Map ) import Util ( str, space ) +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ( Applicative(..) )+#endif import Control.Monad ( forM_, zipWithM, zipWithM_, when, liftM, ap ) import Data.Array ( Array, (!), array, listArray, assocs, bounds ) @@ -49,9 +51,9 @@ instance Show NState where showsPrec _ (NSt accs cl outs) = str "NSt " . shows accs . space . shows cl . space .- shows [ (c, s) | (c,s) <- outs ]+ shows [ (c, s) | (c,s) <- outs ] -{- From the Scan Module+{- From the Scan Module -- The `Accept' structure contains the priority of the token being accepted -- (lower numbers => higher priorities), the name of the token, a place holder@@ -79,47 +81,47 @@ scanner2nfa enc Scanner{scannerTokens = toks} startcodes = runNFA enc $ do- -- make a start state for each start code (these will be- -- numbered from zero).- start_states <- sequence (replicate (length startcodes) newState)- - -- construct the NFA for each token- tok_states <- zipWithM do_token toks [0..]+ -- make a start state for each start code (these will be+ -- numbered from zero).+ start_states <- sequence (replicate (length startcodes) newState)+ + -- construct the NFA for each token+ tok_states <- zipWithM do_token toks [0..] - -- make an epsilon edge from each state state to each- -- token that is acceptable in that state- zipWithM_ (tok_transitions (zip toks tok_states)) - startcodes start_states+ -- make an epsilon edge from each state state to each+ -- token that is acceptable in that state+ zipWithM_ (tok_transitions (zip toks tok_states)) + startcodes start_states - where- do_token (RECtx _scs lctx re rctx code) prio = do- b <- newState- e <- newState- rexp2nfa b e re+ where+ do_token (RECtx _scs lctx re rctx code) prio = do+ b <- newState+ e <- newState+ rexp2nfa b e re - rctx_e <- case rctx of- NoRightContext ->- return NoRightContext- RightContextCode code' ->- return (RightContextCode code')- RightContextRExp re' -> do - r_b <- newState- r_e <- newState- rexp2nfa r_b r_e re'- accept r_e rctxt_accept- return (RightContextRExp r_b)+ rctx_e <- case rctx of+ NoRightContext ->+ return NoRightContext+ RightContextCode code' ->+ return (RightContextCode code')+ RightContextRExp re' -> do + r_b <- newState+ r_e <- newState+ rexp2nfa r_b r_e re'+ accept r_e rctxt_accept+ return (RightContextRExp r_b) - let lctx' = case lctx of+ let lctx' = case lctx of Nothing -> Nothing- Just st -> Just st+ Just st -> Just st - accept e (Acc prio code lctx' rctx_e)- return b+ accept e (Acc prio code lctx' rctx_e)+ return b - tok_transitions toks_with_states start_code start_state = do- let states = [ s | (RECtx scs _ _ _ _, s) <- toks_with_states,- null scs || start_code `elem` map snd scs ]- mapM_ (epsilonEdge start_state) states+ tok_transitions toks_with_states start_code start_state = do+ let states = [ s | (RECtx scs _ _ _ _, s) <- toks_with_states,+ null scs || start_code `elem` map snd scs ]+ mapM_ (epsilonEdge start_state) states -- ----------------------------------------------------------------------------- -- NFA creation from a regular expression@@ -178,15 +180,15 @@ runNFA :: Encoding -> NFAM () -> NFA runNFA e m = case unN m 0 Map.empty e of- (s, nfa_map, ()) -> -- trace ("runNfa.." ++ show (Map.toAscList nfa_map)) $ - e_close (array (0,s-1) (Map.toAscList nfa_map))+ (s, nfa_map, ()) -> -- trace ("runNfa.." ++ show (Map.toAscList nfa_map)) $ + e_close (array (0,s-1) (Map.toAscList nfa_map)) e_close:: Array Int NState -> NFA e_close ar = listArray bds- [NSt accs (out gr v) outs|(v,NSt accs _ outs)<-assocs ar]- where- gr = t_close (hi+1,\v->nst_cl (ar!v))- bds@(_,hi) = bounds ar+ [NSt accs (out gr v) outs|(v,NSt accs _ outs)<-assocs ar]+ where+ gr = t_close (hi+1,\v->nst_cl (ar!v))+ bds@(_,hi) = bounds ar newState :: NFAM SNum newState = N $ \s n _ -> (s+1,n,s)@@ -239,9 +241,9 @@ addEdge n = case Map.lookup from n of Nothing -> - Map.insert from (NSt [] [] [(charset,to)]) n+ Map.insert from (NSt [] [] [(charset,to)]) n Just (NSt acc eps trans) ->- Map.insert from (NSt acc eps ((charset,to):trans)) n+ Map.insert from (NSt acc eps ((charset,to):trans)) n epsilonEdge :: SNum -> SNum -> NFAM () epsilonEdge from to @@ -250,7 +252,7 @@ where addEdge n = case Map.lookup from n of- Nothing -> Map.insert from (NSt [] [to] []) n+ Nothing -> Map.insert from (NSt [] [to] []) n Just (NSt acc eps trans) -> Map.insert from (NSt acc (to:eps) trans) n accept :: SNum -> Accept Code -> NFAM ()@@ -259,9 +261,9 @@ addAccept n = case Map.lookup state n of Nothing ->- Map.insert state (NSt [new_acc] [] []) n+ Map.insert state (NSt [new_acc] [] []) n Just (NSt acc eps trans) ->- Map.insert state (NSt (new_acc:acc) eps trans) n+ Map.insert state (NSt (new_acc:acc) eps trans) n rctxt_accept :: Accept Code
src/Output.hs view
@@ -31,7 +31,7 @@ outputDFA :: Target -> Int -> String -> DFA SNum Code -> ShowS outputDFA target _ _ dfa = interleave_shows nl - [outputBase, outputTable, outputCheck, outputDefault, outputAccept]+ [outputBase, outputTable, outputCheck, outputDefault, outputAccept] where (base, table, check, deflt, accept) = mkTables dfa @@ -52,61 +52,61 @@ do_array hex_chars nm upper_bound ints = -- trace ("do_array: " ++ nm) $ case target of GhcTarget ->- str nm . str " :: AlexAddr\n"- . str nm . str " = AlexA# \""- . str (hex_chars ints)- . str "\"#\n"+ str nm . str " :: AlexAddr\n"+ . str nm . str " = AlexA# \""+ . str (hex_chars ints)+ . str "\"#\n" _ ->- str nm . str " :: Array Int Int\n"- . str nm . str " = listArray (0," . shows upper_bound- . str ") [" . interleave_shows (char ',') (map shows ints)- . str "]\n"+ str nm . str " :: Array Int Int\n"+ . str nm . str " = listArray (0," . shows upper_bound+ . str ") [" . interleave_shows (char ',') (map shows ints)+ . str "]\n" outputAccept- = -- No type signature: we don't know what the type of the actions is.- -- str accept_nm . str " :: Array Int (Accept Code)\n"- str accept_nm . str " = listArray (0::Int," . shows n_states- . str ") [" . interleave_shows (char ',') (map outputAccs accept)- . str "]\n"+ = -- No type signature: we don't know what the type of the actions is.+ -- str accept_nm . str " :: Array Int (Accept Code)\n"+ str accept_nm . str " = listArray (0::Int," . shows n_states+ . str ") [" . interleave_shows (char ',') (map outputAccs accept)+ . str "]\n" outputAccs :: [Accept Code] -> ShowS outputAccs []- = str "AlexAccNone"+ = str "AlexAccNone" outputAccs (Acc _ Nothing Nothing NoRightContext : [])- = str "AlexAccSkip"+ = str "AlexAccSkip" outputAccs (Acc _ (Just act) Nothing NoRightContext : [])- = str "AlexAcc " . paren (str act)+ = str "AlexAcc " . paren (str act) outputAccs (Acc _ Nothing lctx rctx : rest)- = str "AlexAccSkipPred " . space- . paren (outputPred lctx rctx)+ = str "AlexAccSkipPred " . space+ . paren (outputPred lctx rctx) . paren (outputAccs rest) outputAccs (Acc _ (Just act) lctx rctx : rest)- = str "AlexAccPred " . space- . paren (str act) . space- . paren (outputPred lctx rctx)+ = str "AlexAccPred " . space+ . paren (str act) . space+ . paren (outputPred lctx rctx) . paren (outputAccs rest) outputPred (Just set) NoRightContext- = outputLCtx set+ = outputLCtx set outputPred Nothing rctx- = outputRCtx rctx+ = outputRCtx rctx outputPred (Just set) rctx- = outputLCtx set- . str " `alexAndPred` "- . outputRCtx rctx+ = outputLCtx set+ . str " `alexAndPred` "+ . outputRCtx rctx outputLCtx set = str "alexPrevCharMatches" . str (charSetQuote set) outputRCtx NoRightContext = id outputRCtx (RightContextRExp sn)- = str "alexRightContext " . shows sn+ = str "alexRightContext " . shows sn outputRCtx (RightContextCode code)- = str code+ = str code -- outputArr arr- -- = str "array " . shows (bounds arr) . space- -- . shows (assocs arr)+ -- = str "array " . shows (bounds arr) . space+ -- . shows (assocs arr) -- ----------------------------------------------------------------------------- -- Generating arrays.@@ -118,20 +118,20 @@ -- We want to generate: -- -- base :: Array SNum Int--- maps the current state to an offset in the main table+-- maps the current state to an offset in the main table -- -- table :: Array Int SNum--- maps (base!state + char) to the next state+-- maps (base!state + char) to the next state -- -- check :: Array Int SNum--- maps (base!state + char) to state if table entry is valid,--- otherwise we use the default for this state+-- maps (base!state + char) to state if table entry is valid,+-- otherwise we use the default for this state -- -- default :: Array SNum SNum--- default production for this state+-- default production for this state -- -- accept :: Array SNum [Accept Code]--- maps state to list of accept codes for this state+-- maps state to list of accept codes for this state -- -- For each state, we decide what will be the default symbol (pick the -- most common). We now have a mapping Char -> SNum, with one special@@ -139,13 +139,13 @@ mkTables :: DFA SNum Code- -> ( - [Int], -- base- [Int], -- table- [Int], -- check- [Int], -- default- [[Accept Code]] -- accept- )+ -> ( + [Int], -- base+ [Int], -- table+ [Int], -- check+ [Int], -- default+ [[Accept Code]] -- accept+ ) mkTables dfa = -- trace (show (defaults)) $ -- trace (show (fmap (length . snd) dfa_no_defaults)) $ ( elems base_offs, @@ -155,61 +155,61 @@ accept ) where - accept = [ as | State as _ <- elems dfa_arr ]+ accept = [ as | State as _ <- elems dfa_arr ] - state_assocs = Map.toAscList (dfa_states dfa)- n_states = length state_assocs- top_state = n_states - 1+ state_assocs = Map.toAscList (dfa_states dfa)+ n_states = length state_assocs+ top_state = n_states - 1 - dfa_arr :: Array SNum (State SNum Code)- dfa_arr = array (0,top_state) state_assocs+ dfa_arr :: Array SNum (State SNum Code)+ dfa_arr = array (0,top_state) state_assocs - -- fill in all the error productions- expand_states =- [ expand (dfa_arr!state) | state <- [0..top_state] ]- - expand (State _ out) = - [(i, lookup' out i) | i <- [0..0xff]]+ -- fill in all the error productions+ expand_states =+ [ expand (dfa_arr!state) | state <- [0..top_state] ]+ + expand (State _ out) = + [(i, lookup' out i) | i <- [0..0xff]] where lookup' out' i = case IntMap.lookup i out' of- Nothing -> -1- Just s -> s+ Nothing -> -1+ Just s -> s - defaults :: UArray SNum SNum- defaults = listArray (0,top_state) (map best_default expand_states)+ defaults :: UArray SNum SNum+ defaults = listArray (0,top_state) (map best_default expand_states) - -- find the most common destination state in a given state, and- -- make it the default.+ -- find the most common destination state in a given state, and+ -- make it the default. best_default :: [(Int,SNum)] -> SNum- best_default prod_list- | null sorted = -1- | otherwise = snd (head (maximumBy lengths eq))- where sorted = sortBy compareSnds prod_list- compareSnds (_,a) (_,b) = compare a b- eq = groupBy (\(_,a) (_,b) -> a == b) sorted- lengths a b = length a `compare` length b+ best_default prod_list+ | null sorted = -1+ | otherwise = snd (head (maximumBy lengths eq))+ where sorted = sortBy compareSnds prod_list+ compareSnds (_,a) (_,b) = compare a b+ eq = groupBy (\(_,a) (_,b) -> a == b) sorted+ lengths a b = length a `compare` length b - -- remove all the default productions from the DFA+ -- remove all the default productions from the DFA dfa_no_defaults =- [ (s, prods_without_defaults s out)- | (s, out) <- zip [0..] expand_states- ]+ [ (s, prods_without_defaults s out)+ | (s, out) <- zip [0..] expand_states+ ] - prods_without_defaults s out - = [ (fromIntegral c, dest) | (c,dest) <- out, dest /= defaults!s ]+ prods_without_defaults s out + = [ (fromIntegral c, dest) | (c,dest) <- out, dest /= defaults!s ] - (base_offs, table, check, max_off)- = runST (genTables n_states 255 dfa_no_defaults)- + (base_offs, table, check, max_off)+ = runST (genTables n_states 255 dfa_no_defaults)+ genTables- :: Int -- number of states- -> Int -- maximum token no.- -> [(SNum,[(Int,SNum)])] -- entries for the table- -> ST s (UArray Int Int, -- base- UArray Int Int, -- table- UArray Int Int, -- check- Int -- highest offset in table- )+ :: Int -- number of states+ -> Int -- maximum token no.+ -> [(SNum,[(Int,SNum)])] -- entries for the table+ -> ST s (UArray Int Int, -- base+ UArray Int Int, -- table+ UArray Int Int, -- check+ Int -- highest offset in table+ ) genTables n_states max_token entries = do @@ -229,44 +229,44 @@ genTables'- :: STUArray s Int Int -- base- -> STUArray s Int Int -- table- -> STUArray s Int Int -- check- -> STUArray s Int Int -- offset array- -> [(SNum,[(Int,SNum)])] -- entries for the table- -> Int -- maximum token no.- -> ST s Int -- highest offset in table+ :: STUArray s Int Int -- base+ -> STUArray s Int Int -- table+ -> STUArray s Int Int -- check+ -> STUArray s Int Int -- offset array+ -> [(SNum,[(Int,SNum)])] -- entries for the table+ -> Int -- maximum token no.+ -> ST s Int -- highest offset in table genTables' base table check off_arr entries max_token- = fit_all entries 0 1+ = fit_all entries 0 1 where - fit_all [] max_off _ = return max_off- fit_all (s:ss) max_off fst_zero = do- (off, new_max_off, new_fst_zero) <- fit s max_off fst_zero- writeArray off_arr off 1- fit_all ss new_max_off new_fst_zero+ fit_all [] max_off _ = return max_off+ fit_all (s:ss) max_off fst_zero = do+ (off, new_max_off, new_fst_zero) <- fit s max_off fst_zero+ writeArray off_arr off 1+ fit_all ss new_max_off new_fst_zero - -- fit a vector into the table. Return the offset of the vector,- -- the maximum offset used in the table, and the offset of the first- -- entry in the table (used to speed up the lookups a bit).- fit (_,[]) max_off fst_zero = return (0,max_off,fst_zero)+ -- fit a vector into the table. Return the offset of the vector,+ -- the maximum offset used in the table, and the offset of the first+ -- entry in the table (used to speed up the lookups a bit).+ fit (_,[]) max_off fst_zero = return (0,max_off,fst_zero) - fit (state_no, state@((t,_):_)) max_off fst_zero = do- -- start at offset 1 in the table: all the empty states- -- (states with just a default reduction) are mapped to- -- offset zero.- off <- findFreeOffset (-t + fst_zero) check off_arr state- let new_max_off | furthest_right > max_off = furthest_right- | otherwise = max_off- furthest_right = off + max_token+ fit (state_no, state@((t,_):_)) max_off fst_zero = do+ -- start at offset 1 in the table: all the empty states+ -- (states with just a default reduction) are mapped to+ -- offset zero.+ off <- findFreeOffset (-t + fst_zero) check off_arr state+ let new_max_off | furthest_right > max_off = furthest_right+ | otherwise = max_off+ furthest_right = off + max_token - --trace ("fit: state " ++ show state_no ++ ", off " ++ show off ++ ", elems " ++ show state) $ do+ --trace ("fit: state " ++ show state_no ++ ", off " ++ show off ++ ", elems " ++ show state) $ do - writeArray base state_no off- addState off table check state- new_fst_zero <- findFstFreeSlot check fst_zero- return (off, new_max_off, new_fst_zero)+ writeArray base state_no off+ addState off table check state+ new_fst_zero <- findFstFreeSlot check fst_zero+ return (off, new_max_off, new_fst_zero) -- Find a valid offset in the table for this state.@@ -287,7 +287,7 @@ ok <- fits off state check if ok then return off else try_next where- try_next = findFreeOffset (off+1) check off_arr state+ try_next = findFreeOffset (off+1) check off_arr state -- This is an inner loop, so we use some strictness hacks, and avoid -- array bounds checks (unsafeRead instead of readArray) to speed@@ -297,7 +297,7 @@ fits off ((t,_):rest) check = do i <- unsafeRead check (off+t) if i /= -1 then return False- else fits off rest check+ else fits off rest check addState :: Int -> STUArray s Int Int -> STUArray s Int Int -> [(Int, Int)] -> ST s ()@@ -309,9 +309,9 @@ findFstFreeSlot :: STUArray s Int Int -> Int -> ST s Int findFstFreeSlot table n = do- i <- readArray table n- if i == -1 then return n- else findFstFreeSlot table (n+1)+ i <- readArray table n+ if i == -1 then return n+ else findFstFreeSlot table (n+1) ----------------------------------------------------------------------------- -- Convert an integer to a 16-bit number encoded in \xNN\xNN format suitable@@ -321,23 +321,23 @@ hexChars16 acts = concat (map conv16 acts) where conv16 i | i > 0x7fff || i < -0x8000- = error ("Internal error: hexChars16: out of range: " ++ show i)- | otherwise- = hexChar16 i+ = error ("Internal error: hexChars16: out of range: " ++ show i)+ | otherwise+ = hexChar16 i hexChars32 :: [Int] -> String hexChars32 acts = concat (map conv32 acts) where conv32 i = hexChar16 (i .&. 0xffff) ++ - hexChar16 ((i `shiftR` 16) .&. 0xffff)+ hexChar16 ((i `shiftR` 16) .&. 0xffff) hexChar16 :: Int -> String hexChar16 i = toHex (i .&. 0xff)- ++ toHex ((i `shiftR` 8) .&. 0xff) -- force little-endian+ ++ toHex ((i `shiftR` 8) .&. 0xff) -- force little-endian toHex :: Int -> String toHex i = ['\\','x', hexDig (i `div` 16), hexDig (i `mod` 16)] hexDig :: Int -> Char hexDig i | i <= 9 = chr (i + ord '0')- | otherwise = chr (i - 10 + ord 'a')+ | otherwise = chr (i - 10 + ord 'a')
src/ParseMonad.hs view
@@ -7,11 +7,11 @@ -- ----------------------------------------------------------------------------} module ParseMonad (- AlexInput, alexInputPrevChar, alexGetChar, alexGetByte,- AlexPosn(..), alexStartPos,+ AlexInput, alexInputPrevChar, alexGetChar, alexGetByte,+ AlexPosn(..), alexStartPos, - P, runP, StartCode, failP, lookupSMac, lookupRMac, newSMac, newRMac,- setStartCode, getStartCode, getInput, setInput,+ P, runP, StartCode, failP, lookupSMac, lookupRMac, newSMac, newRMac,+ setStartCode, getStartCode, getInput, setInput, ) where import AbsSyn hiding ( StartCode )@@ -20,7 +20,9 @@ import qualified Map hiding ( Map ) import UTF8 +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ( Applicative(..) )+#endif import Control.Monad ( liftM, ap ) import Data.Word (Word8) -- -----------------------------------------------------------------------------@@ -29,10 +31,10 @@ type Byte = Word8 -type AlexInput = (AlexPosn, -- current position,- Char, -- previous char+type AlexInput = (AlexPosn, -- current position,+ Char, -- previous char [Byte],- String) -- current input string+ String) -- current input string alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (_,c,_,_) = c@@ -41,7 +43,7 @@ alexGetChar :: AlexInput -> Maybe (Char,AlexInput) alexGetChar (_,_,[],[]) = Nothing alexGetChar (p,_,[],(c:s)) = let p' = alexMove p c in p' `seq`- Just (c, (p', c, [], s))+ Just (c, (p', c, [], s)) alexGetChar (_, _ ,_ : _, _) = undefined -- hide compiler warning alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)@@ -62,7 +64,7 @@ -- assuming the usual eight character tab stops. data AlexPosn = AlexPn !Int !Int !Int- deriving (Eq,Show)+ deriving (Eq,Show) alexStartPos :: AlexPosn alexStartPos = AlexPn 0 1 1@@ -79,11 +81,11 @@ type StartCode = Int data PState = PState {- smac_env :: Map String CharSet,- rmac_env :: Map String RExp,- startcode :: Int,- input :: AlexInput- }+ smac_env :: Map String CharSet,+ rmac_env :: Map String RExp,+ startcode :: Int,+ input :: AlexInput+ } newtype P a = P { unP :: PState -> Either ParseError (PState,a) } @@ -96,19 +98,19 @@ instance Monad P where (P m) >>= k = P $ \env -> case m env of- Left err -> Left err- Right (env',ok) -> unP (k ok) env'+ Left err -> Left err+ Right (env',ok) -> unP (k ok) env' return a = P $ \env -> Right (env,a) runP :: String -> (Map String CharSet, Map String RExp) - -> P a -> Either ParseError a+ -> P a -> Either ParseError a runP str (senv,renv) (P p) = case p initial_state of- Left err -> Left err- Right (_,a) -> Right a+ Left err -> Left err+ Right (_,a) -> Right a where initial_state = - PState{ smac_env=senv, rmac_env=renv,- startcode = 0, input=(alexStartPos,'\n',[],str) }+ PState{ smac_env=senv, rmac_env=renv,+ startcode = 0, input=(alexStartPos,'\n',[],str) } failP :: String -> P a failP str = P $ \PState{ input = (p,_,_,_) } -> Left (Just p,str)@@ -121,15 +123,15 @@ lookupSMac (posn,smac) = P $ \s@PState{ smac_env = senv } -> case Map.lookup smac senv of- Just ok -> Right (s,ok)- Nothing -> Left (Just posn, "unknown set macro: $" ++ smac)+ Just ok -> Right (s,ok)+ Nothing -> Left (Just posn, "unknown set macro: $" ++ smac) lookupRMac :: String -> P RExp lookupRMac rmac = P $ \s@PState{ rmac_env = renv } -> case Map.lookup rmac renv of- Just ok -> Right (s,ok)- Nothing -> Left (Nothing, "unknown regex macro: %" ++ rmac)+ Just ok -> Right (s,ok)+ Nothing -> Left (Nothing, "unknown regex macro: %" ++ rmac) newSMac :: String -> CharSet -> P () newSMac smac set
src/Scan.hs view
@@ -63,7 +63,7 @@ | RMacT String | SMacDefT String | RMacDefT String - | NumT Int + | NumT Int | WrapperT | EOFT deriving Show@@ -90,7 +90,7 @@ isIdChar c = isAlphaNum c || c `elem` "_'" extract ln str = take (ln-2) (tail str)- + do_ech radix ln str = chr (parseInt radix str) mac ln (_ : str) = take (ln-1) str@@ -125,40 +125,40 @@ return (T p (CodeT (reverse (tail cs)))) go inp n cs = do case alexGetChar inp of- Nothing -> err inp- Just (c,inp) -> - case c of- '{' -> go inp (n+1) (c:cs) - '}' -> go inp (n-1) (c:cs)- '\'' -> go_char inp n (c:cs)- '\"' -> go_str inp n (c:cs) '\"'- c -> go inp n (c:cs)+ Nothing -> err inp+ Just (c,inp) -> + case c of+ '{' -> go inp (n+1) (c:cs) + '}' -> go inp (n-1) (c:cs)+ '\'' -> go_char inp n (c:cs)+ '\"' -> go_str inp n (c:cs) '\"'+ c -> go inp n (c:cs) - -- try to catch occurrences of ' within an identifier+ -- try to catch occurrences of ' within an identifier go_char inp n (c1:c2:cs) | isAlphaNum c2 = go inp n (c1:c2:cs) go_char inp n cs = go_str inp n cs '\'' go_str inp n cs end = do case alexGetChar inp of- Nothing -> err inp- Just (c,inp)- | c == end -> go inp n (c:cs)- | otherwise -> - case c of- '\\' -> case alexGetChar inp of- Nothing -> err inp- Just (d,inp) -> go_str inp n (d:c:cs) end- c -> go_str inp n (c:cs) end+ Nothing -> err inp+ Just (c,inp)+ | c == end -> go inp n (c:cs)+ | otherwise -> + case c of+ '\\' -> case alexGetChar inp of+ Nothing -> err inp+ Just (d,inp) -> go_str inp n (d:c:cs) end+ c -> go_str inp n (c:cs) end err inp = do setInput inp; lexError "lexical error in code fragment"- + lexError s = do (p,_,_,input) <- getInput failP (s ++ (if (not (null input))- then " at " ++ show (head input)- else " at end of file"))+ then " at " ++ show (head input)+ else " at end of file")) lexer :: (Token -> P a) -> P a lexer cont = lexToken >>= cont@@ -171,11 +171,11 @@ AlexEOF -> return (T p EOFT) AlexError _ -> lexError "lexical error" AlexSkip inp1 len -> do- setInput inp1- lexToken+ setInput inp1+ lexToken AlexToken inp1 len t -> do- setInput inp1- t (p,c,s) len+ setInput inp1+ t (p,c,s) len type Action = (AlexPosn,Char,String) -> Int -> P Token @@ -259,8 +259,8 @@ narrow32Int# i where !i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`- (b2 `uncheckedShiftL#` 16#) `or#`- (b1 `uncheckedShiftL#` 8#) `or#` b0)+ (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#)))@@ -299,30 +299,30 @@ alexScanUser user input (I# (sc)) = case alex_scan_tkn user input 0# input sc AlexNone of- (AlexNone, input') ->- case alexGetByte input of- Nothing -> + (AlexNone, input') ->+ case alexGetByte input of+ Nothing -> - AlexEOF- Just _ ->+ AlexEOF+ Just _ -> - AlexError input'+ AlexError input' - (AlexLastSkip input'' len, _) ->+ (AlexLastSkip input'' len, _) -> - AlexSkip input'' len+ AlexSkip input'' len - (AlexLastAcc k input''' len, _) ->+ (AlexLastAcc k input''' len, _) -> - AlexToken input''' len k+ AlexToken input''' len k -- Push the input through the DFA, remembering the most recent accepting@@ -331,7 +331,7 @@ 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))))+ new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) in new_acc `seq` case alexGetByte input of@@ -340,35 +340,35 @@ - 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)+ 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+ 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+ 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@@ -405,11 +405,11 @@ --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.+ (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
src/Sort.hs view
@@ -1,5 +1,5 @@ {------------------------------------------------------------------------------- SORTING LISTS+ SORTING LISTS This module provides properly parameterised insertion and merge sort functions, complete with associated functions for inserting and merging. `isort' is the@@ -40,24 +40,24 @@ runs :: (a->a->Bool) -> [a] -> [[a]] runs (<=) xs0 = foldr op [] xs0 where- op z xss@(xs@(x:_):xss') | z<=x = (z:xs):xss'+ op z xss@(xs@(x:_):xss') | z<=x = (z:xs):xss' | otherwise = [z]:xss- op z xss = [z]:xss+ op z xss = [z]:xss foldb :: (a->a->a) -> [a] -> a foldb _ [x] = x foldb f xs0 = foldb f (fold xs0) where- fold (x1:x2:xs) = f x1 x2 : fold xs- fold xs = xs+ fold (x1:x2:xs) = f x1 x2 : fold xs+ fold xs = xs mrg:: (a->a->Bool) -> [a] -> [a] -> [a] mrg _ [] l = l mrg _ l@(_:_) [] = l mrg (<=) l1@(h1:t1) l2@(h2:t2) =- if h1<=h2- then h1:mrg (<=) t1 l2- else h2:mrg (<=) l1 t2+ if h1<=h2+ then h1:mrg (<=) t1 l2+ else h2:mrg (<=) l1 t2 nub':: (a->a->Bool) -> [a] -> [a]@@ -66,6 +66,6 @@ group_sort:: (a->a->Bool) -> (a->[a]->b) -> [a] -> [b] group_sort le cmb l = s_m (msort le l)- where- s_m [] = []- s_m (h:t) = cmb h (takeWhile (`le` h) t):s_m (dropWhile (`le` h) t)+ where+ s_m [] = []+ s_m (h:t) = cmb h (takeWhile (`le` h) t):s_m (dropWhile (`le` h) t)
templates/GenericTemplate.hs view
@@ -79,8 +79,8 @@ narrow32Int# i where i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`- (b2 `uncheckedShiftL#` 16#) `or#`- (b1 `uncheckedShiftL#` 8#) `or#` b0)+ (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#)))@@ -120,30 +120,30 @@ alexScanUser user input IBOX(sc) = case alex_scan_tkn user input ILIT(0) input sc AlexNone of- (AlexNone, input') ->- case alexGetByte input of- Nothing -> + (AlexNone, input') ->+ case alexGetByte input of+ Nothing -> #ifdef ALEX_DEBUG- trace ("End of input.") $+ trace ("End of input.") $ #endif- AlexEOF- Just _ ->+ AlexEOF+ Just _ -> #ifdef ALEX_DEBUG- trace ("Error.") $+ trace ("Error.") $ #endif- AlexError input'+ AlexError input' - (AlexLastSkip input'' len, _) ->+ (AlexLastSkip input'' len, _) -> #ifdef ALEX_DEBUG- trace ("Skipping.") $ + trace ("Skipping.") $ #endif- AlexSkip input'' len+ AlexSkip input'' len - (AlexLastAcc k input''' len, _) ->+ (AlexLastAcc k input''' len, _) -> #ifdef ALEX_DEBUG- trace ("Accept.") $ + trace ("Accept.") $ #endif- AlexToken input''' len k+ AlexToken input''' len k -- Push the input through the DFA, remembering the most recent accepting@@ -152,7 +152,7 @@ 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` IBOX(s)))+ new_acc = (check_accs (alex_accept `quickIndex` IBOX(s))) in new_acc `seq` case alexGetByte input of@@ -166,34 +166,34 @@ base = alexIndexInt32OffAddr alex_base s offset = PLUS(base,ord_c) check = alexIndexInt16OffAddr alex_check offset- + new_s = if GTE(offset,ILIT(0)) && EQ(check,ord_c)- then alexIndexInt16OffAddr alex_table offset- else alexIndexInt16OffAddr alex_deflt s- in+ then alexIndexInt16OffAddr alex_table offset+ else alexIndexInt16OffAddr alex_deflt s+ in case new_s of- ILIT(-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 PLUS(len,ILIT(1)) else len)+ ILIT(-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 PLUS(len,ILIT(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+ new_input new_s new_acc } where- check_accs (AlexAccNone) = last_acc- check_accs (AlexAcc a ) = AlexLastAcc a input IBOX(len)- check_accs (AlexAccSkip) = AlexLastSkip input IBOX(len)+ check_accs (AlexAccNone) = last_acc+ check_accs (AlexAcc a ) = AlexLastAcc a input IBOX(len)+ check_accs (AlexAccSkip) = AlexLastSkip input IBOX(len) #ifndef ALEX_NOPRED- check_accs (AlexAccPred a predx rest)- | predx user orig_input IBOX(len) input- = AlexLastAcc a input IBOX(len)- | otherwise- = check_accs rest- check_accs (AlexAccSkipPred predx rest)- | predx user orig_input IBOX(len) input- = AlexLastSkip input IBOX(len)- | otherwise- = check_accs rest+ check_accs (AlexAccPred a predx rest)+ | predx user orig_input IBOX(len) input+ = AlexLastAcc a input IBOX(len)+ | otherwise+ = check_accs rest+ check_accs (AlexAccSkipPred predx rest)+ | predx user orig_input IBOX(len) input+ = AlexLastSkip input IBOX(len)+ | otherwise+ = check_accs rest #endif data AlexLastAcc a@@ -202,9 +202,9 @@ | AlexLastSkip !AlexInput !Int instance Functor AlexLastAcc where- fmap f AlexNone = AlexNone+ fmap _ AlexNone = AlexNone fmap f (AlexLastAcc x y z) = AlexLastAcc (f x) y z- fmap f (AlexLastSkip x y) = AlexLastSkip x y+ fmap _ (AlexLastSkip x y) = AlexLastSkip x y data AlexAcc a user = AlexAccNone@@ -233,12 +233,9 @@ --alexRightContext :: Int -> AlexAccPred _ alexRightContext IBOX(sc) user _ _ input = case alex_scan_tkn user input ILIT(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.+ (AlexNone, _) -> False+ _ -> True+ -- TODO: there's no need to find the longest+ -- match when checking the right context, just+ -- the first match will do. #endif---- used by wrappers-iUnbox IBOX(i) = i
templates/wrappers.hs view
@@ -5,7 +5,9 @@ -- it for any purpose whatsoever. import Control.Applicative (Applicative (..))+import qualified Control.Monad (ap) import Data.Word (Word8)+import Data.Int (Int64) #if defined(ALEX_BASIC_BYTESTRING) || defined(ALEX_POSN_BYTESTRING) || defined(ALEX_MONAD_BYTESTRING) import qualified Data.Char@@ -21,6 +23,7 @@ #else +import Data.Char (ord) import qualified Data.Bits -- | Encode a Haskell String to a list of Word8 values, in UTF8 format.@@ -74,50 +77,59 @@ #if defined(ALEX_POSN_BYTESTRING) || defined(ALEX_MONAD_BYTESTRING) type AlexInput = (AlexPosn, -- current position, Char, -- previous char- ByteString.ByteString) -- current input string+ 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 (p,c,s) = c+alexInputPrevChar (_,c,_,_) = c alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)-alexGetByte (p,_,cs) | ByteString.null cs = Nothing- | otherwise = let b = ByteString.head cs- cs' = ByteString.tail cs- c = ByteString.w2c b- p' = alexMove p c- in p' `seq` cs' `seq` Just (b, (p', c, cs'))+alexGetByte (p,_,cs,n) | ByteString.null cs = Nothing+ | otherwise = let b = ByteString.head cs+ cs' = ByteString.tail cs+ c = ByteString.w2c b+ p' = alexMove p c+ n' = n+1+ in p' `seq` cs' `seq` n' `seq` Just (b, (p', c, cs',n')) #endif #ifdef ALEX_BASIC_BYTESTRING-type AlexInput = (Char,- ByteString.ByteString)+data AlexInput = AlexInput { alexChar :: {-# UNPACK #-} !Char,+ alexStr :: !ByteString.ByteString,+ alexBytePos :: {-# UNPACK #-} !Int64} alexInputPrevChar :: AlexInput -> Char-alexInputPrevChar (c,_) = c+alexInputPrevChar = alexChar -alexGetByte (_, cs)+alexGetByte (AlexInput {alexStr=cs,alexBytePos=n}) | ByteString.null cs = Nothing- | otherwise = Just (ByteString.head cs,- (ByteString.w2c $ ByteString.head cs,- ByteString.tail cs))+ | otherwise =+ Just (ByteString.head cs,+ AlexInput {+ alexChar = ByteString.w2c $ ByteString.head cs,+ alexStr = ByteString.tail cs,+ alexBytePos = n+1}) #endif #ifdef ALEX_STRICT_BYTESTRING-data AlexInput = AlexInput { alexChar :: {-# UNPACK #-}!Char- , alexStr :: {-# UNPACK #-}!ByteString.ByteString }+data AlexInput = AlexInput { alexChar :: {-# UNPACK #-} !Char,+ alexStr :: {-# UNPACK #-} !ByteString.ByteString,+ alexBytePos :: {-# UNPACK #-} !Int} alexInputPrevChar :: AlexInput -> Char alexInputPrevChar = alexChar -alexGetByte (AlexInput _ cs)- | ByteString.null cs = Nothing- | otherwise = Just $! (ByteString.head cs, AlexInput c cs')- where- (c,cs') = (ByteString.w2c (ByteString.unsafeHead cs)- , ByteString.unsafeTail cs)+alexGetByte (AlexInput {alexStr=cs,alexBytePos=n})+ | ByteString.null cs = Nothing+ | otherwise =+ Just $! (ByteString.head cs,+ AlexInput {+ alexChar = ByteString.w2c $ ByteString.unsafeHead cs,+ alexStr = ByteString.unsafeTail cs,+ alexBytePos = n+1}) #endif -- -----------------------------------------------------------------------------@@ -138,7 +150,7 @@ alexStartPos = AlexPn 0 1 1 alexMove :: AlexPosn -> Char -> AlexPosn-alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+7) `div` 8)*8+1)+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 c) '\n' = AlexPn (a+1) (l+1) 1 alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) #endif@@ -261,6 +273,7 @@ #ifdef ALEX_MONAD_BYTESTRING 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@@ -274,6 +287,7 @@ 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', #ifdef ALEX_MONAD_USER_STATE@@ -284,6 +298,13 @@ 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 = return+ (<*>) = Control.Monad.ap+ instance Monad Alex where m >>= k = Alex $ \s -> case unAlex m s of Left msg -> Left msg@@ -292,12 +313,15 @@ alexGetInput :: Alex AlexInput alexGetInput- = Alex $ \s@AlexState{alex_pos=pos,alex_chr=c,alex_inp=inp} -> - Right (s, (pos,c,inp))+ = 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)- = Alex $ \s -> case s{alex_pos=pos,alex_chr=c,alex_inp=inp} of+alexSetInput (pos,c,inp,bpos)+ = Alex $ \s -> case s{alex_pos=pos,+ alex_bpos=bpos,+ alex_chr=c,+ alex_inp=inp} of s@(AlexState{}) -> Right (s, ()) alexError :: String -> Alex a@@ -310,24 +334,24 @@ alexSetStartCode sc = Alex $ \s -> Right (s{alex_scd=sc}, ()) alexMonadScan = do- inp@(_,_,str) <- alexGetInput+ inp@(_,_,str,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)+ AlexError ((AlexPn _ line column),_,_,_) -> alexError $ "lexical error at line " ++ (show line) ++ ", column " ++ (show column) AlexSkip inp' len -> do alexSetInput inp' alexMonadScan- AlexToken inp'@(_,_,str') len action -> do+ AlexToken inp'@(_,_,_,n') _ action -> do alexSetInput inp' action (ignorePendingBytes inp) len where- len = ByteString.length str - ByteString.length str'+ len = n'-n -- ----------------------------------------------------------------------------- -- Useful token actions -type AlexAction result = AlexInput -> Int -> Alex result+type AlexAction result = AlexInput -> Int64 -> Alex result -- just ignore this token and scan another one -- skip :: AlexAction result@@ -341,7 +365,7 @@ andBegin :: AlexAction result -> Int -> AlexAction result (action `andBegin` code) input len = do alexSetStartCode code; action input len -token :: (AlexInput -> Int -> token) -> AlexAction token+token :: (AlexInput -> Int64 -> token) -> AlexAction token token t input len = return (t input len) #endif /* ALEX_MONAD_BYTESTRING */ @@ -379,28 +403,32 @@ #ifdef ALEX_BASIC_BYTESTRING -- alexScanTokens :: String -> [token]-alexScanTokens str = go ('\n',str)- where go inp@(_,str) =+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'@(_,str') _ act -> act (ByteString.take len str) : go inp'- where len = ByteString.length str - ByteString.length str'+ AlexToken inp' _ act -> + let str = alexStr inp+ len = alexBytePos inp' - alexBytePos inp in+ act (ByteString.take len str) : go inp' #endif #ifdef ALEX_STRICT_BYTESTRING -- alexScanTokens :: String -> [token]-alexScanTokens str = go (AlexInput '\n' str)- where go inp@(AlexInput _ str) =+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'@(AlexInput _ str') _ act -> act (ByteString.unsafeTake len str) : go inp'- where len = ByteString.length str - ByteString.length str'+ AlexToken inp' _ act -> + let str = alexStr inp+ len = alexBytePos inp' - alexBytePos inp in+ act (ByteString.take len str) : go inp' #endif @@ -427,13 +455,14 @@ #ifdef ALEX_POSN_BYTESTRING --alexScanTokens :: ByteString -> [token]-alexScanTokens str = go (alexStartPos,'\n',str)- where go inp@(pos,_,str) =+alexScanTokens str = go (alexStartPos,'\n',str,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)+ AlexError ((AlexPn _ line column),_,_,_) -> error $ "lexical error at line " ++ (show line) ++ ", column " ++ (show column) AlexSkip inp' len -> go inp'- AlexToken inp' len act -> act pos (ByteString.take (fromIntegral len) str) : go inp'+ AlexToken inp'@(_,_,_,n') _ act ->+ act pos (ByteString.take (n'-n) str) : go inp' #endif
tests/Makefile view
@@ -1,6 +1,6 @@ ALEX=../dist/build/alex/alex HC=ghc-HC_OPTS=-Wall -fno-warn-unused-binds -fno-warn-missing-signatures -fno-warn-unused-matches -fno-warn-name-shadowing -fno-warn-unused-imports+HC_OPTS=-Wall -fno-warn-unused-binds -fno-warn-missing-signatures -fno-warn-unused-matches -fno-warn-name-shadowing -fno-warn-unused-imports -fno-warn-tabs -Werror .PRECIOUS: %.n.hs %.g.hs %.o %.exe %.bin
tests/tokens_monadUserState_bytestring.x view
@@ -24,7 +24,7 @@ -- Each right-hand side has type :: AlexPosn -> String -> Token -- Some action helpers:-tok f (p,_,input) len = return (f p (B.take (fromIntegral len) input))+tok f (p,_,input,_) len = return (f p (B.take (fromIntegral len) input)) -- The token type: data Token =
tests/tokens_monad_bytestring.x view
@@ -24,7 +24,7 @@ -- Each right-hand side has type :: AlexPosn -> String -> Token -- Some action helpers:-tok f (p,_,input) len = return (f p (B.take (fromIntegral len) input))+tok f (p,_,input,_) len = return (f p (B.take (fromIntegral len) input)) -- The token type: data Token =