language-lua 0.7.1 → 0.8.0
raw patch · 11 files changed
+764/−178 lines, 11 filesdep +bytestringdep −safe
Dependencies added: bytestring
Dependencies removed: safe
Files
- CHANGELOG.md +28/−0
- language-lua.cabal +7/−4
- lua-5.3.1-tests/utf8.lua +209/−0
- src/Language/Lua/Annotated/Lexer.x +170/−150
- src/Language/Lua/Annotated/Parser.hs +13/−4
- src/Language/Lua/Annotated/Syntax.hs +4/−0
- src/Language/Lua/PrettyPrinter.hs +3/−3
- src/Language/Lua/StringLiteral.hs +159/−0
- src/Language/Lua/Token.hs +1/−1
- tests/Main.hs +141/−16
- tests/string-literal-roundtrip.lua +29/−0
CHANGELOG.md view
@@ -1,5 +1,33 @@ ## Changelog +#### 0.8.0++- A bug that caused wrong long comment parsing is fixed(#29).++- We can now parse Unicode strings from UTF-8 encoded files. By default these+ literals are not interpreted, and we have+ `StringLiteral.interpretStringLiteral` for interpretation and+ `StringLiteral.constructStringLiteral` for constructing Lua string literals+ from UTF-8 encoded ByteStrings.++ Main invariant is that if you print a parsed Lua string, it should be printed+ the same way. (including long strings)++- Empty statements(`EmptyStat`) are now printed by pretty printer to avoid+ ambiguous printing. Previously these two statements were printed the same:++ ```lua+ f();(f)()+ f()(f)()+ ```++ But the first line does not have the parse ambiguity(3 function applications+ in one statement or two function application statements).++- Forgotten `Annotated` instance for `Name` implemented.++- Some warnings are fixed for GHC < 7.10.+ #### 0.7.1 - Integer division parsing fixed.
language-lua.cabal view
@@ -3,14 +3,14 @@ Description: Lua 5.3 lexer, parser and pretty-printer. -Version: 0.7.1+Version: 0.8.0 Synopsis: Lua parser and pretty-printer Homepage: http://github.com/osa1/language-lua Bug-reports: http://github.com/osa1/language-lua/issues License: BSD3 License-file: LICENSE Author: Ömer Sinan Ağacan-Maintainer: omeragacan@gmail.com+Maintainer: Ömer Sinan Ağacan <omeragacan@gmail.com>, Eric Mertens <emertens@gmail.com> Category: Language Build-type: Simple Stability: Experimental@@ -19,6 +19,7 @@ Extra-source-files: src/Text/PrettyPrint/LICENSE tests/numbers tests/strings+ tests/string-literal-roundtrip.lua lua-5.3.1-tests/*.lua README.md CHANGELOG.md@@ -33,6 +34,7 @@ Exposed-modules: Language.Lua Language.Lua.Token+ Language.Lua.StringLiteral Language.Lua.Syntax Language.Lua.Parser Language.Lua.PrettyPrinter@@ -48,9 +50,9 @@ Build-depends: base >= 4.5 && < 4.9, deepseq, array >= 0.4 && < 0.6,+ bytestring >= 0.10 && < 0.11, mtl >= 2.0 && < 2.3,- parsec >= 3.1.3 && < 3.2,- safe >= 0.3 && < 0.4+ parsec >= 3.1.3 && < 3.2 Build-tools: alex @@ -67,6 +69,7 @@ filepath, language-lua, parsec >= 3.1.8 && < 3.2,+ bytestring >= 0.10 && < 0.11, QuickCheck, tasty, tasty-hunit,
+ lua-5.3.1-tests/utf8.lua view
@@ -0,0 +1,209 @@+-- $Id: utf8.lua,v 1.11 2014/12/26 17:20:53 roberto Exp $++print "testing UTF-8 library"++local utf8 = require'utf8'+++local function checkerror (msg, f, ...)+ local s, err = pcall(f, ...)+ assert(not s and string.find(err, msg))+end+++local function len (s)+ return #string.gsub(s, "[\x80-\xBF]", "")+end+++local justone = "^" .. utf8.charpattern .. "$"++-- 't' is the list of codepoints of 's'+local function checksyntax (s, t)+ local ts = {"return '"}+ for i = 1, #t do ts[i + 1] = string.format("\\u{%x}", t[i]) end+ ts[#t + 2] = "'"+ ts = table.concat(ts)+ assert(assert(load(ts))() == s)+end++assert(utf8.offset("alo", 5) == nil)+assert(utf8.offset("alo", -4) == nil)++-- 't' is the list of codepoints of 's'+local function check (s, t)+ local l = utf8.len(s) + assert(#t == l and len(s) == l)+ assert(utf8.char(table.unpack(t)) == s)++ assert(utf8.offset(s, 0) == 1)++ checksyntax(s, t)++ local t1 = {utf8.codepoint(s, 1, -1)}+ assert(#t == #t1)+ for i = 1, #t do assert(t[i] == t1[i]) end++ for i = 1, l do+ local pi = utf8.offset(s, i) -- position of i-th char+ local pi1 = utf8.offset(s, 2, pi) -- position of next char+ assert(string.find(string.sub(s, pi, pi1 - 1), justone))+ assert(utf8.offset(s, -1, pi1) == pi)+ assert(utf8.offset(s, i - l - 1) == pi)+ assert(pi1 - pi == #utf8.char(utf8.codepoint(s, pi)))+ for j = pi, pi1 - 1 do + assert(utf8.offset(s, 0, j) == pi)+ end+ for j = pi + 1, pi1 - 1 do+ assert(not utf8.len(s, j))+ end+ assert(utf8.len(s, pi, pi) == 1)+ assert(utf8.len(s, pi, pi1 - 1) == 1)+ assert(utf8.len(s, pi) == l - i + 1)+ assert(utf8.len(s, pi1) == l - i)+ assert(utf8.len(s, 1, pi) == i)+ end++ local i = 0+ for p, c in utf8.codes(s) do+ i = i + 1+ assert(c == t[i] and p == utf8.offset(s, i))+ assert(utf8.codepoint(s, p) == c)+ end+ assert(i == #t)++ i = 0+ for p, c in utf8.codes(s) do+ i = i + 1+ assert(c == t[i] and p == utf8.offset(s, i)) + end+ assert(i == #t)++ i = 0+ for c in string.gmatch(s, utf8.charpattern) do+ i = i + 1+ assert(c == utf8.char(t[i]))+ end+ assert(i == #t)++ for i = 1, l do+ assert(utf8.offset(s, i) == utf8.offset(s, i - l - 1, #s + 1))+ end++end+++do -- error indication in utf8.len+ local function check (s, p)+ local a, b = utf8.len(s)+ assert(not a and b == p)+ end+ check("abc\xE3def", 4)+ check("汉字\x80", #("汉字") + 1)+ check("\xF4\x9F\xBF", 1)+ check("\xF4\x9F\xBF\xBF", 1)+end++-- error in utf8.codes+checkerror("invalid UTF%-8 code",+ function ()+ local s = "ab\xff"+ for c in utf8.codes(s) do assert(c) end+ end)+++-- error in initial position for offset+checkerror("position out of range", utf8.offset, "abc", 1, 5)+checkerror("position out of range", utf8.offset, "abc", 1, -4)+checkerror("position out of range", utf8.offset, "", 1, 2)+checkerror("position out of range", utf8.offset, "", 1, -1)+checkerror("continuation byte", utf8.offset, "𦧺", 1, 2)+checkerror("continuation byte", utf8.offset, "𦧺", 1, 2)+checkerror("continuation byte", utf8.offset, "\x80", 1)++++local s = "hello World"+local t = {string.byte(s, 1, -1)}+for i = 1, utf8.len(s) do assert(t[i] == string.byte(s, i)) end+check(s, t)++check("汉字/漢字", {27721, 23383, 47, 28450, 23383,})++do+ local s = "áéí\128"+ local t = {utf8.codepoint(s,1,#s - 1)}+ assert(#t == 3 and t[1] == 225 and t[2] == 233 and t[3] == 237)+ checkerror("invalid UTF%-8 code", utf8.codepoint, s, 1, #s)+ checkerror("out of range", utf8.codepoint, s, #s + 1)+ t = {utf8.codepoint(s, 4, 3)}+ assert(#t == 0)+ checkerror("out of range", utf8.codepoint, s, -(#s + 1), 1)+ checkerror("out of range", utf8.codepoint, s, 1, #s + 1)+end++assert(utf8.char() == "")+assert(utf8.char(97, 98, 99) == "abc")++assert(utf8.codepoint(utf8.char(0x10FFFF)) == 0x10FFFF)++checkerror("value out of range", utf8.char, 0x10FFFF + 1)++local function invalid (s)+ checkerror("invalid UTF%-8 code", utf8.codepoint, s)+ assert(not utf8.len(s))+end++-- UTF-8 representation for 0x11ffff (value out of valid range)+invalid("\xF4\x9F\xBF\xBF")++-- overlong sequences+invalid("\xC0\x80") -- zero+invalid("\xC1\xBF") -- 0x7F (should be coded in 1 byte)+invalid("\xE0\x9F\xBF") -- 0x7FF (should be coded in 2 bytes)+invalid("\xF0\x8F\xBF\xBF") -- 0xFFFF (should be coded in 3 bytes)+++-- invalid bytes+invalid("\x80") -- continuation byte+invalid("\xBF") -- continuation byte+invalid("\xFE") -- invalid byte+invalid("\xFF") -- invalid byte+++-- empty string+check("", {})++-- minimum and maximum values for each sequence size+s = "\0 \x7F\z+ \xC2\x80 \xDF\xBF\z+ \xE0\xA0\x80 \xEF\xBF\xBF\z+ \xF0\x90\x80\x80 \xF4\x8F\xBF\xBF"+s = string.gsub(s, " ", "")+check(s, {0,0x7F, 0x80,0x7FF, 0x800,0xFFFF, 0x10000,0x10FFFF})++x = "日本語a-4\0éó"+check(x, {26085, 26412, 35486, 97, 45, 52, 0, 233, 243})+++-- Supplementary Characters+check("𣲷𠜎𠱓𡁻𠵼ab𠺢",+ {0x23CB7, 0x2070E, 0x20C53, 0x2107B, 0x20D7C, 0x61, 0x62, 0x20EA2,})++check("𨳊𩶘𦧺𨳒𥄫𤓓\xF4\x8F\xBF\xBF",+ {0x28CCA, 0x29D98, 0x269FA, 0x28CD2, 0x2512B, 0x244D3, 0x10ffff})+++local i = 0+for p, c in string.gmatch(x, "()(" .. utf8.charpattern .. ")") do+ i = i + 1+ assert(utf8.offset(x, i) == p)+ assert(utf8.len(x, p) == utf8.len(x) - i + 1)+ assert(utf8.len(c) == 1)+ for j = 1, #c - 1 do+ assert(utf8.offset(x, 0, p + j - 1) == p)+ end+end++print'ok'+
src/Language/Lua/Annotated/Lexer.x view
@@ -1,4 +1,5 @@ {+ {-# OPTIONS_GHC -w #-} module Language.Lua.Annotated.Lexer@@ -8,16 +9,14 @@ , AlexPosn(..) ) where -import Language.Lua.Token-import Control.Applicative ((<$>))-import Control.Monad (forM_, unless, when)-import Data.Char (isNumber)-import Data.List (foldl')-import Safe (readMay)+import Control.Applicative (Applicative(..))+import Control.Monad (ap, liftM, forM_, when)+import Data.Char (GeneralCategory(..),generalCategory,isAscii,isSpace)+import Data.Word (Word8) -}+import Language.Lua.Token -%wrapper "monadUserState"+} $space = [ \ \t ] -- horizontal white space @@ -32,8 +31,8 @@ $longstr = \0-\255 -- valid character in a long string -- escape characters-@charescd = \\ ([ntvbrfa\\\?'"] | $digit{1,3} | x$hexdigit{2} | u\{$hexdigit{1,}\} | \n | z [$space \n]*)-@charescs = \\ ([ntvbrfa\\\?"'] | $digit{1,3} | x$hexdigit{2} | u\{$hexdigit{1,}\} | \n | z [$space \n]*)+@charescd = \\ ([ntvbrfa\\'"] | $digit{1,3} | x$hexdigit{2} | u\{$hexdigit{1,}\} | \n | z [$space \n\r\f\v]*)+@charescs = \\ ([ntvbrfa\\"'] | $digit{1,3} | x$hexdigit{2} | u\{$hexdigit{1,}\} | \n | z [$space \n\r\f\v]*) @digits = $digit+ @hexdigits = $hexdigit+@@ -58,18 +57,18 @@ <0> @hexprefix @hexdigits @expparthex { tokWValue LTokNum } <0> @hexprefix @mantparthex @expparthex? { tokWValue LTokNum } - <0> \"($dqstr|@charescd)*\" { \(posn,_,_,s) l -> return $ mkString True s l posn }- <0> \'($sqstr|@charescs)*\' { \(posn,_,_,s) l -> return $ mkString False s l posn }+ <0> \"($dqstr|@charescd)*\" { \(posn,_,s) l -> return $ mkString s l posn }+ <0> \'($sqstr|@charescs)*\' { \(posn,_,s) l -> return $ mkString s l posn } -- long strings- <0> \[ \=* \[ \n? { enterString `andBegin` state_string }+ <0> \[ \=* \[ { enterString `andBegin` state_string } <state_string> \] \=* \] { testAndEndString } <state_string> $longstr { addCharToString } + <0> "--[" \=* \[ { enterLongComment `andBegin` state_string } <0> "--" { enterComment `andBegin` state_comment } <state_comment> . # \n ; <state_comment> \n { testAndEndComment }- <state_comment> \[ \=* \[ \n? { enterString `andBegin` state_string } <0> "+" { tok LTokPlus } <0> "-" { tok LTokMinus }@@ -150,9 +149,15 @@ putInputBack :: String -> Alex () putInputBack str = Alex $ \s -> Right (s{alex_inp=str ++ alex_inp s}, ()) +enterLongComment :: AlexAction LTok+enterLongComment (posn,_,s) len = do+ initComment+ initString (len-2) posn+ alexMonadScan'+ enterString :: AlexAction LTok-enterString (posn,_,_,s) len = do- initString (if (s !! (len-1) == '\n') then len-1 else len) posn+enterString (posn,_,s) len = do+ initString len posn alexMonadScan' enterComment :: AlexAction LTok@@ -160,13 +165,8 @@ initComment alexMonadScan' -addString :: AlexAction LTok-addString (_,_,_,s) len = do- forM_ (take len s) addCharToStringValue- alexMonadScan'- addCharToString :: AlexAction LTok-addCharToString (_,_,_,s) len = do+addCharToString (_,_,s) len = do addCharToStringValue (head s) alexMonadScan' @@ -182,7 +182,7 @@ if ss then alexMonadScan' else endComment >> alexSetStartCode 0 >> alexMonadScan' testAndEndString :: AlexAction LTok-testAndEndString (_,_,_,s) len = do+testAndEndString (_,_,s) len = do startlen <- getStringDelimLen if startlen /= len then do addCharToStringValue (head s)@@ -198,128 +198,28 @@ else do val <- getStringValue posn <- getStringPosn- return (LTokSLit (reverse val), posn)+ let eqs = replicate (startlen-2) '=' -- 2 were the [s+ return (LTokSLit ("["++eqs++"["++reverse val++"]"++eqs++"]"), posn) {-# INLINE mkString #-}-mkString :: Bool -> String -> Int -> AlexPosn -> LTok-mkString True s l posn =- -- double quoted string, to make it Haskell readable- (LTokSLit (readString posn $ r (replaceCharCodes (take l s))), posn)- where- -- we could handle \z while reading characters, at the cost of adding- -- more state to the lexer. I wanted to go with simplest- -- implementation.- r ('\\' : 'z' : rest) = r (skipWS rest)- -- handle newline escaping- r ('\\' : '\n' : rest) = '\n' : r rest- -- skip escaped backslash- r ('\\' : '\\' : rest) = '\\' : '\\' : r rest- -- quote already escaped, Lua allows this. (ie. "\'")- r ('\\' : '\'' : rest) = '\'' : r rest-- r (c : rest) = c : r rest- r [] = []-mkString False s l posn =- -- single quoted string, to make it Haskell readable- (LTokSLit (readString posn $ '"' : r (replaceCharCodes (take (l-2) $ drop 1 s)) ++ "\""), posn)- where- -- handle \z- r ('\\' : 'z' : rest) = r (skipWS rest)- -- handle newline escaping- r ('\\' : '\n' : rest) = '\n' : r rest- -- skip escaped backslash- r ('\\' : '\\' : rest) = '\\' : '\\' : r rest- -- escaped single quote, remove the escaping- r ('\\' : '\'' : rest) = '\'' : r rest- -- double quote already escaped, Lua allows this. (ie. '\"')- r ('\\' : '"' : rest) = '\\' : '"' : r rest- -- unescaped double quote, escape it- r ('"' : rest) = '\\' : '"' : r rest- r (c : rest) = c : r rest- r [] = []--replaceCharCodes :: String -> String-replaceCharCodes s =- case s of- ('\\' : 'x' : h1 : h2 : rest) -> toEnum (hexToInt h1 * 16 + hexToInt h2) : replaceCharCodes rest- ('\\' : 'u' : '{' : rest) ->- case break (=='}') rest of- (ds,_:rest')- | code <= 0x10ffff -> toEnum code : replaceCharCodes rest'- | otherwise -> '\xFFFD' : replaceCharCodes rest'- where code = foldl' (\acc d -> acc * 16 + hexToInt d) 0 ds- _ -> error "lexical error: unterminated unicode escape"- ('\\' : c1 : c2 : c3 : rest)- | isNumber c1 && isNumber c2 && isNumber c3 ->- toEnum (decToNum c1 * 100 + decToNum c2 * 10 + decToNum c3) : replaceCharCodes rest- | isNumber c1 && isNumber c2 ->- toEnum (decToNum c1 * 10 + decToNum c2) : replaceCharCodes (c3 : rest)- | isNumber c1 ->- toEnum (decToNum c1) : replaceCharCodes (c2 : c3 : rest)- | otherwise ->- '\\' : c1 : replaceCharCodes (c2 : c3 : rest)- ['\\', c1, c2]- | isNumber c1 && isNumber c2 ->- [toEnum (decToNum c1 * 10 + decToNum c2)]- | isNumber c1 ->- toEnum (decToNum c1) : replaceCharCodes [c2]- | otherwise -> s- ['\\', c1]- | isNumber c1 -> [toEnum (decToNum c1)]- | otherwise -> s- (c : rest) -> c : replaceCharCodes rest- [] -> []--skipWS :: String -> String-skipWS (' ' : rest) = skipWS rest-skipWS ('\n' : rest) = skipWS rest-skipWS ('\t' : rest) = skipWS rest-skipWS str = str--hexToInt :: Char -> Int-hexToInt c =- case c of- 'A' -> 10- 'a' -> 10- 'B' -> 11- 'b' -> 11- 'C' -> 12- 'c' -> 12- 'D' -> 13- 'd' -> 13- 'E' -> 14- 'e' -> 14- 'F' -> 15- 'f' -> 15- _ -> decToNum c--{-# INLINE decToNum #-}-decToNum :: Char -> Int-decToNum c = fromEnum c - fromEnum '0'---readString :: AlexPosn -> String -> String-readString (AlexPn _ line col) s =- case readMay s of- Nothing -> error $ concat- [ "lexical error near line: ", show line, " col: ", show col, ": Cannot read string " ++ show s ]- Just s' -> s'+mkString :: String -> Int -> AlexPosn -> LTok+mkString s l posn = (LTokSLit (take l s), posn) -- | Lua token with position information. type LTok = (LToken, AlexPosn) --- type AlexAction result = AlexInput -> Int -> Alex result+type AlexAction result = AlexInput -> Int -> Alex result -- Helper to make LTokens with string value (like LTokNum, LTokSLit etc.) tokWValue :: (String -> LToken) -> AlexInput -> Int -> Alex LTok-tokWValue tok (posn,_,_,s) len = return (tok (take len s), posn)+tokWValue tok (posn,_,s) len = return (tok (take len s), posn) tok :: LToken -> AlexInput -> Int -> Alex LTok-tok t (posn,_,_,_) _ = return (t, posn)+tok t (posn,_,_) _ = return (t, posn) {-# INLINE ident #-} ident :: AlexAction LTok-ident (posn,_,_,s) len = return (tok, posn)+ident (posn,_,s) len = return (tok, posn) where tok = case (take len s) of "and" -> LTokAnd "break" -> LTokBreak@@ -345,15 +245,6 @@ "while" -> LTokWhile ident' -> LTokIdent ident' ---data AlexPosn = AlexPn !Int -- absolute character offset--- !Int -- line number--- !Int -- column number------type AlexInput = (AlexPosn, -- current position,--- Char, -- previous char--- [Byte], -- rest of the bytes for the current char--- String) -- current input string- alexEOF :: Alex LTok alexEOF = return (LTokEof, AlexPn (-1) (-1) (-1)) @@ -365,16 +256,15 @@ AlexEOF -> do cs <- getCommentState when cs endString alexEOF- AlexError ((AlexPn _ line col),ch,_,_) -> alexError $ concat- [ "lexical error near line: " , show line , " col: " , show col , " at char " , [ch] ]+ AlexError ((AlexPn _ line col),ch,_) -> alexError ("at char " ++ [ch]) AlexSkip inp' len -> do alexSetInput inp' alexMonadScan' AlexToken inp' len action -> do alexSetInput inp'- action (ignorePendingBytes inp) len+ action inp len -scanner :: String -> Either String [LTok]+scanner :: String -> Either (String,AlexPosn) [LTok] scanner str = runAlex str loop where loop = do t@(tok, _) <- alexMonadScan'@@ -393,12 +283,142 @@ -- Newline is preserved in order to ensure that line numbers stay correct -- | Lua lexer.-llex :: String -> [LTok]-llex s = case scanner (dropSpecialComment s) of- Left err -> error err- Right r -> r+llex :: String -> Either (String,AlexPosn) [LTok]+llex = scanner . dropSpecialComment -- | Run Lua lexer on a file.-llexFile :: FilePath -> IO [LTok]-llexFile p = llex <$> readFile p+llexFile :: FilePath -> IO (Either (String,AlexPosn) [LTok])+llexFile = fmap llex . readFile++------------------------------------------------------------------------+-- Custom Alex wrapper+------------------------------------------------------------------------++data AlexPosn = AlexPn !Int -- absolute character offset+ !Int -- line number+ !Int -- column number+ deriving (Show,Eq)++type AlexInput = (AlexPosn, -- current position,+ Char, -- previous char+ String) -- current input string++alexStartPos :: AlexPosn+alexStartPos = AlexPn 0 1 1++alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)+alexGetByte (_,_,[]) = Nothing+alexGetByte (p,_,c:cs) = Just (byteForChar c,(p',c,cs))+ where p' = alexMove p c++alexMove :: AlexPosn -> Char -> AlexPosn+alexMove (AlexPn ix line column) c =+ case c of+ '\t' -> AlexPn (ix + 1) line (((column + 7) `div` 8) * 8 + 1)+ '\n' -> AlexPn (ix + 1) (line + 1) 1+ _ -> AlexPn (ix + 1) line (column + 1)++------------------------------------------------------------------------+-- Embed all of unicode, kind of, in a single byte!+------------------------------------------------------------------------++byteForChar :: Char -> Word8+byteForChar c+ | c <= '\6' = non_graphic+ | isAscii c = fromIntegral (ord c)+ | otherwise = case generalCategory c of+ LowercaseLetter -> lower+ OtherLetter -> lower+ UppercaseLetter -> upper+ TitlecaseLetter -> upper+ DecimalNumber -> digit+ OtherNumber -> digit+ ConnectorPunctuation -> symbol+ DashPunctuation -> symbol+ OtherPunctuation -> symbol+ MathSymbol -> symbol+ CurrencySymbol -> symbol+ ModifierSymbol -> symbol+ OtherSymbol -> symbol+ Space -> space+ ModifierLetter -> other+ NonSpacingMark -> other+ SpacingCombiningMark -> other+ EnclosingMark -> other+ LetterNumber -> other+ OpenPunctuation -> other+ ClosePunctuation -> other+ InitialQuote -> other+ FinalQuote -> other+ _ -> non_graphic+ where+ non_graphic = 0+ upper = 1+ lower = 2+ digit = 3+ symbol = 4+ space = 5+ other = 6++-- perform an action for this token, and set the start code to a new value+andBegin :: AlexAction result -> Int -> AlexAction result+(action `andBegin` code) input len = do alexSetStartCode code; action input len++alexSetStartCode :: Int -> Alex ()+alexSetStartCode sc = Alex $ \s -> Right (s{alex_scd=sc}, ())++data AlexState = AlexState {+ alex_pos :: !AlexPosn, -- position at current input location+ alex_inp :: String, -- the current input+ alex_chr :: !Char, -- the character before the input+ alex_scd :: !Int -- the current startcode++ , alex_ust :: AlexUserState -- AlexUserState will be defined in the user program++ }++-- Compile with -funbox-strict-fields for best results!++runAlex :: String -> Alex a -> Either (String,AlexPosn) a+runAlex input (Alex f)+ = case f (AlexState {alex_pos = alexStartPos,+ alex_inp = input,+ alex_chr = '\n',++ alex_ust = alexInitUserState,++ alex_scd = 0}) of Left e -> Left e+ Right ( _, a ) -> Right a++newtype Alex a = Alex { unAlex :: AlexState -> Either (String,AlexPosn) (AlexState, a) }++alexError :: String -> Alex a+alexError message = Alex $ \s -> Left (message, alex_pos s)++alexGetStartCode :: Alex Int+alexGetStartCode = Alex $ \s@AlexState{alex_scd=sc} -> Right (s, sc)++alexSetInput :: AlexInput -> Alex ()+alexSetInput (pos,c,inp)+ = Alex $ \s -> case s{alex_pos=pos,alex_chr=c,alex_inp=inp} of+ s@(AlexState{}) -> Right (s, ())++alexGetInput :: Alex AlexInput+alexGetInput+ = Alex $ \s@AlexState{alex_pos=pos,alex_chr=c,alex_inp=inp} ->+ Right (s, (pos,c,inp))++instance Functor Alex where+ fmap = liftM++instance Applicative Alex where+ pure a = Alex $ \s -> Right (s,a)+ (<*>) = ap++instance Monad Alex where+ return = pure+ m >>= k = Alex $ \s -> case unAlex m s of+ Left msg -> Left msg+ Right (s',a) -> unAlex (k a) s'+ }
src/Language/Lua/Annotated/Parser.hs view
@@ -29,16 +29,25 @@ -- | Runs Lua lexer before parsing. Use @parseText stat@ to parse -- statements, and @parseText exp@ to parse expressions. parseText :: Parser a -> String -> Either ParseError a-parseText p s = parse p "<string>" (llex s)+parseText p = parseNamedText p "<string>" -- | Runs Lua lexer before parsing. Use @parseNamedText stat "name"@ to parse -- statements, and @parseText exp "name"@ to parse expressions. parseNamedText :: Parser a -> String -> String -> Either ParseError a-parseNamedText p n s = parse p n (llex s)+parseNamedText p n s =+ case llex s of+ Left (e,pos) -> parse (reportLexError e pos) n []+ Right xs -> parse p n xs +reportLexError :: String -> AlexPosn -> Parser a+reportLexError msg (AlexPn _ line column) =+ do pos <- getPosition+ setPosition (pos `setSourceLine` line `setSourceColumn` column)+ fail ("lexical error: " ++ msg)+ -- | Parse a Lua file. You can use @parseText chunk@ to parse a file from a string. parseFile :: FilePath -> IO (Either ParseError (Block SourcePos))-parseFile path = parse chunk path . llex <$> readFile path+parseFile path = parseNamedText chunk path <$> readFile path parens :: Monad m => ParsecT [LTok] u m a -> ParsecT [LTok] u m a parens = between (tok LTokLParen) (tok LTokRParen)@@ -217,7 +226,7 @@ stringExp = String <$> getPosition <*> stringlit -varargExp = (Vararg <$> getPosition) <* tok LTokEllipsis+varargExp = Vararg <$> getPosition <* tok LTokEllipsis fundefExp = do pos <- getPosition
src/Language/Lua/Annotated/Syntax.hs view
@@ -279,6 +279,10 @@ amap f (TableArg a x1) = TableArg (f a) x1 amap f (StringArg a x1) = StringArg (f a) x1 +instance Annotated Name where+ ann (Name a _) = a+ amap f (Name a x1) = Name (f a) x1+ instance NFData a => NFData (Name a) instance NFData a => NFData (Stat a) instance NFData a => NFData (Exp a)
src/Language/Lua/PrettyPrinter.hs view
@@ -47,7 +47,7 @@ pprint' _ Nil = text "nil" pprint' _ (Bool s) = pprint s pprint' _ (Number n) = text n- pprint' _ (String s) = text (show s)+ pprint' _ (String s) = text s pprint' _ Vararg = text "..." pprint' _ (EFunDef f) = pprint f pprint' _ (PrefixExp pe) = pprint pe@@ -178,7 +178,7 @@ pprint (Args [fun@EFunDef{}]) = parens (pprint fun) pprint (Args exps) = parens (align (fillSep (punctuate comma (map (align . pprint) exps)))) pprint (TableArg t) = pprint t- pprint (StringArg s) = text (show s)+ pprint (StringArg s) = text s instance LPretty Stat where pprint (Assign names vals)@@ -232,4 +232,4 @@ where exps' = case exps of Nothing -> empty Just es -> equals </> intercalate comma (map pprint es)- pprint EmptyStat = empty+ pprint EmptyStat = text ";"
+ src/Language/Lua/StringLiteral.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE CPP #-}++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++module Language.Lua.StringLiteral+ ( interpretStringLiteral+ , constructStringLiteral+ ) where++import Data.Char (ord, chr, isNumber, isPrint, isAscii)+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy.Char8 as B8+import Data.List (foldl')+import Data.Bits ((.&.),shiftR)+import Numeric (showHex)++#if !(MIN_VERSION_base(4,8,0))+import Data.Monoid (mempty, mappend, mconcat)+#endif++skipWS :: String -> String+skipWS (' ' : rest) = skipWS rest+skipWS ('\n' : rest) = skipWS rest+skipWS ('\r' : rest) = skipWS rest+skipWS ('\f' : rest) = skipWS rest+skipWS ('\t' : rest) = skipWS rest+skipWS ('\v' : rest) = skipWS rest+skipWS str = str++hexToInt :: Char -> Int+hexToInt c =+ case c of+ 'A' -> 10+ 'a' -> 10+ 'B' -> 11+ 'b' -> 11+ 'C' -> 12+ 'c' -> 12+ 'D' -> 13+ 'd' -> 13+ 'E' -> 14+ 'e' -> 14+ 'F' -> 15+ 'f' -> 15+ _ -> decToNum c++{-# INLINE decToNum #-}+decToNum :: Char -> Int+decToNum c = fromEnum c - fromEnum '0'+++interpretStringLiteral :: String -> Maybe ByteString+interpretStringLiteral xxs =+ case xxs of+ '\'':xs -> Just (decodeEscapes (dropLast 1 xs))+ '"':xs -> Just (decodeEscapes (dropLast 1 xs))+ '[':xs -> removeLongQuotes xs+ _ -> Nothing++-- | Long-quoted string literals have no escapes.+-- A leading newline on a long quoted string literal is ignored.+removeLongQuotes :: String -> Maybe ByteString+removeLongQuotes str =+ case span (=='=') str of+ (eqs,'[':'\n':xs) -> go (dropLast (2+length eqs) xs)+ (eqs,'[': xs) -> go (dropLast (2+length eqs) xs)+ _ -> Nothing+ where+ go = Just . B.toLazyByteString . mconcat . map encodeChar++dropLast :: Int -> [a] -> [a]+dropLast n xs = take (length xs - n) xs++decodeEscapes :: String -> ByteString+decodeEscapes = B.toLazyByteString . aux+ where+ aux xxs =+ case xxs of+ [] -> mempty+ '\\' : 'x' : h1 : h2 : rest ->+ B.word8 (fromIntegral (hexToInt h1 * 16 + hexToInt h2)) `mappend` aux rest++ '\\' : 'u' : '{' : rest ->+ case break (=='}') rest of+ (ds,_:rest')+ | code <= 0x10ffff -> encodeChar (chr code) `mappend` aux rest'+ where code = foldl' (\acc d -> acc * 16 + hexToInt d) 0 ds+ _ -> encodeChar '\xFFFD' `mappend` aux (dropWhile (/='}') rest)++ '\\' : c1 : c2 : c3 : rest+ | isNumber c1 && isNumber c2 && isNumber c3 ->+ let code = decToNum c1 * 100 + decToNum c2 * 10 + decToNum c3+ in B.word8 (fromIntegral code) `mappend` aux rest++ '\\' : c1 : c2 : rest+ | isNumber c1 && isNumber c2 ->+ let code = decToNum c1 * 10 + decToNum c2+ in B.word8 (fromIntegral code) `mappend` aux rest++ '\\' : c1 : rest+ | isNumber c1 -> B.word8 (fromIntegral (decToNum c1)) `mappend` aux rest++ '\\' : 'a' : rest -> B.char8 '\a' `mappend` aux rest+ '\\' : 'b' : rest -> B.char8 '\b' `mappend` aux rest+ '\\' : 'f' : rest -> B.char8 '\f' `mappend` aux rest+ '\\' : 'n' : rest -> B.char8 '\n' `mappend` aux rest+ '\\' : '\n' : rest -> B.char8 '\n' `mappend` aux rest+ '\\' : 'r' : rest -> B.char8 '\r' `mappend` aux rest+ '\\' : 't' : rest -> B.char8 '\t' `mappend` aux rest+ '\\' : 'v' : rest -> B.char8 '\v' `mappend` aux rest+ '\\' : '\\' : rest -> B.char8 '\\' `mappend` aux rest+ '\\' : '"' : rest -> B.char8 '"' `mappend` aux rest+ '\\' : '\'' : rest -> B.char8 '\'' `mappend` aux rest+ '\\' : 'z' : rest -> aux (skipWS rest)+ c : rest -> encodeChar c `mappend` aux rest++-- | Convert a string literal body to string literal syntax+constructStringLiteral :: ByteString -> String+constructStringLiteral bs = '"' : aux 0+ where+ aux i+ | i >= B.length bs = "\""+ | otherwise =+ case B8.index bs i of+ '\a' -> '\\' : 'a' : aux (i+1)+ '\b' -> '\\' : 'b' : aux (i+1)+ '\f' -> '\\' : 'f' : aux (i+1)+ '\n' -> '\\' : 'n' : aux (i+1)+ '\r' -> '\\' : 'r' : aux (i+1)+ '\t' -> '\\' : 't' : aux (i+1)+ '\v' -> '\\' : 'v' : aux (i+1)+ '\\' -> '\\' : '\\' : aux (i+1)+ '\"' -> '\\' : '"' : aux (i+1)+ x | isPrint x && isAscii x -> x : aux (i+1)+ | x <= '\x0f' -> '\\' : 'x' : '0' : showHex (ord x) (aux (i+1))+ | otherwise -> '\\' : 'x' : showHex (ord x) (aux (i+1))++encodeChar :: Char -> B.Builder+encodeChar c+ | oc <= 0x7f = asByte oc++ | oc <= 0x7ff = asByte (0xc0 + (oc `shiftR` 6))+ `mappend` asByte (0x80 + oc .&. 0x3f)++ | oc <= 0xffff = asByte (0xe0 + (oc `shiftR` 12))+ `mappend` asByte (0x80 + ((oc `shiftR` 6) .&. 0x3f))+ `mappend` asByte (0x80 + oc .&. 0x3f)++ | otherwise = asByte (0xf0 + (oc `shiftR` 18))+ `mappend` asByte (0x80 + ((oc `shiftR` 12) .&. 0x3f))+ `mappend` asByte (0x80 + ((oc `shiftR` 6) .&. 0x3f))+ `mappend` asByte (0x80 + oc .&. 0x3f)+ where+ asByte = B.word8 . fromIntegral+ oc = ord c
src/Language/Lua/Token.hs view
@@ -59,7 +59,7 @@ | LTokWhile -- ^while | LTokNum String -- ^number constant- | LTokSLit String -- ^string constant+ | LTokSLit String -- ^string constant. Includes quotes! | LTokIdent String -- ^identifier | LTokEof -- ^end of file deriving Eq
tests/Main.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE DeriveGeneric, FlexibleInstances, ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric, FlexibleInstances, OverloadedStrings,+ ScopedTypeVariables #-} module Main where @@ -7,6 +8,7 @@ import qualified Language.Lua.Annotated.Simplify as S import qualified Language.Lua.Parser as P import Language.Lua.PrettyPrinter (pprint)+import Language.Lua.StringLiteral import Language.Lua.Syntax import qualified Language.Lua.Token as T @@ -20,6 +22,7 @@ import Control.Applicative import Control.DeepSeq (deepseq, force) import Control.Monad (forM_)+import qualified Data.ByteString.Lazy as B import Data.Char (isSpace) import GHC.Generics import Prelude hiding (Ordering (..), exp)@@ -34,7 +37,8 @@ tests = testGroup "Tests" [unitTests, propertyTests] unitTests :: TestTree-unitTests = testGroup "Unit tests" [stringTests, numberTests, regressions, lua531Tests]+unitTests = testGroup "Unit tests"+ [stringTests, numberTests, regressions, lua531Tests, literalDecodingTests] where lua531Tests = parseFilesTest "Parsing Lua files from Lua 5.3.1 test suite" "lua-5.3.1-tests" @@ -42,8 +46,102 @@ propertyTests = testGroup "Property tests" [{-genPrintParse-}] parseExps :: String -> String -> Either P.ParseError [A.Exp P.SourcePos]-parseExps file contents = P.runParser (many A.exp) () file (L.llex contents)+parseExps file contents =+ case L.llex contents of+ Left (msg,pos) -> P.runParser (reportLexError msg pos) () file []+ Right xs -> P.runParser (many A.exp) () file xs +reportLexError :: Monad m => String -> L.AlexPosn -> P.ParsecT s u m a+reportLexError msg (L.AlexPn _ line column) =+ do pos <- P.getPosition+ P.setPosition (pos `P.setSourceLine` line `P.setSourceColumn` column)+ fail ("lexical error: " ++ msg)++literalDecodingTests :: TestTree+literalDecodingTests = testGroup "Literal codec tests"+ [ testCase "decoding"+ (do assertEqual "C escapes wrong"+ (Just "\a\b\f\n\r\t\v\\\"'")+ $ interpretStringLiteral "\"\\a\\b\\f\\n\\r\\t\\v\\\\\\\"'\""+ assertEqual "C escapes wrong"+ (Just "\a \b \f \n \r \t \v \\ \" '")+ $ interpretStringLiteral "\"\\a \\b \\f \\n \\r \\t \\v \\\\ \\\" '\""+ assertEqual "ASCII characters wrong"+ (Just "the quick brown fox jumps over the lazy dog")+ $ interpretStringLiteral "'the quick brown fox jumps over the lazy dog'"+ assertEqual "Test decimal escapes"+ (Just "\0\1\2\3\4\60\127\255")+ $ interpretStringLiteral "'\\0\\1\\2\\3\\4\\60\\127\\255'"+ assertEqual "Test hexadecimal escapes"+ (Just "\0\1\2\3\4\127\255")+ $ interpretStringLiteral "\"\\x00\\x01\\x02\\x03\\x04\\x7f\\xff\""+ assertEqual "Test UTF-8 encoding"+ (Just "\230\177\137\229\173\151")+ $ interpretStringLiteral "'汉字'"+ assertEqual "Test unicode escape"+ (Just "\0 \16 \230\177\137\229\173\151")+ $ interpretStringLiteral "'\\u{0} \\u{10} \\u{6c49}\\u{5b57}'"+ assertEqual "Test continued line"+ (Just "hello\nworld")+ $ interpretStringLiteral "\"hello\\\nworld\""+ assertEqual "Test skipped whitespace"+ (Just "helloworld")+ $ interpretStringLiteral "'hello\\z \n \f \t \r \v world'"+ assertEqual "Long-quote leading newline"+ (Just "line1\nline2\n")+ $ interpretStringLiteral "[===[\nline1\nline2\n]===]"+ assertEqual "Long-quote without leading newline"+ (Just "line1\nline2\n")+ $ interpretStringLiteral "[===[line1\nline2\n]===]"+ assertEqual "Long-quote no escapes"+ (Just "\\0\\x00\\u{000}")+ $ interpretStringLiteral "[===[\\0\\x00\\u{000}]===]"+ assertEqual "Empty single quoted"+ (Just "")+ $ interpretStringLiteral "''"+ assertEqual "Empty double quoted"+ (Just "")+ $ interpretStringLiteral "\"\""+ assertEqual "Empty long quoted"+ (Just "")+ $ interpretStringLiteral "[[]]"+ )+ , testCase "encoding"+ (do assertEqual "Empty string"+ "\"\""+ $ constructStringLiteral ""+ assertEqual "Normal escapes"+ "\"\\a\\b\\f\\n\\r\\t\\v\\\\\\\"\""+ $ constructStringLiteral "\a\b\f\n\r\t\v\\\""+ assertEqual "Exhaustive test"+ "\"\\x00\\x01\\x02\\x03\\x04\\x05\\x06\\a\+ \\\b\\t\\n\\v\\f\\r\\x0e\\x0f\+ \\\x10\\x11\\x12\\x13\\x14\\x15\\x16\\x17\+ \\\x18\\x19\\x1a\\x1b\\x1c\\x1d\\x1e\\x1f\+ \ !\\\"#$%&'()*+,-./0123456789:;<=>?@\+ \ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\\\]^_`\+ \abcdefghijklmnopqrstuvwxyz{|}~\\x7f\+ \\\x80\\x81\\x82\\x83\\x84\\x85\\x86\\x87\+ \\\x88\\x89\\x8a\\x8b\\x8c\\x8d\\x8e\\x8f\+ \\\x90\\x91\\x92\\x93\\x94\\x95\\x96\\x97\+ \\\x98\\x99\\x9a\\x9b\\x9c\\x9d\\x9e\\x9f\+ \\\xa0\\xa1\\xa2\\xa3\\xa4\\xa5\\xa6\\xa7\+ \\\xa8\\xa9\\xaa\\xab\\xac\\xad\\xae\\xaf\+ \\\xb0\\xb1\\xb2\\xb3\\xb4\\xb5\\xb6\\xb7\+ \\\xb8\\xb9\\xba\\xbb\\xbc\\xbd\\xbe\\xbf\+ \\\xc0\\xc1\\xc2\\xc3\\xc4\\xc5\\xc6\\xc7\+ \\\xc8\\xc9\\xca\\xcb\\xcc\\xcd\\xce\\xcf\+ \\\xd0\\xd1\\xd2\\xd3\\xd4\\xd5\\xd6\\xd7\+ \\\xd8\\xd9\\xda\\xdb\\xdc\\xdd\\xde\\xdf\+ \\\xe0\\xe1\\xe2\\xe3\\xe4\\xe5\\xe6\\xe7\+ \\\xe8\\xe9\\xea\\xeb\\xec\\xed\\xee\\xef\+ \\\xf0\\xf1\\xf2\\xf3\\xf4\\xf5\\xf6\\xf7\+ \\\xf8\\xf9\\xfa\\xfb\\xfc\\xfd\\xfe\\xff\""+ (constructStringLiteral (B.pack [0..255]))++ )+ ]+ stringTests :: TestTree stringTests = testGroup "String tests" [ testCase@@ -54,16 +152,32 @@ Left parseErr -> assertFailure (show parseErr) Right exps -> do assertBool "Wrong number of strings parsed" (length exps == 5)- assertEqTrans $ map S.sExp exps)+ case asStrings exps of+ Nothing -> assertFailure "Not all strings were strings"+ Just strs ->+ forM_ strs $ \str ->+ assertEqual "String not same"+ expected $ interpretStringLiteral str)+ , testCase+ "Round-trip through the pretty-printer"+ (do let file = "tests/string-literal-roundtrip.lua"+ contents <- readFile file+ case P.parseText P.chunk contents of+ Left parseErr -> assertFailure (show parseErr)+ Right x -> assertEqual+ "pretty printer didn't preserve"+ contents+ (show (pprint x) ++ "\n"))+ -- text file lines always end in a newline+ -- but the pretty printer doesn't know this ] where- assertEqTrans :: [Exp] -> Assertion- assertEqTrans [] = return ()- assertEqTrans [_] = return ()- assertEqTrans (a : b : rest) = do- assertEqual "Strings are not same" a b- assertEqTrans (b : rest)+ expected = Just "alo\n123\""+ asString (String s) = Just s+ asString _ = Nothing + asStrings = mapM (asString . S.sExp)+ numberTests :: TestTree numberTests = testGroup "Number tests" [ testCase@@ -84,7 +198,7 @@ regressions :: TestTree regressions = testGroup "Regression tests" [ testCase "Lexing comment with text \"EOF\" in it" $- assertEqual "Lexing is wrong" [(T.LTokEof, L.AlexPn (-1) (-1) (-1))] (L.llex "--EOF")+ assertEqual "Lexing is wrong" (Right [(T.LTokEof, L.AlexPn (-1) (-1) (-1))]) (L.llex "--EOF") , testCase "Binary/unary operator parsing/printing" $ do pp "2^3^2 == 2^(3^2)" pp "2^3*4 == (2^3)*4"@@ -103,7 +217,7 @@ show (L.llex "\"\\\'\"") `deepseq` return () , testCase "Lexing Lua string: '\\\\\"'" $ do assertEqual "String lexed wrong"- [T.LTokSLit "\\\"", T.LTokEof] (map fst $ L.llex "'\\\\\"'")+ (Right [T.LTokSLit "'\\\\\"'", T.LTokEof]) (fmap (map fst) $ L.llex "'\\\\\"'") , testCase "Lexing long literal `[====[ ... ]====]`" $ show (L.llex "[=[]]=]") `deepseq` return () , testCase "Handling \\z" $@@ -120,15 +234,26 @@ assertParseFailure (P.parseText P.stat "x =") , testCase "empty list of return values should be accpeted" $ assertEqual "Parsed wrong" (Right $ Block [] (Just [])) (P.parseText P.chunk "return")+ , testCase "Long comments should start immediately after --" $ do+ assertEqual "Parsed wrong" (Right $ Block [] Nothing)+ (P.parseText P.chunk "--[[ line1\nline2 ]]")+ assertParseFailure (P.parseText P.chunk "-- [[ line1\nline2 ]]")+ , testCase "Print EmptyStat for disambiguation" $ ppChunk "f();(f)()" ] where pp :: String -> Assertion- pp expr =- case P.parseText P.exp expr of+ pp = ppTest (P.parseText P.exp) (show . pprint)++ ppChunk :: String -> Assertion+ ppChunk = ppTest (P.parseText P.chunk) (show . pprint)++ ppTest :: Show err => (String -> Either err ret) -> (ret -> String) -> String -> Assertion+ ppTest parser printer str =+ case parser str of Left err -> assertFailure $ "Parsing failed: " ++ show err Right expr' -> assertEqual "Printed string is not equal to original one modulo whitespace"- (filter (not . isSpace) expr) (filter (not . isSpace) (show $ pprint expr'))+ (filter (not . isSpace) str) (filter (not . isSpace) (printer expr')) assertParseFailure (Left _parseError) = return () assertParseFailure (Right ret) = assertFailure $ "Unexpected parse: " ++ show ret@@ -193,7 +318,7 @@ , LocalFunAssign <$> arbitrary <*> arbitrary , LocalAssign <$> listOf1 arbitrary <*> arbitrary -- Don't generate EmptyState - it's not printed by pretty-printer- -- , return $ EmptyStat ()+ , return EmptyStat ] shrink = recursivelyShrink
+ tests/string-literal-roundtrip.lua view
@@ -0,0 +1,29 @@+x = "abc"+x = "abc\+123"+x = "\0\1\10\010\100"+x = "\"\""+x = "\a\b\t\n\f\r\v\\\'"+x = [==[+abc123+]==]+x = [[+abc+123+]]+x = [===[]===]+x = 'abc'+x = 'abc\+123'+x = '\0\1\10\010\100'+x = '\"\"'+x = '\a\b\t\n\f\r\v\\\''+x = "汉字\x80"+x = "汉字"+x = '汉字\x80'+x = '汉字'+x = '\u{0}\u{000}\u{10ffff}'+x = "\u{0}\u{000}\u{10ffff}"+x = [[\a\b\c\d\f"""''']]+x = "\x00\x01\xfe\xff"+x = '\x00\x01\xfe\xff'