diff --git a/Language/SQL/SimpleSQL/Parser.lhs b/Language/SQL/SimpleSQL/Parser.lhs index 092064d..222c44e 100644 --- a/Language/SQL/SimpleSQL/Parser.lhs +++ b/Language/SQL/SimpleSQL/Parser.lhs @@ -144,6 +144,12 @@ which parses as a typed literal > name = choice [QName <$> quotedIdentifier > ,Name <$> identifierBlacklist blacklist] +> names :: Parser [Name] +> names = ((:[]) <$> name) >>= optionSuffix another +> where +> another n = +> (((n++) . (:[])) <$> try (symbol "." *> name)) >>= optionSuffix another + == star used in select *, select x.*, and agg(*) variations, and some other @@ -181,7 +187,7 @@ The parsing for the aggregate extensions is here as well: aggregate([all|distinct] args [order by orderitems]) -> aggOrApp :: Name -> Parser ValueExpr +> aggOrApp :: [Name] -> Parser ValueExpr > aggOrApp n = > makeApp n > <$> parens ((,,) <$> (fromMaybe SQDefault <$> duplicates) @@ -243,7 +249,7 @@ always used with the optionSuffix combinator. > mkFrame rs c = c rs > windowSuffix _ = fail "" -> app :: Name -> Parser ValueExpr +> app :: [Name] -> Parser ValueExpr > app n = aggOrApp n >>= optionSuffix windowSuffix == iden prefix term @@ -256,7 +262,7 @@ all the value expressions which start with an identifier > idenPrefixTerm = > -- todo: work out how to left factor this > try (TypedLit <$> typeName <*> stringToken) -> <|> (name >>= iden) +> <|> (names >>= iden) > where > iden n = app n <|> return (Iden n) @@ -308,7 +314,7 @@ operatorname(firstArg keyword0 arg0 keyword1 arg1 etc.) > -- check we haven't parsed the first > -- keyword as an identifier > guard (case (e,kws) of -> (Iden (Name i), (k,_):_) | map toLower i == k -> False +> (Iden [Name i], (k,_):_) | map toLower i == k -> False > _ -> True) > return e > fa <- case firstArg of @@ -317,7 +323,7 @@ operatorname(firstArg keyword0 arg0 keyword1 arg1 etc.) > SOKMandatory -> Just <$> pfa > as <- mapM parseArg kws > void closeParen -> return $ SpecialOpK (Name opName) fa $ catMaybes as +> return $ SpecialOpK [Name opName] fa $ catMaybes as > where > parseArg (nm,mand) = > let p = keyword_ nm >> valueExpr @@ -389,7 +395,7 @@ in the source > ,"trailing" <$ keyword_ "trailing" > ,"both" <$ keyword_ "both"] > mkTrim fa ch fr = -> SpecialOpK (Name "trim") Nothing +> SpecialOpK [Name "trim"] Nothing > $ catMaybes [Just (fa,StringLit ch) > ,Just ("from", fr)] @@ -426,14 +432,14 @@ and operator. This is the call to valueExprB. > betweenSuffix :: Parser (ValueExpr -> ValueExpr) > betweenSuffix = -> makeOp <$> (Name <$> opName) +> makeOp <$> Name <$> opName > <*> valueExprB > <*> (keyword_ "and" *> valueExprB) > where > opName = choice > ["between" <$ keyword_ "between" > ,"not between" <$ try (keyword_ "not" <* keyword_ "between")] -> makeOp n b c = \a -> SpecialOp n [a,b,c] +> makeOp n b c = \a -> SpecialOp [n] [a,b,c] subquery expression: [exists|unique] (queryexpr) @@ -453,7 +459,7 @@ a = any (select * from t) > c <- comp > cq <- compQuan > q <- parens queryExpr -> return $ \v -> QuantifiedComparison v c cq q +> return $ \v -> QuantifiedComparison v [c] cq q > where > comp = Name <$> choice (map symbol > ["=", "<>", "<=", "<", ">", ">="]) @@ -481,7 +487,7 @@ a match (select a from t) > arrayCtor = keyword_ "array" >> > choice > [ArrayCtor <$> parens queryExpr -> ,Array (Iden (Name "array")) <$> brackets (commaSep valueExpr)] +> ,Array (Iden [Name "array"]) <$> brackets (commaSep valueExpr)] > escape :: Parser (ValueExpr -> ValueExpr) > escape = do @@ -545,7 +551,7 @@ todo: timestamp types: > ,ctor <$> commaSep1 valueExpr] > where > ctor [a] = Parens a -> ctor as = SpecialOp (Name "rowctor") as +> ctor as = SpecialOp [Name "rowctor"] as == operator parsing @@ -624,12 +630,12 @@ TODO: carefully review the precedences and associativities. > -- somehow > binaryKeywords nm assoc = binary (try $ mapM_ keyword_ (words nm)) nm assoc > binary p nm assoc = -> E.Infix (p >> return (\a b -> BinOp a (Name nm) b)) assoc +> E.Infix (p >> return (\a b -> BinOp a [Name nm] b)) assoc > prefixKeyword nm = prefix (keyword_ nm) nm > prefixSym nm = prefix (symbol_ nm) nm -> prefix p nm = prefix' (p >> return (PrefixOp (Name nm))) +> prefix p nm = prefix' (p >> return (PrefixOp [Name nm])) > postfixKeywords nm = postfix (try $ mapM_ keyword_ (words nm)) nm -> postfix p nm = postfix' (p >> return (PostfixOp (Name nm))) +> postfix p nm = postfix' (p >> return (PostfixOp [Name nm])) > -- hack from here > -- http://stackoverflow.com/questions/10475337/parsec-expr-repeated-prefix-postfix-operator-not-supported > -- not implemented properly yet @@ -705,12 +711,10 @@ tref > ,TRLateral <$> (keyword_ "lateral" > *> nonJoinTref) > ,do -> n <- name +> n <- names > choice [TRFunction n > <$> parens (commaSep valueExpr) -> ,do -> choice [TRQualified n <$> (symbol "." >> name) -> ,return $ TRSimple n]]] +> ,return $ TRSimple n]] > >>= optionSuffix aliasSuffix > aliasSuffix j = option j (TRAlias j <$> alias) > joinTrefSuffix t = (do @@ -842,7 +846,7 @@ and union, etc.. > Select d sl f w g h od ofs fe > values = keyword_ "values" > >> Values <$> commaSep (parens (commaSep valueExpr)) -> table = keyword_ "table" >> Table <$> name +> table = keyword_ "table" >> Table <$> names local data type to help with parsing the bit after the select list, called 'table expression' in the ansi sql grammar. Maybe this should diff --git a/Language/SQL/SimpleSQL/Pretty.lhs b/Language/SQL/SimpleSQL/Pretty.lhs index 20715fb..98cc3e1 100644 --- a/Language/SQL/SimpleSQL/Pretty.lhs +++ b/Language/SQL/SimpleSQL/Pretty.lhs @@ -14,8 +14,9 @@ which have been changed to try to improve the layout of the output. > import Language.SQL.SimpleSQL.Syntax > import Text.PrettyPrint (render, vcat, text, (<>), (<+>), empty, parens, > nest, Doc, punctuate, comma, sep, quotes, -> doubleQuotes, brackets) +> doubleQuotes, brackets,hcat) > import Data.Maybe (maybeToList, catMaybes) +> import Data.List (intercalate) > -- | Convert a query expr ast to concrete syntax. > prettyQueryExpr :: QueryExpr -> String @@ -40,7 +41,7 @@ which have been changed to try to improve the layout of the output. > text "interval" <+> quotes (text v) > <+> text u > <+> maybe empty (parens . text . show ) p -> valueExpr (Iden i) = name i +> valueExpr (Iden i) = names i > valueExpr Star = text "*" > valueExpr Parameter = text "?" > valueExpr (HostParameter p i) = @@ -49,10 +50,10 @@ which have been changed to try to improve the layout of the output. > (\i' -> text "indicator" <+> text (':':i')) > i -> valueExpr (App f es) = name f <> parens (commaSep (map valueExpr es)) +> valueExpr (App f es) = names f <> parens (commaSep (map valueExpr es)) > valueExpr (AggregateApp f d es od) = -> name f +> names f > <> parens ((case d of > Distinct -> text "distinct" > All -> text "all" @@ -61,7 +62,7 @@ which have been changed to try to improve the layout of the output. > <+> orderBy od) > valueExpr (WindowApp f es pb od fr) = -> name f <> parens (commaSep $ map valueExpr es) +> names f <> parens (commaSep $ map valueExpr es) > <+> text "over" > <+> parens ((case pb of > [] -> empty @@ -83,40 +84,40 @@ which have been changed to try to improve the layout of the output. > fpd (Preceding e) = valueExpr e <+> text "preceding" > fpd (Following e) = valueExpr e <+> text "following" -> valueExpr (SpecialOp nm [a,b,c]) | nm `elem` [Name "between" -> ,Name "not between"] = +> valueExpr (SpecialOp nm [a,b,c]) | nm `elem` [[Name "between"] +> ,[Name "not between"]] = > sep [valueExpr a -> ,name nm <+> valueExpr b -> ,nest (length (unname nm) + 1) $ text "and" <+> valueExpr c] +> ,names nm <+> valueExpr b +> ,nest (length (unnames nm) + 1) $ text "and" <+> valueExpr c] -> valueExpr (SpecialOp (Name "rowctor") as) = +> valueExpr (SpecialOp [Name "rowctor"] as) = > parens $ commaSep $ map valueExpr as > valueExpr (SpecialOp nm es) = -> name nm <+> parens (commaSep $ map valueExpr es) +> names nm <+> parens (commaSep $ map valueExpr es) > valueExpr (SpecialOpK nm fs as) = -> name nm <> parens (sep $ catMaybes +> names nm <> parens (sep $ catMaybes > (fmap valueExpr fs > : map (\(n,e) -> Just (text n <+> valueExpr e)) as)) -> valueExpr (PrefixOp f e) = name f <+> valueExpr e -> valueExpr (PostfixOp f e) = valueExpr e <+> name f -> valueExpr e@(BinOp _ op _) | op `elem` [Name "and", Name "or"] = +> valueExpr (PrefixOp f e) = names f <+> valueExpr e +> valueExpr (PostfixOp f e) = valueExpr e <+> names f +> valueExpr e@(BinOp _ op _) | op `elem` [[Name "and"], [Name "or"]] = > -- special case for and, or, get all the ands so we can vcat them > -- nicely > case ands e of > (e':es) -> vcat (valueExpr e' -> : map ((name op <+>) . valueExpr) es) +> : map ((names op <+>) . valueExpr) es) > [] -> empty -- shouldn't be possible > where > ands (BinOp a op' b) | op == op' = ands a ++ ands b > ands x = [x] > -- special case for . we don't use whitespace -> valueExpr (BinOp e0 (Name ".") e1) = +> valueExpr (BinOp e0 [Name "."] e1) = > valueExpr e0 <> text "." <> valueExpr e1 > valueExpr (BinOp e0 f e1) = -> valueExpr e0 <+> name f <+> valueExpr e1 +> valueExpr e0 <+> names f <+> valueExpr e1 > valueExpr (Case t ws els) = > sep $ [text "case" <+> maybe empty valueExpr t] @@ -146,7 +147,7 @@ which have been changed to try to improve the layout of the output. > valueExpr (QuantifiedComparison v c cp sq) = > valueExpr v -> <+> name c +> <+> names c > <+> (text $ case cp of > CPAny -> "any" > CPSome -> "some" @@ -197,10 +198,17 @@ which have been changed to try to improve the layout of the output. > unname (QName n) = "\"" ++ n ++ "\"" > unname (Name n) = n +> unnames :: [Name] -> String +> unnames ns = intercalate "." $ map unname ns + + > name :: Name -> Doc > name (QName n) = doubleQuotes $ text n > name (Name n) = text n +> names :: [Name] -> Doc +> names ns = hcat $ punctuate (text ".") $ map name ns + > typeName :: TypeName -> Doc > typeName (TypeName t) = text t > typeName (PrecTypeName t a) = text t <+> parens (text $ show a) @@ -250,7 +258,7 @@ which have been changed to try to improve the layout of the output. > queryExpr (Values vs) = > text "values" > <+> nest 7 (commaSep (map (parens . commaSep . map valueExpr) vs)) -> queryExpr (Table t) = text "table" <+> name t +> queryExpr (Table t) = text "table" <+> names t > alias :: Alias -> Doc @@ -270,11 +278,10 @@ which have been changed to try to improve the layout of the output. > sep [text "from" > ,nest 5 $ vcat $ punctuate comma $ map tr ts] > where -> tr (TRSimple t) = name t -> tr (TRQualified s t) = name s <> text "." <> name t +> tr (TRSimple t) = names t > tr (TRLateral t) = text "lateral" <+> tr t > tr (TRFunction f as) = -> name f <> parens (commaSep $ map valueExpr as) +> names f <> parens (commaSep $ map valueExpr as) > tr (TRAlias t a) = sep [tr t, alias a] > tr (TRParens t) = parens $ tr t > tr (TRQueryExpr q) = parens $ queryExpr q diff --git a/Language/SQL/SimpleSQL/Syntax.lhs b/Language/SQL/SimpleSQL/Syntax.lhs index c6560d2..1c26f3a 100644 --- a/Language/SQL/SimpleSQL/Syntax.lhs +++ b/Language/SQL/SimpleSQL/Syntax.lhs @@ -60,17 +60,17 @@ > ,ilUnits :: String -- ^ units > ,ilPrecision :: Maybe Integer -- ^ precision > } -> -- | identifier without dots -> | Iden Name +> -- | identifier with parts separated by dots +> | Iden [Name] > -- | star, as in select *, t.*, count(*) > | Star > -- | function application (anything that looks like c style > -- function application syntactically) -> | App Name [ValueExpr] +> | App [Name] [ValueExpr] > -- | aggregate application, which adds distinct or all, and > -- order by, to regular function application > | AggregateApp -> {aggName :: Name -- ^ aggregate function name +> {aggName :: [Name] -- ^ aggregate function name > ,aggDistinct :: SetQuantifier -- ^ distinct > ,aggArgs :: [ValueExpr]-- ^ args > ,aggOrderBy :: [SortSpec] -- ^ order by @@ -79,7 +79,7 @@ > -- by b) to regular function application. Explicit frames are > -- not currently supported > | WindowApp -> {wnName :: Name -- ^ window function name +> {wnName :: [Name] -- ^ window function name > ,wnArgs :: [ValueExpr] -- ^ args > ,wnPartition :: [ValueExpr] -- ^ partition by > ,wnOrderBy :: [SortSpec] -- ^ order by @@ -88,23 +88,23 @@ > -- | Infix binary operators. This is used for symbol operators > -- (a + b), keyword operators (a and b) and multiple keyword > -- operators (a is similar to b) -> | BinOp ValueExpr Name ValueExpr +> | BinOp ValueExpr [Name] ValueExpr > -- | Prefix unary operators. This is used for symbol > -- operators, keyword operators and multiple keyword operators. -> | PrefixOp Name ValueExpr +> | PrefixOp [Name] ValueExpr > -- | Postfix unary operators. This is used for symbol > -- operators, keyword operators and multiple keyword operators. -> | PostfixOp Name ValueExpr +> | PostfixOp [Name] ValueExpr > -- | Used for ternary, mixfix and other non orthodox > -- operators. Currently used for row constructors, and for > -- between. -> | SpecialOp Name [ValueExpr] +> | SpecialOp [Name] [ValueExpr] > -- | Used for the operators which look like functions > -- except the arguments are separated by keywords instead > -- of commas. The maybe is for the first unnamed argument > -- if it is present, and the list is for the keyword argument > -- pairs. -> | SpecialOpK Name (Maybe ValueExpr) [(String,ValueExpr)] +> | SpecialOpK [Name] (Maybe ValueExpr) [(String,ValueExpr)] > -- | case expression. both flavours supported > | Case > {caseTest :: Maybe ValueExpr -- ^ test value @@ -129,7 +129,7 @@ > -- indicator :nl > | QuantifiedComparison > ValueExpr -> Name -- operator +> [Name] -- operator > CompPredQuantifier > QueryExpr > | Match ValueExpr Bool -- true if unique @@ -254,7 +254,7 @@ This would make some things a bit cleaner? > ,qeViews :: [(Alias,QueryExpr)] > ,qeQueryExpression :: QueryExpr} > | Values [[ValueExpr]] -> | Table Name +> | Table [Name] > deriving (Eq,Show,Read,Data,Typeable) TODO: add queryexpr parens to deal with e.g. @@ -309,10 +309,8 @@ I'm not sure if this is valid syntax or not. > deriving (Eq,Show,Read,Data,Typeable) > -- | Represents a entry in the csv of tables in the from clause. -> data TableRef = -- | from t -> TRSimple Name -> -- | from s.t -> | TRQualified Name Name +> data TableRef = -- | from t / from s.t +> TRSimple [Name] > -- | from a join b > | TRJoin TableRef JoinType TableRef (Maybe JoinCondition) > -- | from (a) @@ -322,7 +320,7 @@ I'm not sure if this is valid syntax or not. > -- | from (query expr) > | TRQueryExpr QueryExpr > -- | from function(args) -> | TRFunction Name [ValueExpr] +> | TRFunction [Name] [ValueExpr] > -- | from lateral t > | TRLateral TableRef > deriving (Eq,Show,Read,Data,Typeable) diff --git a/tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs b/tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs index 811eedb..f206db7 100644 --- a/tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs +++ b/tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs @@ -67,8 +67,8 @@ These are a few misc tests which don't fit anywhere else. > ,("select a + b * c" > ,makeSelect {qeSelectList = -> [(BinOp (Iden (Name "a")) (Name "+") -> (BinOp (Iden (Name "b")) (Name "*") (Iden (Name "c"))) +> [(BinOp (Iden "a") "+" +> (BinOp (Iden "b") "*" (Iden "c")) > ,Nothing)]}) > ] diff --git a/tools/Language/SQL/SimpleSQL/TableRefs.lhs b/tools/Language/SQL/SimpleSQL/TableRefs.lhs index c75212e..91bd35d 100644 --- a/tools/Language/SQL/SimpleSQL/TableRefs.lhs +++ b/tools/Language/SQL/SimpleSQL/TableRefs.lhs @@ -21,7 +21,7 @@ expression > ,ms [TRSimple "t", TRSimple "u"]) > ,("select a from s.t" -> ,ms [TRQualified "s" "t"]) +> ,ms [TRSimple ["s","t"]]) these lateral queries make no sense but the syntax is valid diff --git a/tools/Language/SQL/SimpleSQL/TestTypes.lhs b/tools/Language/SQL/SimpleSQL/TestTypes.lhs index 8254c9c..8a3d6da 100644 --- a/tools/Language/SQL/SimpleSQL/TestTypes.lhs +++ b/tools/Language/SQL/SimpleSQL/TestTypes.lhs @@ -2,6 +2,7 @@ This is the types used to define the tests as pure data. See the Tests.lhs module for the 'interpreter'. +> {-# LANGUAGE FlexibleInstances #-} > module Language.SQL.SimpleSQL.TestTypes where > import Language.SQL.SimpleSQL.Syntax @@ -24,3 +25,6 @@ hack to make the tests a bit simpler > instance IsString Name where > fromString = Name + +> instance IsString [Name] where +> fromString = (:[]) . Name diff --git a/tools/Language/SQL/SimpleSQL/ValueExprs.lhs b/tools/Language/SQL/SimpleSQL/ValueExprs.lhs index e4b1c2b..f974e1c 100644 --- a/tools/Language/SQL/SimpleSQL/ValueExprs.lhs +++ b/tools/Language/SQL/SimpleSQL/ValueExprs.lhs @@ -47,7 +47,7 @@ Tests for parsing value expressions > identifiers = Group "identifiers" $ map (uncurry TestValueExpr) > [("iden1", Iden "iden1") > --,("t.a", Iden2 "t" "a") -> ,("\"quoted identifier\"", Iden $ QName "quoted identifier") +> ,("\"quoted identifier\"", Iden [QName "quoted identifier"]) > ] > star :: TestItem @@ -65,9 +65,9 @@ Tests for parsing value expressions > dots :: TestItem > dots = Group "dot" $ map (uncurry TestValueExpr) -> [("t.a", BinOp (Iden "t") "." (Iden "a")) +> [("t.a", Iden ["t","a"]) > ,("t.*", BinOp (Iden "t") "." Star) -> ,("a.b.c", BinOp (BinOp (Iden "a") "." (Iden "b")) "." (Iden "c")) +> ,("a.b.c", Iden ["a","b","c"]) > ,("ROW(t.*,42)", App "ROW" [BinOp (Iden "t") "." Star, NumLit "42"]) > ]