alex 3.2.7.3 → 3.2.7.4
raw patch · 8 files changed
+210/−196 lines, 8 files
Files
- CHANGELOG.md +9/−0
- alex.cabal +2/−2
- examples/Makefile +1/−2
- src/Main.hs +2/−2
- src/Scan.hs +172/−171
- src/Sort.hs +2/−15
- src/Util.hs +0/−4
- tests/default_typeclass.x +22/−0
CHANGELOG.md view
@@ -1,3 +1,12 @@+## Change in 3.2.7.4++ * The user-supplied "epilogue" Haskell code is now put _last_ in the generated file.+ This enables use of Template Haskell in the epilogue.+ (Issue [#125](https://github.com/haskell/alex/issues/125).)+ * Tested with GHC 7.0 - 9.6.1.++_Andreas Abel, 2023-05-02_+ ## Change in 3.2.7.3 * Amend last change (3.2.7.2)
alex.cabal view
@@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: alex-version: 3.2.7.3+version: 3.2.7.4 -- don't forget updating changelog.md! license: BSD3 license-file: LICENSE@@ -23,7 +23,7 @@ tested-with: GHC == 9.6.1- GHC == 9.4.4+ GHC == 9.4.5 GHC == 9.2.7 GHC == 9.0.2 GHC == 8.10.7
examples/Makefile view
@@ -12,8 +12,7 @@ PROGS = lit Tokens Tokens_gscan words words_posn words_monad tiny haskell tiger -ALEX_OPTS = --template=.. -g-# ALEX_OPTS = --template=..+ALEX_OPTS = --template=../data/ -g %.alex.hs : %.x $(ALEX) $(ALEX_OPTS) $< -o $@
src/Main.hs view
@@ -228,8 +228,6 @@ put_info (infoDFA 1 nm min_dfa "") hPutStr out_h (outputDFA target 1 nm scheme min_dfa "") - injectCode maybe_footer file out_h- hPutStr out_h (sc_hdr "") hPutStr out_h (actions "") @@ -241,6 +239,8 @@ | i <- cppDefs ] tmplt <- alexReadFile $ template_dir ++ "/AlexTemplate.hs" hPutStr out_h tmplt++ injectCode maybe_footer file out_h hClose out_h finish_info
src/Scan.hs view
@@ -271,176 +271,7 @@ , (0,alex_action_8) ] -{-# LINE 84 "src/Scan.x" #-}--- -------------------------------------------------------------------------------- Token type -data Token = T AlexPosn Tkn- deriving Show--tokPosn (T p _) = p--data Tkn- = SpecialT Char- | CodeT String- | ZeroT- | IdT String- | StringT String- | BindT String- | CharT Char- | SMacT String- | RMacT String- | SMacDefT String- | RMacDefT String- | NumT Int- | WrapperT- | EncodingT- | ActionTypeT- | TokenTypeT- | TypeClassT- | EOFT- deriving Show---- -------------------------------------------------------------------------------- Token functions--special, zero, string, bind, escape, decch, hexch, octch, char :: Action-smac, rmac, smacdef, rmacdef, startcode, wrapper, encoding :: Action-actionty, tokenty, typeclass :: Action-special (p,_,str) _ = return $ T p (SpecialT (head str))-zero (p,_,_) _ = return $ T p ZeroT-string (p,_,str) ln = return $ T p (StringT (extract ln str))-bind (p,_,str) _ = return $ T p (BindT (takeWhile isIdChar str))-escape (p,_,str) _ = return $ T p (CharT (esc str))-decch (p,_,str) ln = return $ T p (CharT (do_ech 10 ln (take (ln-1) (tail str))))-hexch (p,_,str) ln = return $ T p (CharT (do_ech 16 ln (take (ln-2) (drop 2 str))))-octch (p,_,str) ln = return $ T p (CharT (do_ech 8 ln (take (ln-2) (drop 2 str))))-char (p,_,str) _ = return $ T p (CharT (head str))-num (p,_,str) ln = return $ T p $ NumT $ parseInt 10 $ take ln str-smac (p,_,str) ln = return $ T p (SMacT (mac ln str))-rmac (p,_,str) ln = return $ T p (RMacT (mac ln str))-smacdef (p,_,str) ln = return $ T p (SMacDefT (macdef ln str))-rmacdef (p,_,str) ln = return $ T p (RMacDefT (macdef ln str))-startcode (p,_,str) ln = return $ T p (IdT (take ln str))-wrapper (p,_,_) _ = return $ T p WrapperT-encoding (p,_,_) _ = return $ T p EncodingT-actionty (p,_,_) _ = return $ T p ActionTypeT-tokenty (p,_,_) _ = return $ T p TokenTypeT-typeclass (p,_,_) _ = return $ T p TypeClassT--isIdChar :: Char -> Bool-isIdChar c = isAlphaNum c || c `elem` "_'"--extract :: Int -> String -> String-extract ln str = take (ln-2) (tail str)--do_ech :: Int -> Int -> String -> Char-do_ech radix _ln str = chr (parseInt radix str)--mac :: Int -> String -> String-mac ln str = take (ln-1) $ tail str---- TODO : replace not . isSpace with (\c -> not (isSpace c) && c /= '=')-macdef :: Int -> String -> String-macdef _ln str = takeWhile (\c -> not (isSpace c) && c /= '=') $ tail str--esc :: String -> Char-esc str =- case head $ tail str of- 'a' -> '\a'- 'b' -> '\b'- 'f' -> '\f'- 'n' -> '\n'- 'r' -> '\r'- 't' -> '\t'- 'v' -> '\v'- c -> c--parseInt :: Int -> String -> Int-parseInt radix ds = foldl1 (\n d -> n * radix + d) (map digitToInt ds)---- In brace-delimited code, we have to be careful to match braces--- within the code, but ignore braces inside strings and character--- literals. We do an approximate job (doing it properly requires--- implementing a large chunk of the Haskell lexical syntax).--code :: Action-code (p,_,_inp) _ = do- currentInput <- getInput- go currentInput 1 ""- where- go :: AlexInput -> Int -> String -> P Token- go inp 0 cs = do- setInput inp- return $ T p $ CodeT $ triml $ reverse $ triml $ tail cs- go inp n cs = do- case alexGetChar inp of- Nothing -> err inp- Just (c,inp2) ->- case c of- '{' -> go inp2 (n+1) (c:cs)- '}' -> go inp2 (n-1) (c:cs)- '\'' -> go_char inp2 n (c:cs)- '\"' -> go_str inp2 n (c:cs) '\"'- c2 -> go inp2 n (c2:cs)-- go_char :: AlexInput -> Int -> String -> P Token- -- try to catch multiple occurrences of ' at identifier end- go_char inp n cs@('\'':'\'':_) = go inp n cs- -- try to catch occurrences of ' within an identifier- go_char inp n cs@('\'':c2:_)- | isAlphaNum c2 = go inp n cs- go_char inp n cs = go_str inp n cs '\''-- go_str :: AlexInput -> Int -> String -> Char -> P Token- go_str inp n cs end = do- case alexGetChar inp of- Nothing -> err inp- Just (c,inp2)- | c == end -> go inp2 n (c:cs)- | otherwise ->- case c of- '\\' -> case alexGetChar inp2 of- Nothing -> err inp2- Just (d,inp3) -> go_str inp3 n (d:c:cs) end- c2 -> go_str inp2 n (c2:cs) end-- err inp = do setInput inp; lexError "lexical error in code fragment"-- triml = dropWhile isSpace--lexError :: String -> P a-lexError s = do- (_,_,_,input) <- getInput- failP (s ++ (if (not (null input))- then " at " ++ show (head input)- else " at end of file"))--lexer :: (Token -> P a) -> P a-lexer cont = lexToken >>= cont--lexToken :: P Token-lexToken = do- inp@(p,c,_,s) <- getInput- sc <- getStartCode- case alexScan inp sc of- AlexEOF -> return (T p EOFT)- AlexError _ -> lexError "lexical error"- AlexSkip inp1 _ -> do- setInput inp1- lexToken- AlexToken inp1 len t -> do- setInput inp1- t (p,c,s) len--type Action = (AlexPosn,Char,String) -> Int -> P Token--skip :: Action-skip _ _ = lexToken--andBegin :: Action -> StartCode -> Action-andBegin act sc inp len = setStartCode sc >> act inp len- afterstartcodes,multiplicity,startcodes :: Int afterstartcodes = 1 multiplicity = 2@@ -639,9 +470,10 @@ let 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)+ new_s = if GTE(offset,ILIT(0))+ && let check = alexIndexInt16OffAddr alex_check offset+ in EQ(check,ord_c) then alexIndexInt16OffAddr alex_table offset else alexIndexInt16OffAddr alex_deflt s in@@ -714,3 +546,172 @@ -- match when checking the right context, just -- the first match will do. #endif+{-# LINE 84 "src/Scan.x" #-}+-- -----------------------------------------------------------------------------+-- Token type++data Token = T AlexPosn Tkn+ deriving Show++tokPosn (T p _) = p++data Tkn+ = SpecialT Char+ | CodeT String+ | ZeroT+ | IdT String+ | StringT String+ | BindT String+ | CharT Char+ | SMacT String+ | RMacT String+ | SMacDefT String+ | RMacDefT String+ | NumT Int+ | WrapperT+ | EncodingT+ | ActionTypeT+ | TokenTypeT+ | TypeClassT+ | EOFT+ deriving Show++-- -----------------------------------------------------------------------------+-- Token functions++special, zero, string, bind, escape, decch, hexch, octch, char :: Action+smac, rmac, smacdef, rmacdef, startcode, wrapper, encoding :: Action+actionty, tokenty, typeclass :: Action+special (p,_,str) _ = return $ T p (SpecialT (head str))+zero (p,_,_) _ = return $ T p ZeroT+string (p,_,str) ln = return $ T p (StringT (extract ln str))+bind (p,_,str) _ = return $ T p (BindT (takeWhile isIdChar str))+escape (p,_,str) _ = return $ T p (CharT (esc str))+decch (p,_,str) ln = return $ T p (CharT (do_ech 10 ln (take (ln-1) (tail str))))+hexch (p,_,str) ln = return $ T p (CharT (do_ech 16 ln (take (ln-2) (drop 2 str))))+octch (p,_,str) ln = return $ T p (CharT (do_ech 8 ln (take (ln-2) (drop 2 str))))+char (p,_,str) _ = return $ T p (CharT (head str))+num (p,_,str) ln = return $ T p $ NumT $ parseInt 10 $ take ln str+smac (p,_,str) ln = return $ T p (SMacT (mac ln str))+rmac (p,_,str) ln = return $ T p (RMacT (mac ln str))+smacdef (p,_,str) ln = return $ T p (SMacDefT (macdef ln str))+rmacdef (p,_,str) ln = return $ T p (RMacDefT (macdef ln str))+startcode (p,_,str) ln = return $ T p (IdT (take ln str))+wrapper (p,_,_) _ = return $ T p WrapperT+encoding (p,_,_) _ = return $ T p EncodingT+actionty (p,_,_) _ = return $ T p ActionTypeT+tokenty (p,_,_) _ = return $ T p TokenTypeT+typeclass (p,_,_) _ = return $ T p TypeClassT++isIdChar :: Char -> Bool+isIdChar c = isAlphaNum c || c `elem` "_'"++extract :: Int -> String -> String+extract ln str = take (ln-2) (tail str)++do_ech :: Int -> Int -> String -> Char+do_ech radix _ln str = chr (parseInt radix str)++mac :: Int -> String -> String+mac ln str = take (ln-1) $ tail str++-- TODO : replace not . isSpace with (\c -> not (isSpace c) && c /= '=')+macdef :: Int -> String -> String+macdef _ln str = takeWhile (\c -> not (isSpace c) && c /= '=') $ tail str++esc :: String -> Char+esc str =+ case head $ tail str of+ 'a' -> '\a'+ 'b' -> '\b'+ 'f' -> '\f'+ 'n' -> '\n'+ 'r' -> '\r'+ 't' -> '\t'+ 'v' -> '\v'+ c -> c++parseInt :: Int -> String -> Int+parseInt radix ds = foldl1 (\n d -> n * radix + d) (map digitToInt ds)++-- In brace-delimited code, we have to be careful to match braces+-- within the code, but ignore braces inside strings and character+-- literals. We do an approximate job (doing it properly requires+-- implementing a large chunk of the Haskell lexical syntax).++code :: Action+code (p,_,_inp) _ = do+ currentInput <- getInput+ go currentInput 1 ""+ where+ go :: AlexInput -> Int -> String -> P Token+ go inp 0 cs = do+ setInput inp+ return $ T p $ CodeT $ triml $ reverse $ triml $ tail cs+ go inp n cs = do+ case alexGetChar inp of+ Nothing -> err inp+ Just (c,inp2) ->+ case c of+ '{' -> go inp2 (n+1) (c:cs)+ '}' -> go inp2 (n-1) (c:cs)+ '\'' -> go_char inp2 n (c:cs)+ '\"' -> go_str inp2 n (c:cs) '\"'+ c2 -> go inp2 n (c2:cs)++ go_char :: AlexInput -> Int -> String -> P Token+ -- try to catch multiple occurrences of ' at identifier end+ go_char inp n cs@('\'':'\'':_) = go inp n cs+ -- try to catch occurrences of ' within an identifier+ go_char inp n cs@('\'':c2:_)+ | isAlphaNum c2 = go inp n cs+ go_char inp n cs = go_str inp n cs '\''++ go_str :: AlexInput -> Int -> String -> Char -> P Token+ go_str inp n cs end = do+ case alexGetChar inp of+ Nothing -> err inp+ Just (c,inp2)+ | c == end -> go inp2 n (c:cs)+ | otherwise ->+ case c of+ '\\' -> case alexGetChar inp2 of+ Nothing -> err inp2+ Just (d,inp3) -> go_str inp3 n (d:c:cs) end+ c2 -> go_str inp2 n (c2:cs) end++ err inp = do setInput inp; lexError "lexical error in code fragment"++ triml = dropWhile isSpace++lexError :: String -> P a+lexError s = do+ (_,_,_,input) <- getInput+ failP (s ++ (if (not (null input))+ then " at " ++ show (head input)+ else " at end of file"))++lexer :: (Token -> P a) -> P a+lexer cont = lexToken >>= cont++lexToken :: P Token+lexToken = do+ inp@(p,c,_,s) <- getInput+ sc <- getStartCode+ case alexScan inp sc of+ AlexEOF -> return (T p EOFT)+ AlexError _ -> lexError "lexical error"+ AlexSkip inp1 _ -> do+ setInput inp1+ lexToken+ AlexToken inp1 len t -> do+ setInput inp1+ t (p,c,s) len++type Action = (AlexPosn,Char,String) -> Int -> P Token++skip :: Action+skip _ _ = lexToken++andBegin :: Action -> StartCode -> Action+andBegin act sc inp len = setStartCode sc >> act inp len
src/Sort.hs view
@@ -1,10 +1,8 @@ {------------------------------------------------------------------------------ SORTING LISTS -This module provides properly parameterised insertion and merge sort functions,-complete with associated functions for inserting and merging. `isort' is the-standard lazy version and can be used to the minimum k elements of a list in-linear time. The merge sort is based on a Bob Buckley's (Bob Buckley+This module provides a properly parameterised merge sort function, complete+with associated functions. It is based on a Bob Buckley's (Bob Buckley 18-AUG-95) coding of Knuth's natural merge sort (see Vol. 2). It seems to be fast in the average case; it makes use of natural runs in the data becomming linear on ordered data; and it completes in worst time O(n.log(n)). It is@@ -21,17 +19,6 @@ -- Hide (<=) so that we don't get name shadowing warnings for it import Prelude hiding ((<=))---- `isort' is an insertion sort and is here for historical reasons; msort is--- better in almost every situation.--isort:: (a->a->Bool) -> [a] -> [a]-isort (<=) = foldr (insrt (<=)) []--insrt:: (a->a->Bool) -> a -> [a] -> [a]-insrt _ e [] = [e]-insrt (<=) e l@(h:t) = if e<=h then e:l else h:insrt (<=) e t- msort :: (a->a->Bool) -> [a] -> [a] msort _ [] = [] -- (foldb f []) is undefined
src/Util.hs view
@@ -13,7 +13,6 @@ , char , nl , paren- , brack , interleave_shows , space , cjustify@@ -36,9 +35,6 @@ paren :: (String -> String) -> String -> String paren s = char '(' . s . char ')'--brack :: (String -> String) -> String -> String-brack s = char '[' . s . char ']' interleave_shows :: (String -> String) -> [String -> String] -> String -> String interleave_shows _ [] = id
tests/default_typeclass.x view
@@ -1,6 +1,7 @@ { {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-} -- issue #125 module Main (main) where import System.Exit@@ -309,5 +310,26 @@ instance (Functor m, Monad m) => Applicative (StateT s m) where pure a = state $ \s -> (a, s) (<*>) = ap++-- Andreas Abel, 2023-04-14, issue #125+-- It should be possible to put some Template Haskell here, e.g.+-- @+-- makeLenses ''AlexState+-- @+-- (with 'makeLenses' from 'lens' or 'microlens-th').+--+-- For this to work this "epilogue" code must come last in the generated file.+-- Otherwise, we get scope errors, e.g.+--+-- default_typeclass.x:157:5: error: [GHC-76037]+-- Not in scope: data constructor ‘AlexError’+-- |+-- 157 | case alexScan inp sc of+-- | ^^^^^^^^^+--+-- It is hard to test 'makeLenses' here because we would need a dependency,+-- but just any Template Haskell instruction seems to trigger issue #125.+-- Thus, we confine ourselves to:+return [] }