small fixes

fix positions?
small fixes to haddock
add notes to top of lexer module
simplify line comment lexer
remove some trys from lexer
fix the block comment parser to return all the comment text when there
  are embedded / * in the comment
refactor the symbol, keyword and identifier blacklist checking into
  the low level token parsers instead of a separate step using guard

Language/SQL/SimpleSQL/Lexer.lhs

@@ -1,9 +1,12 @@
 
-Lexer TODO:
+The parser uses a separate lexer for two reasons:
 
-left factor to get rid of trys
+1. sql syntax is very awkward to parse, the separate lexer makes it
+easier to handle this in most places (in some places it makes it
+harder or impossible, the fix is to switch to something better than
+parsec
 
-add some notes on why there is a separate lexer.
+2. using a separate lexer gives a huge speed boost
 
 > -- | This is the module contains a Lexer for SQL.
 > {-# LANGUAGE TupleSections #-}
@@ -86,9 +89,8 @@ add some notes on why there is a separate lexer.
 
 
 
-> -- | Accurate pretty printing, if you lex a bunch of tokens,
+> -- | Pretty printing, if you lex a bunch of tokens, then pretty
-> -- then pretty print them, should should get back exactly the
+> -- print them, should should get back exactly the same string
-> -- same string
 > prettyToken :: Dialect -> Token -> String
 > prettyToken _ (Symbol s) = s
 > prettyToken _ (Identifier t) = t
@@ -116,6 +118,7 @@ add some notes on why there is a separate lexer.
 
 TODO: try to make all parsers applicative only
 
+> -- | Lex some SQL to a list of tokens.
 > lexSQL :: Dialect
 >                   -- ^ dialect of SQL to use
 >                -> FilePath
@@ -127,7 +130,7 @@ TODO: try to make all parsers applicative only
 >                   -- ^ the SQL source to lex
 >                -> Either ParseError [((String,Int,Int),Token)]
 > lexSQL dialect fn p src =
->     let (l,c) = fromMaybe (1,0) p
+>     let (l,c) = fromMaybe (1,1) p
 >     in either (Left . convParseError src) Right
 >        $ runParser (setPos (l,c) *> many (sqlToken dialect) <* eof) () fn src
 >   where
@@ -148,20 +151,6 @@ TODO: try to make all parsers applicative only
 >                     ,symbol d
 >                     ,sqlWhitespace d]
 
-> takeWhile1 :: (Char -> Bool) -> Parser String
-> takeWhile1 p = many1 (satisfy p)
-
-> takeWhile :: (Char -> Bool) -> Parser String
-> takeWhile p = many (satisfy p)
-
-> takeTill :: (Char -> Bool) -> Parser String
-> takeTill p =
->     try (manyTill anyChar (peekSatisfy p))
-
-> peekSatisfy :: (Char -> Bool) -> Parser ()
-> peekSatisfy p = do
->     void $ try $ lookAhead (satisfy p)
-
 > identifier :: Dialect -> Parser Token
 > identifier d =
 >     choice
@@ -255,13 +244,8 @@ character symbols in the two lists below.
 > lineComment :: Dialect -> Parser Token
 > lineComment _ =
 >     (\s -> LineComment $ concat ["--",s]) <$>
->     (try (string "--") *> choice
+>     (try (string "--") *>
->                     [flip snoc '\n' <$> takeTill (=='\n') <* char '\n'
+>      manyTill anyChar (void (char '\n') <|> eof))
->                     ,takeWhile (/='\n') <* eof
->                     ])
->   where
->     snoc :: String -> Char -> String
->     snoc s a = s ++ [a]
 
 > blockComment :: Dialect -> Parser Token
 > blockComment _ =
@@ -281,7 +265,7 @@ character symbols in the two lists below.
 >               -- nested comment, recurse
 >              ,try (string "/*") *> ((\s -> concat [x,"/*",s]) <$> commentSuffix (n + 1))
 >               -- not an end comment or nested comment, continue
->              ,(:) <$> anyChar <*> commentSuffix n]
+>              ,(\c s -> x ++ [c] ++ s) <$> anyChar <*> commentSuffix n]
 
 
 > startsWith :: (Char -> Bool) -> (Char -> Bool) -> Parser String
@@ -289,3 +273,17 @@ character symbols in the two lists below.
 >   c <- satisfy p
 >   choice [(:) c <$> (takeWhile1 ps)
 >          ,return [c]]
+
+> takeWhile1 :: (Char -> Bool) -> Parser String
+> takeWhile1 p = many1 (satisfy p)
+
+> takeWhile :: (Char -> Bool) -> Parser String
+> takeWhile p = many (satisfy p)
+
+> takeTill :: (Char -> Bool) -> Parser String
+> takeTill p =
+>     manyTill anyChar (peekSatisfy p)
+
+> peekSatisfy :: (Char -> Bool) -> Parser ()
+> peekSatisfy p = do
+>     void $ lookAhead (satisfy p)

Language/SQL/SimpleSQL/Parser.lhs

@@ -183,7 +183,7 @@ fixing them in the syntax but leaving them till the semantic checking
 >     ,ParseError(..)) where
 
 > import Control.Monad.Identity (Identity)
