start reworking some of the combinators

Language/SQL/SimpleSQL/Parser.lhs

@@ -184,7 +184,7 @@ fixing them in the syntax but leaving them till the semantic checking
 
 > import Control.Monad.Identity (Identity)
 > import Control.Monad (guard, void, when)
-> import Control.Applicative ((<$), (<$>), (<*>) ,(<*), (*>))
+> import Control.Applicative ((<$), (<$>), (<*>) ,(<*), (*>), (<**>))
 > import Data.Maybe (fromMaybe,catMaybes)
 > import Data.Char (toLower)
 > import Text.Parsec (errorPos,sourceLine,sourceColumn,sourceName
@@ -192,7 +192,7 @@ fixing them in the syntax but leaving them till the semantic checking
 >                    ,option,between,sepBy,sepBy1,string,manyTill,anyChar
 >                    ,try,string,many1,oneOf,digit,(<|>),choice,char,eof
 >                    ,optionMaybe,optional,many,letter,parse
->                    ,chainl1, (<?>),notFollowedBy,alphaNum, lookAhead)
+>                    ,chainl1, chainr1,(<?>),notFollowedBy,alphaNum, lookAhead)
 > import Text.Parsec.String (Parser)
 > import qualified Text.Parsec as P (ParseError)
 > import Text.Parsec.Perm (permute,(<$?>), (<|?>))
@@ -306,11 +306,19 @@ u&"example quoted"
 >               ,UQName <$> uquotedIdentifier
 >               ,Name <$> identifierBlacklist blacklist]
 
+todo: replace (:[]) with a named function all over
+
 > names :: Parser [Name]
-> names = ((:[]) <$> name) >>= optionSuffix another
+> names = reverse <$> repeatPostfix ((:[]) <$> name) anotherName
+>   -- can't use a simple chain here since we
+>   -- want to wrap the . + name in a try
+>   -- this will change when this is left factored
 >   where
->     another n =
+>     anotherName :: Parser ([Name] -> [Name])
->         (((n++) . (:[])) <$> try (symbol "." *> name)) >>= optionSuffix another
+>     anotherName = try ((:) <$> (symbol "." *> name))
+
+> repeatPostfix :: Parser a -> Parser (a -> a) -> Parser a
+> repeatPostfix p q = foldr ($) <$> p <*> (reverse <$> many q)
 
 = Type Names
 
@@ -420,8 +428,9 @@ TODO: this code needs heavy refactoring
 
 > typeName :: Parser TypeName
 > typeName =
->     (rowTypeName <|> intervalTypeName <|> otherTypeName)
+>     repeatPostfix
->     >>= tnSuffix
+>         (rowTypeName <|> intervalTypeName <|> otherTypeName)
+>         tnSuffix
 >     <?> "typename"
 >   where
 >     -- row type names - a little like create table
@@ -438,6 +447,7 @@ TODO: this code needs heavy refactoring
 >     otherTypeName = do
 >         tn <- (try reservedTypeNames <|> names)
 >         choice [try $ timezone tn
+>                 -- todo: use the P (a->a) style
 >                ,try (precscale tn) >>= optionSuffix charSuffix
 >                ,try $ lob tn
 >                ,optionSuffix charSuffix $ TypeName tn]
@@ -480,14 +490,11 @@ TODO: this code needs heavy refactoring
 >     lobUnits = choice [PrecCharacters <$ keyword_ "characters"
 >                       ,PrecOctets <$ keyword_ "octets"]
 >     -- deal with multiset and array suffixes
