diff --git a/ANNOUNCE b/ANNOUNCE --- a/ANNOUNCE +++ b/ANNOUNCE @@ -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. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -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) diff --git a/alex.cabal b/alex.cabal --- a/alex.cabal +++ b/alex.cabal @@ -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 diff --git a/doc/alex.xml b/doc/alex.xml --- a/doc/alex.xml +++ b/doc/alex.xml @@ -69,7 +69,7 @@ - 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. diff --git a/examples/Makefile b/examples/Makefile --- a/examples/Makefile +++ b/examples/Makefile @@ -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: diff --git a/src/AbsSyn.hs b/src/AbsSyn.hs --- a/src/AbsSyn.hs +++ b/src/AbsSyn.hs @@ -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 diff --git a/src/CharSet.hs b/src/CharSet.hs --- a/src/CharSet.hs +++ b/src/CharSet.hs @@ -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 diff --git a/src/DFA.hs b/src/DFA.hs --- a/src/DFA.hs +++ b/src/DFA.hs @@ -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 -} diff --git a/src/DFS.hs b/src/DFS.hs --- a/src/DFS.hs +++ b/src/DFS.hs @@ -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 -} diff --git a/src/Data/Ranged/Boundaries.hs b/src/Data/Ranged/Boundaries.hs --- a/src/Data/Ranged/Boundaries.hs +++ b/src/Data/Ranged/Boundaries.hs @@ -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 diff --git a/src/Data/Ranged/RangedSet.hs b/src/Data/Ranged/RangedSet.hs --- a/src/Data/Ranged/RangedSet.hs +++ b/src/Data/Ranged/RangedSet.hs @@ -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 diff --git a/src/Info.hs b/src/Info.hs --- a/src/Info.hs +++ b/src/Info.hs @@ -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) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/NFA.hs b/src/NFA.hs --- a/src/NFA.hs +++ b/src/NFA.hs @@ -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 diff --git a/src/Output.hs b/src/Output.hs --- a/src/Output.hs +++ b/src/Output.hs @@ -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') diff --git a/src/ParseMonad.hs b/src/ParseMonad.hs --- a/src/ParseMonad.hs +++ b/src/ParseMonad.hs @@ -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 diff --git a/src/Scan.hs b/src/Scan.hs --- a/src/Scan.hs +++ b/src/Scan.hs @@ -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 diff --git a/src/Sort.hs b/src/Sort.hs --- a/src/Sort.hs +++ b/src/Sort.hs @@ -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) diff --git a/templates/GenericTemplate.hs b/templates/GenericTemplate.hs --- a/templates/GenericTemplate.hs +++ b/templates/GenericTemplate.hs @@ -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 diff --git a/templates/wrappers.hs b/templates/wrappers.hs --- a/templates/wrappers.hs +++ b/templates/wrappers.hs @@ -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 diff --git a/tests/Makefile b/tests/Makefile --- a/tests/Makefile +++ b/tests/Makefile @@ -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 diff --git a/tests/tokens_monadUserState_bytestring.x b/tests/tokens_monadUserState_bytestring.x --- a/tests/tokens_monadUserState_bytestring.x +++ b/tests/tokens_monadUserState_bytestring.x @@ -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 = diff --git a/tests/tokens_monad_bytestring.x b/tests/tokens_monad_bytestring.x --- a/tests/tokens_monad_bytestring.x +++ b/tests/tokens_monad_bytestring.x @@ -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 =