-> import Control.Monad (guard, void, when)
+> import Control.Monad (guard, void)
 > import Control.Applicative ((<$), (<$>), (<*>) ,(<*), (*>), (<**>), pure)
 > import Data.Char (toLower, isDigit)
 > import Text.Parsec (setPosition,setSourceColumn,setSourceLine,getPosition
@@ -261,7 +261,7 @@ converts the error return to the nice wrapper
 >           -> String
 >           -> Either ParseError a
 > wrapParse parser d f p src = do
->     let (l,c) = fromMaybe (1,0) p
+>     let (l,c) = fromMaybe (1,1) p
 >     lx <- L.lexSQL d f (Just (l,c)) src
 >     either (Left . convParseError src) Right
 >       $ runParser (setPos p *> parser <* eof)
@@ -316,7 +316,7 @@ u&"example quoted"
 >     d <- getState
 >     choice [QName <$> qidentifierTok
 >            ,UQName <$> uqidentifierTok
->            ,Name <$> identifierBlacklist (blacklist d)
+>            ,Name <$> identifierTok (blacklist d) Nothing
 >            ,(\(s,e,t) -> DQName s e t) <$> dqidentifierTok
 >            ]
 
@@ -545,7 +545,7 @@ See the stringToken lexer below for notes on string literal syntax.
 > stringLit = StringLit <$> stringTokExtend
 
 > numberLit :: Parser ValueExpr
-> numberLit = NumLit <$> sqlNumberTok
+> numberLit = NumLit <$> sqlNumberTok False
 
 > characterSetLit :: Parser ValueExpr
 > characterSetLit = uncurry CSStringLit <$> csSqlStringLitTok
@@ -999,7 +999,7 @@ for the escape now there is a separate lexer ...
 >     pure $ \v -> ctor v c
 >   where
 >     escapeChar :: Parser Char
->     escapeChar = (identifierTok <|> symbolTok) >>= oneOnly
+>     escapeChar = (identifierTok [] Nothing <|> symbolTok Nothing) >>= oneOnly
 >     oneOnly :: String -> Parser Char
 >     oneOnly c = case c of
 >                    [c'] -> return c'
@@ -1501,23 +1501,25 @@ and it will parse as a single string
 >       L.HostParam p -> Just p
 >       _ -> Nothing)
 
-> sqlNumberTok :: Parser String
+> sqlNumberTok :: Bool -> Parser String
-> sqlNumberTok = mytoken (\tok ->
+> sqlNumberTok intOnly = mytoken (\tok ->
 >     case tok of
->       L.SqlNumber p -> Just p
+>       L.SqlNumber p | not intOnly || all isDigit p -> Just p
 >       _ -> Nothing)
 
 
-> symbolTok :: Parser String
+> symbolTok :: Maybe String -> Parser String
-> symbolTok = mytoken (\tok ->
+> symbolTok sym = mytoken (\tok ->
->     case tok of
+>     case (sym,tok) of
->       L.Symbol p -> Just p
+>       (Nothing, L.Symbol p) -> Just p
+>       (Just s, L.Symbol p) | s == p -> Just p
 >       _ -> Nothing)
 
-> identifierTok :: Parser String
+> identifierTok :: [String] -> Maybe String -> Parser String
-> identifierTok = mytoken (\tok ->
+> identifierTok blackList kw = mytoken (\tok ->
->     case tok of
+>     case (kw,tok) of
->       L.Identifier p -> Just p
+>       (Nothing, L.Identifier p) | map toLower p `notElem` blackList -> Just p
+>       (Just k, L.Identifier p) | k == map toLower p -> Just p
 >       _ -> Nothing)
 
 > qidentifierTok :: Parser String
@@ -1547,19 +1549,12 @@ and it will parse as a single string
 >     testToken (_,tok)   = test tok
 
 > unsignedInteger :: Parser Integer
-> unsignedInteger = try (do
+> unsignedInteger = read <$> sqlNumberTok True <?> "natural number"
->                    x <- sqlNumberTok
->                    guard (all isDigit x)
->                    return $ read x
->                    ) <?> "integer"
 
 todo: work out the symbol parsing better
 
 > symbol :: String -> Parser String
-> symbol s = try (do
+> symbol s = symbolTok (Just s) <?> s
->   u <- symbolTok
->   guard (s == u)
->   pure s) <?> s
 
 > singleCharSymbol :: Char -> Parser Char
 > singleCharSymbol c = c <$ symbol [c]
@@ -1589,10 +1584,7 @@ todo: work out the symbol parsing better
 = helper functions
 
 > keyword :: String -> Parser String
-> keyword k = try (do
+> keyword k = identifierTok [] (Just k) <?> k
->     i <- identifierTok
->     guard (map toLower i == k)
->     pure k) <?> k
 
 helper function to improve error messages
 
@@ -1618,14 +1610,6 @@ helper function to improve error messages
 > commaSep1 :: Parser a -> Parser [a]
 > commaSep1 = (`sepBy1` comma)
 
-> identifierBlacklist :: [String] -> Parser String
-> identifierBlacklist bl = try (do
->     i <- identifierTok
->     when (map toLower i `elem` bl) $
->         fail $ "keyword not allowed here: " ++ i
->     pure i)
->     <?> "identifier"
-
 > blacklist :: Dialect -> [String]
 > blacklist = reservedWord
 

tools/Language/SQL/SimpleSQL/LexerTests.lhs

@@ -51,8 +51,7 @@ Test for the lexer
 >     -- block comment
 >     ++ map (\c -> (c, [BlockComment c]))
 >        ["/**/", "/* */","/* this is a comment */"
->         -- todo: bug in the lexer, fix this
+>        ,"/* this *is/ a comment */"
->         --,"/* this *is/ a comment */"
 >        ]