->     tnSuffix x =
+>     tnSuffix :: Parser (TypeName -> TypeName)
->         multisetSuffix x <|> arrayTNSuffix x <|> return x
+>     tnSuffix = multisetSuffix <|> arrayTNSuffix
->     multisetSuffix x =
+>     multisetSuffix = MultisetTypeName <$ keyword_ "multiset"
->         (MultisetTypeName x <$ keyword_ "multiset") >>= tnSuffix
+>     arrayTNSuffix = keyword_ "array" >>
->     arrayTNSuffix x =
+>         flip ArrayTypeName <$> optionMaybe (brackets unsignedInteger)
->         (keyword_ "array" >> ArrayTypeName x
->                              <$> optionMaybe (brackets unsignedInteger)
->         ) >>= tnSuffix
 >     -- this parser handles the fixed set of multi word
 >     -- type names, plus all the type names which are
 >     -- reserved words
@@ -850,6 +857,9 @@ if there are no value exprs
 >     makeApp i (SQDefault,es,Nothing) = App i es
 >     makeApp i (d,es,od) = AggregateApp i d es (fromMaybe [] od) Nothing
 
+TODO: change all these suffix functions to use type
+Parser (ValueExpr -> ValueExpr)
+
 > app :: [Name] -> Parser ValueExpr
 > app n = aggOrApp n >>= \a -> choice
 >         [windowSuffix a
@@ -940,8 +950,6 @@ in: two variations:
 a in (expr0, expr1, ...)
 a in (queryexpr)
 
-this is parsed as a postfix operator which is why it is in this form
-
 > inSuffix :: Parser (ValueExpr -> ValueExpr)
 > inSuffix =
 >     mkIn <$> inty
@@ -1232,6 +1240,8 @@ tref
 > from :: Parser [TableRef]
 > from = keyword_ "from" *> commaSep1 tref
 >   where
+>     -- TODO: use P (a->) for the join tref suffix
+>     -- chainl or buildexpressionparser
 >     tref = nonJoinTref >>= optionSuffix joinTrefSuffix
 >     nonJoinTref = choice
 >         [parens $ choice
@@ -1243,9 +1253,8 @@ tref
 >          n <- names
 >          choice [TRFunction n
 >                  <$> parens (commaSep valueExpr)
->                 ,return $ TRSimple n]]
+>                 ,return $ TRSimple n]] <??> aliasSuffix
->         >>= optionSuffix aliasSuffix
+>     aliasSuffix = flip TRAlias <$> fromAlias
->     aliasSuffix j = option j (TRAlias j <$> fromAlias)
 >     joinTrefSuffix t =
 >         (TRJoin t <$> option False (True <$ keyword_ "natural")
 >                   <*> joinType
@@ -1356,7 +1365,7 @@ and union, etc..
 > queryExpr :: Parser QueryExpr
 > queryExpr = choice
 >     [with
->     ,choice [values,table, select] >>= optionSuffix queryExprSuffix]
+>     ,chainr1 (choice [values,table, select]) setOp]
 >   where
 >     select = keyword_ "select" >>
 >         mkSelect
@@ -1396,30 +1405,33 @@ be in the public syntax?
 >     mkTe f w g h od (ofs,fe) =
 >         TableExpression f w g h od ofs fe
 
-> queryExprSuffix :: QueryExpr -> Parser QueryExpr
+> setOp :: Parser (QueryExpr -> QueryExpr -> QueryExpr)
-> queryExprSuffix qe = cqSuffix >>= optionSuffix queryExprSuffix
+> setOp = cq
+>         <$> setOpK
+>         <*> (fromMaybe SQDefault <$> duplicates)
+>         <*> corr
 >   where
->     cqSuffix = CombineQueryExpr qe
+>     cq o d c q0 q1 = CombineQueryExpr q0 o d c q1
->                <$> setOp
+>     setOpK = choice [Union <$ keyword_ "union"
->                <*> (fromMaybe SQDefault <$> duplicates)
+>                     ,Intersect <$ keyword_ "intersect"
->                <*> corr
+>                     ,Except <$ keyword_ "except"]
->                <*> queryExpr
->     setOp = choice [Union <$ keyword_ "union"
->                    ,Intersect <$ keyword_ "intersect"
->                    ,Except <$ keyword_ "except"]
 >             <?> "set operator"
 >     corr = option Respectively (Corresponding <$ keyword_ "corresponding")
 
 
 wrapper for query expr which ignores optional trailing semicolon.
 
+TODO: change style
+
 > topLevelQueryExpr :: Parser QueryExpr
-> topLevelQueryExpr = queryExpr >>= optionSuffix ((semi *>) . return)
+> topLevelQueryExpr = queryExpr <??> (id <$ semi)
 
 wrapper to parse a series of query exprs from a single source. They
 must be separated by semicolon, but for the last expression, the
 trailing semicolon is optional.
 
+TODO: change style
+
 > queryExprs :: Parser [QueryExpr]
 > queryExprs = (:[]) <$> queryExpr
 >              >>= optionSuffix ((semi *>) . return)
@@ -1511,24 +1523,15 @@ making a decision on how to represent numbers, the client code can
 make this choice.
 
 > numberLiteral :: Parser String
-> numberLiteral =
+> numberLiteral = lexeme (
->     lexeme (numToken <* notFollowedBy (alphaNum <|> char '.'))
+>     int <??> (pp dot <??.> pp int) <??> pp expon
->     <?> "number literal"
+>     <|> (++) <$> dot <*> int <??> pp expon)
 >   where
->     numToken = choice [int
->                        >>= optionSuffix dot
->                        >>= optionSuffix fracts
->                        >>= optionSuffix expon
->                       ,fract "" >>= optionSuffix expon]
 >     int = many1 digit
->     fract p = dot p >>= fracts
+>     dot = string "."
->     dot p = (p++) <$> string "."
+>     expon = (:) <$> oneOf "eE" <*> sInt
->     fracts p = (p++) <$> int
+>     sInt = (++) <$> option "" (string "+" <|> string "-") <*> int
->     expon p = concat <$> sequence
+>     pp = ((++) <$$>)
->               [return p
->               ,(:[]) <$> oneOf "eE"
->               ,option "" (string "+" <|> string "-")
->               ,int]
 
 
 > identifier :: Parser String
@@ -1666,6 +1669,9 @@ associativity when chaining it recursively. Have to review
 all these uses and figure out if any should be right associative
 instead, and create an alternative suffix parser
 
+This is no good, and should be replaced with chain and <??> which has
+a different type
+
 > optionSuffix :: (a -> Parser a) -> a -> Parser a
 > optionSuffix p a = option a (p a)
 
@@ -2068,3 +2074,26 @@ context
 >                     ++ replicate (sourceColumn p - 1) ' ' ++ "^\n"
 >              _ -> ""
 >     p = errorPos e
+
+parses an optional postfix element and applies its result to its left
+hand result, taken from uu-parsinglib
+
+TODO: make sure the precedence higher than <|> and lower than the
+other operators so it can be used nicely
+
+> (<??>) :: Parser a -> Parser (a -> a) -> Parser a
+> p <??> q = p <**> option id q
+
+
+this is analogous to <**>
+
+> (<$$>) :: (a -> b -> c) -> Parser b -> Parser (a -> c)
+> (<$$>) = (<$>) . flip
+
+
+composing suffix parsers, not sure about the name
+
+> (<??.>) :: Parser (a -> a) -> Parser (a -> a) -> Parser (a -> a)
+> (<??.>) pa pb = (.) <$$> pa <*> option id pb
+
+

TODO

@@ -5,6 +5,14 @@ continue 2011 review and tests
 2. start thinking about automated tests for invalid syntax to catch
    bad parsing
 
+
+fixing the non idiomatic (pun!) suffix parsing:
+  typename parsing
+  identifier/app/agg/window parsing
+  join parsing in trefs (use chain? - tricky because of postfix onExpr)
+  top level and queryexprs parsing
+  number literal
+
 review names in the syntax for correspondence with sql standard, avoid
    gratuitous differences