diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2017 Uber Technologies, Inc. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,22 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +import Distribution.Simple +main = defaultMain diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,40 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +module Main where + +import Criterion.Main (defaultMain, bench, bgroup, whnf) + +import qualified Database.Sql.Vertica.Parser as VSQL +import qualified Database.Sql.Hive.Parser as HiveQL + +import qualified Data.Text.Lazy as TL + +main :: IO () +main = defaultMain + [ bgroup "parsing" + [ bgroup "Vertica" + [ bench "tiny" $ whnf VSQL.parseAll "SELECT 1;" + ] + , bgroup "Hive" + [ bench "tiny" $ whnf HiveQL.parseAll "SELECT 1;" + ] + ] + ] diff --git a/queryparser.cabal b/queryparser.cabal new file mode 100644 --- /dev/null +++ b/queryparser.cabal @@ -0,0 +1,140 @@ +name: queryparser + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: Analysis and parsing library for SQL queries. + +-- A longer description of the package. +description: + A library for parsing SQL queries into well-typed data structures, + and producing easily quantifiable analyses from said data + structures. + . + Currently this includes support for Hive, Vertica, and Presto + dialects of SQL. Parsing for each dialect is provided in their own + package, as queryparser-{dialect} + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Heli Wang, David Thomas, Matt Halverson + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: heli@uber.com + +-- A copyright notice. +-- copyright: + +category: Database + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +-- extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + +flag development { + description: Enable development level of strictness + default: False + manual: True +} + +library + -- Modules exported by the library. + exposed-modules: Database.Sql.Position + , Database.Sql.Helpers + , Database.Sql.Info + , Database.Sql.Type + , Database.Sql.Type.Names + , Database.Sql.Type.Query + , Database.Sql.Type.Schema + , Database.Sql.Type.Scope + , Database.Sql.Type.TableProps + , Database.Sql.Type.Unused + , Database.Sql.Pretty + , Database.Sql.Util.Columns + , Database.Sql.Util.Eval + , Database.Sql.Util.Eval.Concrete + , Database.Sql.Util.Joins + , Database.Sql.Util.Scope + , Database.Sql.Util.Tables + , Database.Sql.Util.Lineage.Table + , Database.Sql.Util.Lineage.ColumnPlus + , Database.Sql.Util.Schema + + -- Modules included in this library but not exported. + other-modules: Data.Maybe.More + , Data.Functor.Identity.Orphans + + default-extensions: OverloadedStrings + , LambdaCase + , RecordWildCards + , TupleSections + , ConstraintKinds + , FlexibleInstances + + -- Other library packages from which modules are imported. + build-depends: base >=4.8 && <4.9 + , text >=1.2 && <1.3 + , bytestring + , containers + , semigroups >= 0.16 + , mtl >= 2.2 && < 2.3 + , parsec >= 3.1 && < 3.2 + , pretty >= 1.1 && < 1.2 + , aeson >= 0.8 + , yaml >= 0.8 && < 0.9 + , unordered-containers + , hashable + , QuickCheck + , fixed-list + , predicate-class + + -- Directories containing source files. + hs-source-dirs: src + + + ghc-options: -Wall + + if flag(development) + ghc-options: -Werror + + -- Base language which the package is written in. + default-language: Haskell2010 + +benchmark queryparser-bench + type: exitcode-stdio-1.0 + main-is: Bench.hs + build-depends: base >=4.8 && <4.9 + , queryparser + , criterion + , text + hs-source-dirs: bench + + ghc-options: -Wall -with-rtsopts=-M5M + + if flag(development) + ghc-options: -Werror + + default-language: Haskell2010 + default-extensions: OverloadedStrings + , LambdaCase + , RecordWildCards + , TupleSections + , ConstraintKinds + , FlexibleInstances diff --git a/src/Data/Functor/Identity/Orphans.hs b/src/Data/Functor/Identity/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Identity/Orphans.hs @@ -0,0 +1,31 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Functor.Identity.Orphans where + +import Data.Functor.Identity + +import Test.QuickCheck + +instance Arbitrary a => Arbitrary (Identity a) where + arbitrary = Identity <$> arbitrary + shrink (Identity x) = Identity <$> shrink x diff --git a/src/Data/Maybe/More.hs b/src/Data/Maybe/More.hs new file mode 100644 --- /dev/null +++ b/src/Data/Maybe/More.hs @@ -0,0 +1,27 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +module Data.Maybe.More where + +overJust :: Applicative f => (t -> f a) -> Maybe t -> f (Maybe a) +overJust _ Nothing = pure Nothing +overJust f (Just x) = Just <$> f x + + diff --git a/src/Database/Sql/Helpers.hs b/src/Database/Sql/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Helpers.hs @@ -0,0 +1,64 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +module Database.Sql.Helpers where + +import Database.Sql.Position + +import Text.Parsec (ParsecT, Stream, option, optionMaybe) +import qualified Text.Parsec as P + +import Data.Semigroup (Semigroup, sconcat, (<>)) +import Data.List.NonEmpty (NonEmpty ((:|))) + + +consumeOrderedOptions :: (Stream s m t, Semigroup a) => a -> [ParsecT s u m a] -> ParsecT s u m a +consumeOrderedOptions defaultVal optionPs = do + let v = defaultVal + vs <- sequence $ map (option v) optionPs + pure $ sconcat $ v :| vs + + +-- the options may appear in any order, but may only appear once. +consumeUnorderedOptions :: (Stream s m t, Semigroup a) => a -> [ParsecT s u m a] -> ParsecT s u m a +consumeUnorderedOptions defaultVal optionPs = go defaultVal optionPs [] + where + go v [] _ = return v + + go v untriedPs triedPs = do + let candidateP:remainingPs = untriedPs + optionMaybe candidateP >>= \case + Just v' -> go (v <> v') (remainingPs ++ triedPs) [] + Nothing -> go v remainingPs (candidateP:triedPs) + + +eof :: (Stream s m t, Show t, Integral u) => ParsecT s u m Range +eof = do + _ <- P.eof + p <- position + return $ Range p p + where + position = do + sourcePos <- P.getPosition + offset <- P.getState + let positionLine = fromIntegral $ P.sourceLine sourcePos + positionColumn = fromIntegral $ P.sourceColumn sourcePos + positionOffset = fromIntegral $ offset + return Position{..} diff --git a/src/Database/Sql/Info.hs b/src/Database/Sql/Info.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Info.hs @@ -0,0 +1,389 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +{-# LANGUAGE TypeFamilies #-} + +module Database.Sql.Info where + +import Database.Sql.Type +import Data.Semigroup + +class HasInfo a where + type Info a + getInfo :: a -> Info a + + +instance HasInfo (Statement d r a) where + type Info (Statement d r a) = a + getInfo (QueryStmt query) = getInfo query + getInfo (InsertStmt insert) = getInfo insert + getInfo (UpdateStmt update) = getInfo update + getInfo (DeleteStmt delete) = getInfo delete + getInfo (TruncateStmt truncate') = getInfo truncate' + getInfo (CreateTableStmt create) = getInfo create + getInfo (AlterTableStmt alter) = getInfo alter + getInfo (DropTableStmt drop') = getInfo drop' + getInfo (CreateViewStmt create) = getInfo create + getInfo (DropViewStmt drop') = getInfo drop' + getInfo (CreateSchemaStmt create) = getInfo create + getInfo (GrantStmt grant) = getInfo grant + getInfo (RevokeStmt revoke) = getInfo revoke + getInfo (BeginStmt info) = info + getInfo (CommitStmt info) = info + getInfo (RollbackStmt info) = info + getInfo (ExplainStmt info _) = info + getInfo (EmptyStmt info) = info + +instance HasInfo (CreateTable d r a) where + type Info (CreateTable d r a) = a + getInfo = createTableInfo + +instance HasInfo (AlterTable r a) where + type Info (AlterTable r a) = a + getInfo (AlterTableRenameTable info _ _) = info + getInfo (AlterTableRenameColumn info _ _ _) = info + getInfo (AlterTableAddColumns info _ _) = info + +instance HasInfo (TableDefinition d r a) where + type Info (TableDefinition d r a) = a + getInfo (TableColumns info _) = info + getInfo (TableLike info _) = info + getInfo (TableAs info _ _) = info + getInfo (TableNoColumnInfo info) = info + +instance HasInfo (Insert r a) where + type Info (Insert r a) = a + getInfo = insertInfo + +instance HasInfo (InsertValues r a) where + type Info (InsertValues r a) = a + getInfo (InsertExprValues info _) = info + getInfo (InsertSelectValues query) = getInfo query + getInfo (InsertDefaultValues info) = info + getInfo (InsertDataFromFile info _) = info + +instance HasInfo (Update r a) where + type Info (Update r a) = a + getInfo = updateInfo + +instance HasInfo (Delete r a) where + type Info (Delete r a) = a + getInfo (Delete info _ _) = info + +instance HasInfo (Truncate r a) where + type Info (Truncate r a) = a + getInfo (Truncate info _) = info + +instance HasInfo (DropTable r a) where + type Info (DropTable r a) = a + getInfo = dropTableInfo + +instance HasInfo (CreateView r a) where + type Info (CreateView r a) = a + getInfo = createViewInfo + +instance HasInfo (DropView r a) where + type Info (DropView r a) = a + getInfo = dropViewInfo + +instance HasInfo (CreateSchema r a) where + type Info (CreateSchema r a) = a + getInfo = createSchemaInfo + +instance HasInfo (Grant a) where + type Info (Grant a) = a + getInfo (Grant info) = info + +instance HasInfo (Revoke a) where + type Info (Revoke a) = a + getInfo (Revoke info) = info + +instance HasInfo (Query r a) where + type Info (Query r a) = a + getInfo (QuerySelect info _) = info + getInfo (QueryExcept info _ _ _) = info + getInfo (QueryUnion info _ _ _ _) = info + getInfo (QueryIntersect info _ _ _) = info + getInfo (QueryWith info _ _) = info + getInfo (QueryOrder info _ _) = info + getInfo (QueryLimit info _ _) = info + getInfo (QueryOffset info _ _) = info + + +instance HasInfo (DatabaseName a) where + type Info (DatabaseName a) = a + getInfo (DatabaseName info _) = info + +instance (Foldable f, Functor f, Semigroup a) => HasInfo (QSchemaName f a) where + type Info (QSchemaName f a) = a + getInfo (QSchemaName info database _ _) = foldl (<>) info $ getInfo <$> database + +instance (Foldable f, Functor f, Semigroup a) => HasInfo (QTableName f a) where + type Info (QTableName f a) = a + getInfo (QTableName info schema _) = foldl (<>) info $ getInfo <$> schema + +instance HasInfo (TableAlias a) where + type Info (TableAlias a) = a + getInfo (TableAlias info _ _) = info + +instance Semigroup a => HasInfo (RTableRef a) where + type Info (RTableRef a) = a + getInfo (RTableRef name _) = getInfo name + getInfo (RTableAlias alias) = getInfo alias + +instance Semigroup a => HasInfo (RTableName a) where + type Info (RTableName a) = a + getInfo (RTableName name _) = getInfo name + +instance (Foldable f, Functor f, Semigroup a) => HasInfo (QFunctionName f a) where + type Info (QFunctionName f a) = a + getInfo (QFunctionName info _ _) = info + +instance (Foldable f, Functor f, Semigroup a) => HasInfo (QColumnName f a) where + type Info (QColumnName f a) = a + getInfo (QColumnName info table _) = foldl (<>) info $ getInfo <$> table + +instance HasInfo (ColumnAlias a) where + type Info (ColumnAlias a) = a + getInfo (ColumnAlias info _ _) = info + +instance Semigroup a => HasInfo (RColumnRef a) where + type Info (RColumnRef a) = a + getInfo (RColumnRef name) = getInfo name + getInfo (RColumnAlias alias) = getInfo alias + +instance HasInfo (ParamName a) where + type Info (ParamName a) = a + getInfo (ParamName info _) = info + +instance HasInfo (DefaultExpr r a) where + type Info (DefaultExpr r a) = a + getInfo (DefaultValue info) = info + getInfo (ExprValue expr) = getInfo expr + +instance HasInfo (Expr r a) where + type Info (Expr r a) = a + getInfo (BinOpExpr info _ _ _) = info + getInfo (CaseExpr info _ _) = info + getInfo (UnOpExpr info _ _) = info + getInfo (LikeExpr info _ _ _ _) = info + getInfo (ConstantExpr info _) = info + getInfo (ColumnExpr info _) = info + getInfo (InListExpr info _ _) = info + getInfo (InSubqueryExpr info _ _) = info + getInfo (BetweenExpr info _ _ _) = info + getInfo (OverlapsExpr info _ _) = info + getInfo (FunctionExpr info _ _ _ _ _ _) = info + getInfo (AtTimeZoneExpr info _ _) = info + getInfo (SubqueryExpr info _) = info + getInfo (ArrayExpr info _) = info + getInfo (ExistsExpr info _) = info + getInfo (FieldAccessExpr info _ _) = info + getInfo (ArrayAccessExpr info _ _) = info + getInfo (TypeCastExpr info _ _ _) = info + getInfo (VariableSubstitutionExpr info) = info + +instance HasInfo (Filter r a) where + type Info (Filter r a) = a + getInfo (Filter info _) = info + +instance HasInfo (NamedWindowExpr r a) where + type Info (NamedWindowExpr r a) = a + getInfo (NamedWindowExpr info _ _) = info + getInfo (NamedPartialWindowExpr info _ _) = info + +instance HasInfo (OverSubExpr r a) where + type Info (OverSubExpr r a) = a + getInfo (OverWindowExpr info _) = info + getInfo (OverWindowName info _) = info + getInfo (OverPartialWindowExpr info _) = info + +instance HasInfo (WindowExpr r a) where + type Info (WindowExpr r a) = a + getInfo (WindowExpr info _ _ _) = info + +instance HasInfo (PartialWindowExpr r a) where + type Info (PartialWindowExpr r a) = a + getInfo (PartialWindowExpr info _ _ _ _) = info + +instance HasInfo (Partition r a) where + type Info (Partition r a) = a + getInfo (PartitionBy info _) = info + getInfo (PartitionBest info) = info + getInfo (PartitionNodes info) = info + +instance HasInfo (Order r a) where + type Info (Order r a) = a + getInfo (Order info _ _ _) = info + +instance HasInfo (WindowName a) where + type Info (WindowName a) = a + getInfo (WindowName info _) = info + +instance HasInfo (StructFieldName a) where + type Info (StructFieldName a) = a + getInfo (StructFieldName info _) = info + +instance HasInfo (ArrayIndex a) where + type Info (ArrayIndex a) = a + getInfo (ArrayIndex info _) = info + +instance HasInfo (DataType a) where + type Info (DataType a) = a + getInfo (PrimitiveDataType info _ _) = info + getInfo (ArrayDataType info _) = info + getInfo (MapDataType info _ _) = info + getInfo (StructDataType info _) = info + getInfo (UnionDataType info _) = info + +instance HasInfo (DataTypeParam a) where + type Info (DataTypeParam a) = a + getInfo (DataTypeParamConstant c) = getInfo c + getInfo (DataTypeParamType t) = getInfo t + +instance HasInfo (Select r a) where + type Info (Select r a) = a + getInfo = selectInfo + + +instance HasInfo (SelectColumns r a) where + type Info (SelectColumns r a) = a + getInfo (SelectColumns info _) = info + + +instance HasInfo (SelectFrom r a) where + type Info (SelectFrom r a) = a + getInfo (SelectFrom info _) = info + + +instance HasInfo (SelectWhere r a) where + type Info (SelectWhere r a) = a + getInfo (SelectWhere info _) = info + +instance HasInfo (SelectTimeseries r a) where + type Info (SelectTimeseries r a) = a + getInfo = selectTimeseriesInfo + +instance HasInfo (PositionOrExpr r a) where + type Info (PositionOrExpr r a) = a + getInfo (PositionOrExprPosition info _ _) = info + getInfo (PositionOrExprExpr expr) = getInfo expr + +instance HasInfo (GroupingElement r a) where + type Info (GroupingElement r a) = a + getInfo (GroupingElementExpr info _) = info + getInfo (GroupingElementSet info _) = info + +instance HasInfo (SelectGroup r a) where + type Info (SelectGroup r a) = a + getInfo (SelectGroup info _) = info + +instance HasInfo (SelectHaving r a) where + type Info (SelectHaving r a) = a + getInfo (SelectHaving info _) = info + +instance HasInfo (SelectNamedWindow r a) where + type Info (SelectNamedWindow r a) = a + getInfo (SelectNamedWindow info _) = info + + +instance HasInfo (FrameType a) where + type Info (FrameType a) = a + getInfo (RowFrame info) = info + getInfo (RangeFrame info) = info + + +instance HasInfo (FrameBound a) where + type Info (FrameBound a) = a + getInfo (Unbounded info) = info + getInfo (CurrentRow info) = info + getInfo (Preceding info _) = info + getInfo (Following info _) = info + + +instance HasInfo (Frame a) where + type Info (Frame a) = a + getInfo (Frame info _ _ _) = info + + +instance HasInfo (Constant a) where + type Info (Constant a) = a + getInfo (StringConstant info _) = info + getInfo (NumericConstant info _) = info + getInfo (NullConstant info) = info + getInfo (BooleanConstant info _) = info + getInfo (TypedConstant info _ _) = info + getInfo (ParameterConstant info) = info + + +instance HasInfo (JoinCondition r a) where + type Info (JoinCondition r a) = a + getInfo (JoinNatural info _) = info + getInfo (JoinOn expr) = getInfo expr + getInfo (JoinUsing info _) = info + +instance HasInfo (JoinType a) where + type Info (JoinType a) = a + getInfo (JoinInner info) = info + getInfo (JoinLeft info) = info + getInfo (JoinRight info) = info + getInfo (JoinFull info) = info + getInfo (JoinSemi info) = info + +instance HasInfo (Tablish r a) where + type Info (Tablish r a) = a + getInfo (TablishTable info _ _) = info + getInfo (TablishSubQuery info _ _) = info + getInfo (TablishJoin info _ _ _ _) = info + getInfo (TablishLateralView info _ _) = info + + +instance HasInfo (Selection r a) where + type Info (Selection r a) = a + getInfo (SelectStar info _ _) = info + getInfo (SelectExpr info _ _) = info + + +instance HasInfo (OrderDirection a) where + type Info (OrderDirection a) = a + getInfo (OrderAsc info) = info + getInfo (OrderDesc info) = info + +instance HasInfo (NullPosition a) where + type Info (NullPosition a) = a + getInfo (NullsFirst info) = info + getInfo (NullsLast info) = info + getInfo (NullsAuto info) = info + +instance HasInfo (Offset a) where + type Info (Offset a) = a + getInfo (Offset info _) = info + +instance HasInfo (Limit a) where + type Info (Limit a) = a + getInfo (Limit info _) = info + +instance HasInfo (Escape r a) where + type Info (Escape r a) = a + getInfo = getInfo . escapeExpr + +instance HasInfo (Pattern r a) where + type Info (Pattern r a) = a + getInfo = getInfo . patternExpr diff --git a/src/Database/Sql/Position.hs b/src/Database/Sql/Position.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Position.hs @@ -0,0 +1,109 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Database.Sql.Position where + +import Data.Int (Int64) + +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL + +import Data.Aeson + +import Data.Semigroup (Semigroup (..)) + +import Data.Data (Data) +import GHC.Generics (Generic) + +data Position = Position + { positionLine :: Int64 + , positionColumn :: Int64 + , positionOffset :: Int64 + } deriving (Generic, Data, Show, Eq, Ord) + +data Range = Range + { start :: Position + , end :: Position + } deriving (Generic, Data, Show, Eq, Ord) + +instance Semigroup Range where + Range s e <> Range s' e' = Range (min s s') (max e e') + +infixr 6 ?<> +(?<>) :: Semigroup a => a -> Maybe a -> a +r ?<> Nothing = r +r ?<> (Just r') = r <> r' + +advanceHorizontal :: Int64 -> Position -> Position +advanceHorizontal n p = p + { positionColumn = positionColumn p + n + , positionOffset = positionOffset p + n + } + +advanceVertical :: Int64 -> Position -> Position +advanceVertical n p = p + { positionLine = positionLine p + n + , positionColumn = if n > 0 then 0 else positionColumn p + , positionOffset = positionOffset p + n + } + +advance :: Text -> Position -> Position +advance t p = + let newlines = TL.count "\n" t + in p + { positionLine = positionLine p + newlines + , positionColumn = if newlines == 0 + then positionColumn p + TL.length t + else TL.length $ snd $ TL.breakOnEnd "\n" t + + , positionOffset = positionOffset p + TL.length t + } + +instance ToJSON Position where + toJSON Position {..} = object + [ "line" .= positionLine + , "column" .= positionColumn + , "offset" .= positionOffset + ] + +instance ToJSON Range where + toJSON Range {..} = object + [ "start" .= start + , "end" .= end + ] + +instance FromJSON Position where + parseJSON (Object o) = do + positionLine <- o .: "line" + positionColumn <- o .: "column" + positionOffset <- o .: "offset" + return Position{..} + + parseJSON v = fail $ "don't know how to parse as Position: " ++ show v + +instance FromJSON Range where + parseJSON (Object o) = do + start <- o .: "start" + end <- o .: "end" + return Range{..} + + parseJSON v = fail $ "don't know how to parse as Range: " ++ show v diff --git a/src/Database/Sql/Pretty.hs b/src/Database/Sql/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Pretty.hs @@ -0,0 +1,60 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +module Database.Sql.Pretty where + +import Database.Sql.Type + +import qualified Data.Text.Lazy as TL + +import Text.PrettyPrint + + +renderPretty :: Pretty a => a -> String +renderPretty = render . pretty + +class Pretty a where + pretty :: a -> Doc + + +dot :: Doc +dot = text "." + +instance Pretty (DatabaseName a) where + pretty (DatabaseName _ name) = text $ TL.unpack name + +instance Foldable f => Pretty (QSchemaName f a) where + pretty (QSchemaName _ _ _ SessionSchema) = empty + pretty (QSchemaName _ database name NormalSchema) = + let d = foldMap pretty database + addDatabase = if isEmpty d then id else ((d <> dot) <>) + in addDatabase $ text $ TL.unpack name + +instance Foldable f => Pretty (QTableName f a) where + pretty (QTableName _ schema name) = + let s = foldMap pretty schema + addSchema = if isEmpty s then id else ((s <> dot) <>) + in addSchema $ text $ TL.unpack name + +instance Foldable f => Pretty (QColumnName f a) where + pretty (QColumnName _ table name) = + let t = foldMap pretty table + addTable = if isEmpty t then id else ((t <> dot) <>) + in addTable $ text $ TL.unpack name diff --git a/src/Database/Sql/Type.hs b/src/Database/Sql/Type.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Type.hs @@ -0,0 +1,1125 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Sql.Type + ( module Database.Sql.Type + , module Database.Sql.Type.Names + , module Database.Sql.Type.TableProps + , module Database.Sql.Type.Schema + , module Database.Sql.Type.Scope + , module Database.Sql.Type.Query + , module Database.Sql.Type.Unused + ) where + +import Database.Sql.Type.Names +import Database.Sql.Type.Schema +import Database.Sql.Type.Query +import Database.Sql.Type.TableProps +import Database.Sql.Type.Scope +import Database.Sql.Type.Unused + +import Control.Applicative ((<|>)) + +import Data.Aeson (ToJSON (..), FromJSON (..), (.:), (.:?), (.=)) +import qualified Data.Aeson as JSON + +import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty, toList) +import qualified Data.List.NonEmpty as NE +import qualified Data.Text.Lazy.Encoding as TL +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BL + +import Data.Proxy (Proxy (..)) + +import Data.Data (Data) +import GHC.Generics (Generic) +import GHC.Exts (Constraint) + +import Test.QuickCheck + + +type ConstrainSDialectParts (c :: * -> Constraint) d r a = (c a, c (DialectCreateTableExtra d r a), c (DialectColumnDefinitionExtra d a)) +type ConstrainSASDialectParts (c :: (* -> *) -> Constraint) d r = (c (DialectCreateTableExtra d r), c (DialectColumnDefinitionExtra d)) + +type ConstrainSAll (c :: * -> Constraint) d r a = (ConstrainSNames c r a, ConstrainSDialectParts c d r a) +type ConstrainSASAll (c :: (* -> *) -> Constraint) d r = (ConstrainSASNames c r, ConstrainSASDialectParts c d r) + +class Dialect d where + type DialectCreateTableExtra d r :: * -> * + type DialectCreateTableExtra d r = Unused + type DialectColumnDefinitionExtra d :: * -> * + type DialectColumnDefinitionExtra d = Unused + + shouldCTEsShadowTables :: Proxy d -> Bool + areLcolumnsVisibleInLateralViews :: Proxy d -> Bool + getSelectScope :: forall a . Proxy d -> FromColumns a -> SelectionAliases a -> SelectScope a + resolveCreateTableExtra :: Proxy d -> DialectCreateTableExtra d RawNames a -> Resolver (DialectCreateTableExtra d ResolvedNames) a + + +data Unparsed a = Unparsed a deriving (Show, Eq) + +data Statement + d -- sql dialect + r -- resolution level (raw or resolved) + a -- per-node parameters - typically Range or () + = QueryStmt (Query r a) + | InsertStmt (Insert r a) + | UpdateStmt (Update r a) + | DeleteStmt (Delete r a) + | TruncateStmt (Truncate r a) + | CreateTableStmt (CreateTable d r a) + | AlterTableStmt (AlterTable r a) + | DropTableStmt (DropTable r a) + | CreateViewStmt (CreateView r a) + | DropViewStmt (DropView r a) + | CreateSchemaStmt (CreateSchema r a) + | GrantStmt (Grant a) + | RevokeStmt (Revoke a) + | BeginStmt a + | CommitStmt a + | RollbackStmt a + | ExplainStmt a (Statement d r a) + | EmptyStmt a + +deriving instance (ConstrainSAll Data d r a, Data d, Data r) => Data (Statement d r a) +deriving instance Generic (Statement d r a) +deriving instance ConstrainSAll Eq d r a => Eq (Statement d r a) +deriving instance ConstrainSAll Show d r a => Show (Statement d r a) +deriving instance ConstrainSASAll Functor d r => Functor (Statement d r) +deriving instance ConstrainSASAll Foldable d r => Foldable (Statement d r) +deriving instance ConstrainSASAll Traversable d r => Traversable (Statement d r) + +data Insert r a = Insert + { insertInfo :: a + , insertBehavior :: InsertBehavior a + , insertTable :: TableName r a + , insertColumns :: Maybe (NonEmpty (ColumnRef r a)) + , insertValues :: InsertValues r a + } + +deriving instance (ConstrainSNames Data r a, Data r) => Data (Insert r a) +deriving instance Generic (Insert r a) +deriving instance ConstrainSNames Eq r a => Eq (Insert r a) +deriving instance ConstrainSNames Show r a => Show (Insert r a) +deriving instance ConstrainSASNames Functor r => Functor (Insert r) +deriving instance ConstrainSASNames Foldable r => Foldable (Insert r) +deriving instance ConstrainSASNames Traversable r => Traversable (Insert r) + +-- Placeholder for partition type until we figure out +-- how to implement placeholders +type TablePartition = () + +data InsertBehavior a + = InsertOverwrite a + | InsertAppend a + | InsertOverwritePartition a TablePartition + | InsertAppendPartition a TablePartition + deriving (Generic, Data, Eq, Show, Functor, Foldable, Traversable) + +data InsertValues r a + = InsertExprValues a (NonEmpty (NonEmpty (DefaultExpr r a))) + | InsertSelectValues (Query r a) + | InsertDefaultValues a + | InsertDataFromFile a ByteString + +deriving instance (ConstrainSNames Data r a, Data r) => Data (InsertValues r a) +deriving instance Generic (InsertValues r a) +deriving instance ConstrainSNames Eq r a => Eq (InsertValues r a) +deriving instance ConstrainSNames Show r a => Show (InsertValues r a) +deriving instance ConstrainSASNames Functor r => Functor (InsertValues r) +deriving instance ConstrainSASNames Foldable r => Foldable (InsertValues r) +deriving instance ConstrainSASNames Traversable r => Traversable (InsertValues r) + + +data DefaultExpr r a + = DefaultValue a + | ExprValue (Expr r a) + +deriving instance (ConstrainSNames Data r a, Data r) => Data (DefaultExpr r a) +deriving instance Generic (DefaultExpr r a) +deriving instance ConstrainSNames Eq r a => Eq (DefaultExpr r a) +deriving instance ConstrainSNames Show r a => Show (DefaultExpr r a) +deriving instance ConstrainSASNames Functor r => Functor (DefaultExpr r) +deriving instance ConstrainSASNames Foldable r => Foldable (DefaultExpr r) +deriving instance ConstrainSASNames Traversable r => Traversable (DefaultExpr r) + + +data Update r a = Update + { updateInfo :: a + , updateTable :: TableName r a + , updateAlias :: Maybe (TableAlias a) + , updateSetExprs :: NonEmpty (ColumnRef r a, DefaultExpr r a) + , updateFrom :: Maybe (Tablish r a) + , updateWhere :: Maybe (Expr r a) + } + +deriving instance (ConstrainSNames Data r a, Data r) => Data (Update r a) +deriving instance Generic (Update r a) +deriving instance ConstrainSNames Eq r a => Eq (Update r a) +deriving instance ConstrainSNames Show r a => Show (Update r a) +deriving instance ConstrainSASNames Functor r => Functor (Update r) +deriving instance ConstrainSASNames Foldable r => Foldable (Update r) +deriving instance ConstrainSASNames Traversable r => Traversable (Update r) + +data Delete r a + = Delete a (TableName r a) (Maybe (Expr r a)) + +deriving instance (ConstrainSNames Data r a, Data r) => Data (Delete r a) +deriving instance Generic (Delete r a) +deriving instance ConstrainSNames Eq r a => Eq (Delete r a) +deriving instance ConstrainSNames Show r a => Show (Delete r a) +deriving instance ConstrainSASNames Functor r => Functor (Delete r) +deriving instance ConstrainSASNames Foldable r => Foldable (Delete r) +deriving instance ConstrainSASNames Traversable r => Traversable (Delete r) + +data Truncate r a + = Truncate a (TableName r a) + +deriving instance (ConstrainSNames Data r a, Data r) => Data (Truncate r a) +deriving instance Generic (Truncate r a) +deriving instance ConstrainSNames Eq r a => Eq (Truncate r a) +deriving instance ConstrainSNames Show r a => Show (Truncate r a) +deriving instance ConstrainSASNames Functor r => Functor (Truncate r) +deriving instance ConstrainSASNames Foldable r => Foldable (Truncate r) +deriving instance ConstrainSASNames Traversable r => Traversable (Truncate r) + + +data CreateTable d r a = CreateTable + { createTableInfo :: a + , createTablePersistence :: Persistence a + , createTableExternality :: Externality a + , createTableIfNotExists :: Maybe a + , createTableName :: CreateTableName r a + , createTableDefinition :: TableDefinition d r a + , createTableExtra :: Maybe (DialectCreateTableExtra d r a) + } + +deriving instance (ConstrainSAll Data d r a, Data d, Data r) => Data (CreateTable d r a) +deriving instance Generic (CreateTable d r a) +deriving instance ConstrainSAll Eq d r a => Eq (CreateTable d r a) +deriving instance ConstrainSAll Show d r a => Show (CreateTable d r a) +deriving instance ConstrainSASAll Functor d r => Functor (CreateTable d r) +deriving instance ConstrainSASAll Foldable d r => Foldable (CreateTable d r) +deriving instance ConstrainSASAll Traversable d r => Traversable (CreateTable d r) + + +data AlterTable r a + = AlterTableRenameTable a (TableName r a) (TableName r a) + | AlterTableRenameColumn a (TableName r a) (UQColumnName a) (UQColumnName a) + | AlterTableAddColumns a (TableName r a) (NonEmpty (UQColumnName a)) + +deriving instance (ConstrainSNames Data r a, Data r) => Data (AlterTable r a) +deriving instance Generic (AlterTable r a) +deriving instance ConstrainSNames Eq r a => Eq (AlterTable r a) +deriving instance ConstrainSNames Show r a => Show (AlterTable r a) +deriving instance ConstrainSASNames Functor r => Functor (AlterTable r) +deriving instance ConstrainSASNames Foldable r => Foldable (AlterTable r) +deriving instance ConstrainSASNames Traversable r => Traversable (AlterTable r) + +data DropTable r a = DropTable + { dropTableInfo :: a + , dropTableIfExists :: Maybe a + , dropTableNames :: NonEmpty (DropTableName r a) + } + +deriving instance (ConstrainSNames Data r a, Data r) => Data (DropTable r a) +deriving instance Generic (DropTable r a) +deriving instance ConstrainSNames Eq r a => Eq (DropTable r a) +deriving instance ConstrainSNames Show r a => Show (DropTable r a) +deriving instance ConstrainSASNames Functor r => Functor (DropTable r) +deriving instance ConstrainSASNames Foldable r => Foldable (DropTable r) +deriving instance ConstrainSASNames Traversable r => Traversable (DropTable r) + +data CreateView r a = CreateView + { createViewInfo :: a + , createViewPersistence :: Persistence a + , createViewIfNotExists :: Maybe a + , createViewColumns :: Maybe (NonEmpty (UQColumnName a)) + , createViewName :: CreateTableName r a + , createViewQuery :: Query r a + } + +deriving instance (ConstrainSNames Data r a, Data r) => Data (CreateView r a) +deriving instance Generic (CreateView r a) +deriving instance ConstrainSNames Eq r a => Eq (CreateView r a) +deriving instance ConstrainSNames Show r a => Show (CreateView r a) +deriving instance ConstrainSASNames Functor r => Functor (CreateView r) +deriving instance ConstrainSASNames Foldable r => Foldable (CreateView r) +deriving instance ConstrainSASNames Traversable r => Traversable (CreateView r) + +data DropView r a = DropView + { dropViewInfo :: a + , dropViewIfExists :: Maybe a + , dropViewName :: DropTableName r a + } + +deriving instance (ConstrainSNames Data r a, Data r) => Data (DropView r a) +deriving instance Generic (DropView r a) +deriving instance ConstrainSNames Eq r a => Eq (DropView r a) +deriving instance ConstrainSNames Show r a => Show (DropView r a) +deriving instance ConstrainSASNames Functor r => Functor (DropView r) +deriving instance ConstrainSASNames Foldable r => Foldable (DropView r) +deriving instance ConstrainSASNames Traversable r => Traversable (DropView r) + +data CreateSchema r a = CreateSchema + { createSchemaInfo :: a + , createSchemaIfNotExists :: Maybe a + , createSchemaName :: CreateSchemaName r a + } + +deriving instance (ConstrainSNames Data r a, Data r) => Data (CreateSchema r a) +deriving instance Generic (CreateSchema r a) +deriving instance ConstrainSNames Eq r a => Eq (CreateSchema r a) +deriving instance ConstrainSNames Show r a => Show (CreateSchema r a) +deriving instance ConstrainSASNames Functor r => Functor (CreateSchema r) +deriving instance ConstrainSASNames Foldable r => Foldable (CreateSchema r) +deriving instance ConstrainSASNames Traversable r => Traversable (CreateSchema r) + +data Grant a = Grant a + deriving (Generic, Data, Eq, Show, Functor, Foldable, Traversable) + +data Revoke a = Revoke a + deriving (Generic, Data, Eq, Show, Functor, Foldable, Traversable) + +data TableDefinition d r a + = TableColumns a (NonEmpty (ColumnOrConstraint d r a)) + | TableLike a (TableName r a) + | TableAs a (Maybe (NonEmpty (UQColumnName a))) (Query r a) -- TODO what do I do with "AT ..." elsewhere? + | TableNoColumnInfo a -- Hive permits CREATE TABLEs with custom serializers, + -- e.g. "CREATE EXTERNAL TABLE foo LOCATION 'hdfs://';" + -- and "CREATE TABLE foo ROW FORMAT SERDE 'AvroSerDe' TBLPROPERTIES ('avro.schema.url'='hdfs://');" + +deriving instance (ConstrainSAll Data d r a, Data d, Data r) => Data (TableDefinition d r a) +deriving instance Generic (TableDefinition d r a) +deriving instance ConstrainSAll Eq d r a => Eq (TableDefinition d r a) +deriving instance ConstrainSAll Show d r a => Show (TableDefinition d r a) +deriving instance ConstrainSASAll Functor d r => Functor (TableDefinition d r) +deriving instance ConstrainSASAll Foldable d r => Foldable (TableDefinition d r) +deriving instance ConstrainSASAll Traversable d r => Traversable (TableDefinition d r) + + +-- | ColumnOrConstraint +-- Column definition or *table level* constraint +-- Column-level constraints are carried with the column + +data ColumnOrConstraint d r a + = ColumnOrConstraintColumn (ColumnDefinition d r a) + | ColumnOrConstraintConstraint (ConstraintDefinition a) + +deriving instance (ConstrainSAll Data d r a, Data d, Data r) => Data (ColumnOrConstraint d r a) +deriving instance Generic (ColumnOrConstraint d r a) +deriving instance ConstrainSAll Eq d r a => Eq (ColumnOrConstraint d r a) +deriving instance ConstrainSAll Show d r a => Show (ColumnOrConstraint d r a) +deriving instance ConstrainSASAll Functor d r => Functor (ColumnOrConstraint d r) +deriving instance ConstrainSASAll Foldable d r => Foldable (ColumnOrConstraint d r) +deriving instance ConstrainSASAll Traversable d r => Traversable (ColumnOrConstraint d r) + + +data ColumnDefinition d r a = ColumnDefinition + { columnDefinitionInfo :: a + , columnDefinitionName :: UQColumnName a + , columnDefinitionType :: DataType a + , columnDefinitionNull :: Maybe (NullConstraint a) + , columnDefinitionDefault :: Maybe (Expr r a) + , columnDefinitionExtra :: Maybe (DialectColumnDefinitionExtra d a) + } + +deriving instance (ConstrainSAll Data d r a, Data d, Data r) => Data (ColumnDefinition d r a) +deriving instance Generic (ColumnDefinition d r a) +deriving instance ConstrainSAll Eq d r a => Eq (ColumnDefinition d r a) +deriving instance ConstrainSAll Show d r a => Show (ColumnDefinition d r a) +deriving instance ConstrainSASAll Functor d r => Functor (ColumnDefinition d r) +deriving instance ConstrainSASAll Foldable d r => Foldable (ColumnDefinition d r) +deriving instance ConstrainSASAll Traversable d r => Traversable (ColumnDefinition d r) + +data NullConstraint a + = Nullable a + | NotNull a + deriving (Generic, Data, Eq, Show, Functor, Foldable, Traversable) + +data ConstraintDefinition a = ConstraintDefinition + { constraintDefinitionInfo :: a + } deriving (Generic, Data, Eq, Show, Functor, Foldable, Traversable) + + +instance ConstrainSAll ToJSON d r a => ToJSON (Statement d r a) where + toJSON (QueryStmt query) = JSON.object + [ "tag" .= JSON.String "QueryStmt" + , "query" .= query + ] + + toJSON (InsertStmt insert) = JSON.object + [ "tag" .= JSON.String "InsertStmt" + , "insert" .= insert + ] + + toJSON (UpdateStmt update) = JSON.object + [ "tag" .= JSON.String "UpdateStmt" + , "update" .= update + ] + + toJSON (DeleteStmt delete) = JSON.object + [ "tag" .= JSON.String "DeleteStmt" + , "delete" .= delete + ] + + toJSON (TruncateStmt truncate') = JSON.object + [ "tag" .= JSON.String "TruncateStmt" + , "truncate" .= truncate' + ] + + toJSON (CreateTableStmt create) = JSON.object + [ "tag" .= JSON.String "CreateTableStmt" + , "create" .= create + ] + + toJSON (AlterTableStmt alter) = JSON.object + [ "tag" .= JSON.String "AlterTableStmt" + , "alter" .= alter + ] + + toJSON (DropTableStmt drop') = JSON.object + [ "tag" .= JSON.String "DropTableStmt" + , "drop" .= drop' + ] + + toJSON (CreateViewStmt create) = JSON.object + [ "tag" .= JSON.String "CreateViewStmt" + , "create" .= create + ] + + toJSON (DropViewStmt drop') = JSON.object + [ "tag" .= JSON.String "DropViewStmt" + , "drop" .= drop' + ] + + toJSON (CreateSchemaStmt create) = JSON.object + [ "tag" .= JSON.String "CreateSchemaStmt" + , "create" .= create + ] + + toJSON (GrantStmt grant) = JSON.object + [ "tag" .= JSON.String "GrantStmt" + , "grant" .= grant + ] + + toJSON (RevokeStmt revoke) = JSON.object + [ "tag" .= JSON.String "RevokeStmt" + , "revoke" .= revoke + ] + + toJSON (BeginStmt begin) = JSON.object + [ "tag" .= JSON.String "BeginStmt" + , "begin" .= begin + ] + + toJSON (CommitStmt info) = JSON.object + [ "tag" .= JSON.String "CommitStmt" + , "info" .= info + ] + + toJSON (RollbackStmt info) = JSON.object + [ "tag" .= JSON.String "RollbackStmt" + , "info" .= info + ] + + toJSON (ExplainStmt info stmt) = JSON.object + [ "tag" .= JSON.String "ExplainStmt" + , "info" .= info + , "stmt" .= stmt + ] + + toJSON (EmptyStmt info) = JSON.object + [ "tag" .= JSON.String "EmptyStmt" + , "info" .= info + ] + +instance ConstrainSAll ToJSON d r a => ToJSON (CreateTable d r a) where + toJSON CreateTable{..} = JSON.object + [ "tag" .= JSON.String "CreateTable" + , "info" .= createTableInfo + , "persistence" .= createTablePersistence + , "ifnotexists" .= case createTableIfNotExists of + Just info -> JSON.object ["info" .= info, "value" .= True] + Nothing -> JSON.Null + + , "table" .= createTableName + , "definition" .= createTableDefinition + , "extra" .= createTableExtra + ] + +instance ( ToJSON a + , ToJSON (TableName r a) + ) => ToJSON (AlterTable r a) where + toJSON (AlterTableRenameTable info from to) = JSON.object + [ "tag" .= JSON.String "AlterTableRenameTable" + , "info" .= info + , "from" .= from + , "to" .= to + ] + toJSON (AlterTableRenameColumn info table from to) = JSON.object + [ "tag" .= JSON.String "AlterTableRenameColumn" + , "info" .= info + , "table" .= table + , "from" .= from + , "to" .= to + ] + toJSON (AlterTableAddColumns info table (c:|cs)) = JSON.object + [ "tag" .= JSON.String "AlterTableAddColumns" + , "info" .= info + , "table" .= table + , "columns" .= (c:cs) + ] + +instance (ToJSON a, ToJSON (DropTableName r a)) => ToJSON (DropTable r a) where + toJSON DropTable{..} = JSON.object + [ "tag" .= JSON.String "DropTable" + , "info" .= dropTableInfo + , "ifexists" .= case dropTableIfExists of + Just info -> JSON.object ["info" .= info, "value" .= True] + Nothing -> JSON.Null + + , "tables" .= NE.toList dropTableNames + ] + +instance ConstrainSNames ToJSON r a => ToJSON (CreateView r a) where + toJSON CreateView{..} = JSON.object + [ "tag" .= JSON.String "CreateView" + , "info" .= createViewInfo + , "persistence" .= createViewPersistence + , "ifnotexists" .= case createViewIfNotExists of + Just info -> JSON.object ["info" .= info, "value" .= True] + Nothing -> JSON.Null + + , "columns" .= case createViewColumns of + Just (c:|cs) -> toJSON (c:cs) + Nothing -> JSON.Null + + , "table" .= createViewName + , "query" .= createViewQuery + ] + +instance ConstrainSNames ToJSON r a => ToJSON (DropView r a) where + toJSON DropView{..} = JSON.object + [ "tag" .= JSON.String "DropView" + , "info" .= dropViewInfo + , "ifexists" .= case dropViewIfExists of + Just info -> JSON.object ["info" .= info, "value" .= True] + Nothing -> JSON.Null + + , "table" .= dropViewName + ] + + +instance (ToJSON a, ToJSON (CreateSchemaName r a)) => ToJSON (CreateSchema r a) where + toJSON (CreateSchema {..}) = JSON.object + [ "tag" .= JSON.String "CreateSchema" + , "info" .= createSchemaInfo + , "ifnotexists" .= case createSchemaIfNotExists of + Just info -> JSON.object ["info" .= info, "value" .= True] + Nothing -> JSON.Null + + , "schema" .= createSchemaName + ] + +instance ToJSON a => ToJSON (Grant a) where + toJSON (Grant a) = JSON.object + [ "tag" .= JSON.String "Grant" + , "info" .= a + ] + +instance ToJSON a => ToJSON (Revoke a) where + toJSON (Revoke a) = JSON.object + [ "tag" .= JSON.String "Revoke" + , "info" .= a + ] + +instance ConstrainSAll ToJSON d r a => ToJSON (TableDefinition d r a) where + toJSON (TableColumns info (c:|cs)) = JSON.object + [ "tag" .= JSON.String "TableColumns" + , "info" .= info + , "columns" .= (c:cs) + ] + + toJSON (TableLike info table) = JSON.object + [ "tag" .= JSON.String "TableLike" + , "info" .= info + , "table" .= table + ] + + toJSON (TableAs info columns query) = JSON.object + [ "tag" .= JSON.String "TableAs" + , "info" .= info + , "columns" .= case columns of + Just (c:|cs) -> toJSON (c:cs) + Nothing -> JSON.Null + , "query" .= query + ] + + toJSON (TableNoColumnInfo info) = JSON.object + [ "tag" .= JSON.String "TableNoColumnInfo" + , "info" .= info + ] + +instance ConstrainSAll ToJSON d r a => ToJSON (ColumnOrConstraint d r a) where + toJSON (ColumnOrConstraintColumn column) = toJSON column + toJSON (ColumnOrConstraintConstraint constraint) = toJSON constraint + +instance ConstrainSAll ToJSON d r a => ToJSON (ColumnDefinition d r a) where + toJSON (ColumnDefinition{..}) = JSON.object + [ "tag" .= JSON.String "ColumnDefinition" + , "info" .= columnDefinitionInfo + , "name" .= columnDefinitionName + , "type" .= columnDefinitionType + , "nullable" .= columnDefinitionNull + , "default" .= columnDefinitionDefault + , "extra" .= columnDefinitionExtra + ] + +instance ToJSON a => ToJSON (NullConstraint a) where + toJSON (Nullable info) = JSON.object + [ "tag" .= JSON.String "Nullable" + , "info" .= info + ] + + toJSON (NotNull info) = JSON.object + [ "tag" .= JSON.String "NotNull" + , "info" .= info + ] + +instance ToJSON a => ToJSON (ConstraintDefinition a) where + toJSON (ConstraintDefinition{..}) = JSON.object + [ "tag" .= JSON.String "ConstraintDefinition" + , "info" .= constraintDefinitionInfo + ] + +instance ConstrainSNames ToJSON r a => ToJSON (Insert r a) where + toJSON Insert{..} = JSON.object + [ "tag" .= JSON.String "Insert" + , "info" .= insertInfo + , "table" .= insertTable + , "values" .= insertValues + , "behavior" .= insertBehavior + ] + +instance ToJSON a => ToJSON (InsertBehavior a) where + toJSON (InsertOverwrite info) = JSON.object + [ "tag" .= JSON.String "Overwrite" + , "info" .= info + ] + toJSON (InsertAppend info) = JSON.object + [ "tag" .= JSON.String "Append" + , "info" .= info + ] + toJSON (InsertOverwritePartition info partition) = JSON.object + [ "tag" .= JSON.String "OverwritePartition" + , "info" .= info + , "partition" .= partition + ] + toJSON (InsertAppendPartition info partition) = JSON.object + [ "tag" .= JSON.String "AppendPartition" + , "info" .= info + , "partition" .= partition + ] + +instance ConstrainSNames ToJSON r a => ToJSON (InsertValues r a) where + toJSON (InsertExprValues info values) = JSON.object + [ "tag" .= JSON.String "InsertExprValues" + , "info" .= info + , "values" .= (map toList $ toList values) + ] + + toJSON (InsertSelectValues query) = JSON.object + [ "tag" .= JSON.String "InsertSelectValues" + , "query" .= query + ] + + toJSON (InsertDefaultValues info) = JSON.object + [ "tag" .= JSON.String "InsertDefaultValues" + , "info" .= info + ] + + toJSON (InsertDataFromFile info path) = JSON.object + [ "tag" .= JSON.String "InsertDataFromFile" + , "info" .= info + , case TL.decodeUtf8' path of + Left _ -> "path" .= BL.unpack path + Right str -> "path" .= str + ] + +instance ConstrainSNames ToJSON r a => ToJSON (DefaultExpr r a) where + toJSON (DefaultValue info) = JSON.object + [ "tag" .= JSON.String "DefaultValue" + , "info" .= info + ] + + toJSON (ExprValue expr) = JSON.object + [ "tag" .= JSON.String "ExprValue" + , "expr" .= expr + ] + +instance ConstrainSNames ToJSON r a => ToJSON (Update r a) where + toJSON Update{..} = JSON.object + [ "tag" .= JSON.String "Update" + , "info" .= updateInfo + , "table" .= updateTable + , "alias" .= updateAlias + , "set_exprs" .= toList updateSetExprs + , "from" .= updateFrom + , "where" .= updateWhere + ] + +instance ConstrainSNames ToJSON r a => ToJSON (Delete r a) where + toJSON (Delete info table expr) = JSON.object + [ "tag" .= JSON.String "Delete" + , "info" .= info + , "table" .= table + , "expr" .= expr + ] + +instance ConstrainSNames ToJSON r a => ToJSON (Truncate r a) where + toJSON (Truncate info table) = JSON.object + [ "tag" .= JSON.String "Truncate" + , "info" .= info + , "table" .= table + ] + +instance ConstrainSAll FromJSON d r a => FromJSON (Statement d r a) where + parseJSON (JSON.Object o) = o .: "tag" >>= \case + JSON.String "QueryStmt" -> QueryStmt <$> o .: "query" + JSON.String "InsertStmt" -> InsertStmt <$> o .: "insert" + JSON.String "UpdateStmt" -> UpdateStmt <$> o .: "update" + JSON.String "DeleteStmt" -> DeleteStmt <$> o .: "delete" + JSON.String "TruncateStmt" -> TruncateStmt <$> o .: "truncate" + JSON.String "CreateTableStmt" -> CreateTableStmt <$> o .: "create" + JSON.String "AlterTableStmt" -> AlterTableStmt <$> o .: "alter" + JSON.String "DropTableStmt" -> DropTableStmt <$> o .: "drop" + JSON.String "CreateSchemaStmt" -> CreateSchemaStmt <$> o .: "create" + JSON.String "GrantStmt" -> GrantStmt <$> o .: "grant" + JSON.String "RevokeStmt" -> RevokeStmt <$> o .: "revoke" + JSON.String "BeginStmt" -> BeginStmt <$> o .: "begin" + JSON.String "CommitStmt" -> CommitStmt <$> o .: "info" + JSON.String "RollbackStmt" -> RollbackStmt <$> o .: "info" + JSON.String "ExplainStmt" -> ExplainStmt <$> o .: "info" <*> o .: "stmt" + JSON.String "EmptyStmt" -> EmptyStmt <$> o .: "info" + _ -> fail "unrecognized tag on statement object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as Statement:" + , show v + + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (Insert r a) where + parseJSON (JSON.Object o) = do + JSON.String "Insert" <- o .: "tag" + insertInfo <- o .: "info" + insertTable <- o .: "table" + columns <- o .:? "columns" + let insertColumns = nonEmpty =<< columns + insertValues <- o .: "values" + insertBehavior <- o .: "behavior" + pure Insert{..} + + parseJSON v = fail $ unwords + [ "don't know how to parse as Insert:" + , show v + ] + +instance ConstrainSNames FromJSON r a => FromJSON (Update r a) where + parseJSON (JSON.Object o) = do + JSON.String "Update" <- o .: "tag" + updateInfo <- o .: "info" + updateTable <- o .: "table" + updateAlias <- o .:? "alias" + updateSetExprs <- NE.fromList <$> o .: "set_exprs" + updateFrom <- o .:? "from" + updateWhere <- o .:? "where" + pure Update{..} + + parseJSON v = fail $ unwords + [ "don't know how to parse as Update:" + , show v + ] + +instance ConstrainSNames FromJSON r a => FromJSON (Delete r a) where + parseJSON (JSON.Object o) = do + JSON.String "Delete" <- o .: "tag" + info <- o .: "info" + table <- o .: "table" + expr <- o .: "expr" + pure $ Delete info table expr + + parseJSON v = fail $ unwords + [ "don't know how to parse as Delete:" + , show v + ] + +instance ConstrainSNames FromJSON r a => FromJSON (Truncate r a) where + parseJSON (JSON.Object o) = do + JSON.String "Truncate" <- o .: "tag" + info <- o .: "info" + table <- o .: "table" + pure $ Truncate info table + + parseJSON v = fail $ unwords + [ "don't know how to parse as Truncate:" + , show v + ] + +instance ConstrainSAll FromJSON d r a => FromJSON (CreateTable d r a) where + parseJSON (JSON.Object o) = do + JSON.String "CreateTable" <- o .: "tag" + createTableInfo <- o .: "info" + createTablePersistence <- o .: "persistence" + createTableExternality <- o .: "externality" + createTableIfNotExists <- o .:? "ifnotexists" >>= \case + Just o' -> do + JSON.Bool True <- o' .: "value" + o' .: "info" + Nothing -> pure Nothing + + createTableName <- o .: "table" + createTableDefinition <- o .: "definition" + createTableExtra <- o .: "extra" + pure CreateTable{..} + + parseJSON v = fail $ unwords + [ "don't know how to parse as CreateTable:" + , show v + ] + +instance ConstrainSNames FromJSON r a => FromJSON (AlterTable r a) where + parseJSON (JSON.Object o) = o .: "tag" >>= \case + JSON.String "AlterTableRenameTable" -> do + info <- o .: "info" + from <- o .: "from" + to <- o .: "to" + pure $ AlterTableRenameTable info from to + JSON.String "AlterTableRenameColumn" -> do + info <- o .: "info" + table <- o .: "table" + from <- o .: "from" + to <- o .: "to" + pure $ AlterTableRenameColumn info table from to + JSON.String "AlterTableAddColumns" -> do + info <- o .: "info" + table <- o .: "table" + columns <- o .: "columns" >>= \case + [] -> fail "expected at least one column in column list for AlterTableAddColumns" + (c:cs) -> pure (c:|cs) + pure $ AlterTableAddColumns info table columns + _ -> fail "unrecognized tag on AlterTable object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as AlterTable:" + , show v + ] + +instance ConstrainSNames FromJSON r a => FromJSON (DropTable r a) where + parseJSON (JSON.Object o) = do + JSON.String "DropTable" <- o .: "tag" + dropTableInfo <- o .: "info" + dropTableIfExists <- o .:? "ifexists" >>= \case + Just o' -> do + JSON.Bool True <- o' .: "value" + o' .: "info" + Nothing -> pure Nothing + + dropTableNames <- NE.fromList <$> o .: "tables" + pure $ DropTable{..} + + parseJSON v = fail $ unwords + [ "don't know how to parse as DropTable:" + , show v + ] + +instance ConstrainSNames FromJSON r a => FromJSON (CreateView r a) where + parseJSON (JSON.Object o) = do + JSON.String "CreateView" <- o .: "tag" + createViewInfo <- o .: "info" + createViewPersistence <- o .: "persistence" + createViewIfNotExists <- o .:? "ifnotexists" >>= \case + Just o' -> do + JSON.Bool True <- o' .: "value" + o' .: "info" + Nothing -> pure Nothing + + createViewColumns <- o .:? "columns" >>= \case + Just [] -> fail "expected at least one column in column list for CreateView (or no column list)" + Just (c:cs) -> pure $ Just (c:|cs) + Nothing -> pure Nothing + + createViewName <- o .: "table" + createViewQuery <- o .: "query" + pure $ CreateView{..} + + parseJSON v = fail $ unwords + [ "don't know how to parse as CreateView:" + , show v + ] + +instance ConstrainSNames FromJSON r a => FromJSON (DropView r a) where + parseJSON (JSON.Object o) = do + JSON.String "DropView" <- o .: "tag" + dropViewInfo <- o .: "info" + dropViewIfExists <- o .:? "ifexists" >>= \case + Just o' -> do + JSON.Bool True <- o' .: "value" + o' .: "info" + Nothing -> pure Nothing + + dropViewName <- o .: "table" + pure $ DropView{..} + + parseJSON v = fail $ unwords + [ "don't know how to parse as DropView:" + , show v + ] + +instance ConstrainSNames FromJSON r a => FromJSON (CreateSchema r a) where + + parseJSON (JSON.Object o) = do + JSON.String "CreateSchema" <- o .: "tag" + createSchemaInfo <- o .: "info" + createSchemaIfNotExists <- o .:? "ifnotexists" >>= \case + Just o' -> do + JSON.Bool True <- o' .: "value" + o' .: "info" + Nothing -> pure Nothing + + createSchemaName <- o .: "schema" + pure $ CreateSchema{..} + + parseJSON v = fail $ unwords + [ "don't know how to parse as CreateSchema:" + , show v + ] + +instance FromJSON a => FromJSON (Grant a) where + + parseJSON (JSON.Object o) = do + JSON.String "Grant" <- o .: "tag" + info <- o .: "info" + pure $ Grant info + + parseJSON v = fail $ unwords + [ "don't know how to parse as Grant:" + , show v + ] + +instance FromJSON a => FromJSON (Revoke a) where + + parseJSON (JSON.Object o) = do + JSON.String "Revoke" <- o .: "tag" + info <- o .: "info" + pure $ Revoke info + + parseJSON v = fail $ unwords + [ "don't know how to parse as Revoke:" + , show v + ] + +instance FromJSON a => FromJSON (InsertBehavior a) where + + parseJSON (JSON.Object o) = o .: "tag" >>= \case + JSON.String "Append" -> do + info <- o .: "info" + pure $ InsertAppend info + + JSON.String "Overwrite" -> do + info <- o .: "info" + pure $ InsertOverwrite info + + JSON.String "AppendPartition" -> do + info <- o .: "info" + partition <- o .: "partition" + pure $ InsertAppendPartition info partition + + JSON.String "OverwritePartition" -> do + info <- o .: "info" + partition <- o .: "partition" + pure $ InsertOverwritePartition info partition + + _ -> fail "unrecognized tag on InsertBehavior object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as InsertBehavior:" + , show v + ] + +instance ConstrainSAll FromJSON d r a => FromJSON (TableDefinition d r a) where + + parseJSON (JSON.Object o) = o .: "tag" >>= \case + JSON.String "TableColumns" -> do + info <- o .: "info" + o .: "columns" >>= \case + [] -> fail "expected at least one column in TableColumns object" + (c:cs) -> pure $ TableColumns info (c:|cs) + + JSON.String "TableLike" -> do + info <- o .: "info" + table <- o .: "table" + pure $ TableLike info table + + JSON.String "TableAs" -> do + info <- o .: "info" + columns <- o .: "columns" >>= \case + Just [] -> fail "expected at least one column in column list for TableAs (or no column list)" + Just (c:cs) -> pure $ Just (c:|cs) + Nothing -> pure Nothing + query <- o .: "query" + pure $ TableAs info columns query + + JSON.String "TableNoColumnInfo" -> do + info <- o .: "info" + pure $ TableNoColumnInfo info + + _ -> fail "unrecognized tag on table definition object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as TableDefinition:" + , show v + ] + + +instance ConstrainSAll FromJSON d r a => FromJSON (ColumnOrConstraint d r a) where + + parseJSON (JSON.Object o) = o .: "tag" >>= \case + JSON.String "ColumnDefinition" -> ColumnOrConstraintColumn <$> parseJSON (JSON.Object o) + JSON.String "ConstraintDefinition" -> ColumnOrConstraintConstraint <$> parseJSON (JSON.Object o) + _ -> fail "unrecognized tag on column or constraint object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as ColumnOrConstraint:" + , show v + ] + +instance ConstrainSAll FromJSON d r a => FromJSON (ColumnDefinition d r a) where + + parseJSON (JSON.Object o) = do + JSON.String "ColumnDefinition" <- o .: "tag" + columnDefinitionInfo <- o .: "info" + columnDefinitionName <- o .: "name" + columnDefinitionType <- o .: "type" + columnDefinitionNull <- o .: "nullable" + columnDefinitionDefault <- o .: "default" + columnDefinitionExtra <- o .: "extra" + pure ColumnDefinition{..} + + parseJSON v = fail $ unwords + [ "don't know how to parse as ColumnDefinition:" + , show v + ] + +instance FromJSON a => FromJSON (NullConstraint a) where + parseJSON (JSON.Object o) = do + info <- o .: "info" + o .: "tag" >>= \case + JSON.String "Nullable" -> pure $ Nullable info + JSON.String "NotNull" -> pure $ NotNull info + _ -> fail "unrecognized tag on null constraint object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as NullConstraint:" + , show v + ] + +instance FromJSON a => FromJSON (ConstraintDefinition a) where + + parseJSON (JSON.Object o) = do + JSON.String "ConstraintDefinition" <- o .: "tag" + constraintDefinitionInfo <- o .: "info" + pure ConstraintDefinition{..} + + parseJSON v = fail $ unwords + [ "don't know how to parse as ConstraintDefinition:" + , show v + ] + +instance ConstrainSNames FromJSON r a => FromJSON (InsertValues r a) where + parseJSON (JSON.Object o) = o .: "tag" >>= \case + JSON.String "InsertExprValues" -> do + info <- o .: "info" + values <- o .: "values" + let fromList xs = if null xs + then fail "empty list of values for row in insert statement" + else NE.fromList xs + rows = map fromList values + maybe (fail "empty list of rows for insert statement") + (pure . InsertExprValues info) $ nonEmpty rows + + JSON.String "InsertSelectValues" -> InsertSelectValues <$> o .: "query" + JSON.String "InsertDefaultValues" -> InsertDefaultValues <$> o .: "info" + JSON.String "InsertDataFromFile" -> do + info <- o .: "info" + path <- TL.encodeUtf8 <$> o .: "path" + <|> BL.pack <$> o .: "path" + <|> fail "expected string or array for path" + pure $ InsertDataFromFile info path + + _ -> fail "unrecognized tag on insert values object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as InsertValues:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (DefaultExpr r a) where + parseJSON (JSON.Object o) = o .: "tag" >>= \case + JSON.String "DefaultValue" -> DefaultValue <$> o .: "info" + JSON.String "ExprValue" -> ExprValue <$> o .: "expr" + _ -> fail "unrecognized tag on default expression object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as DefaultExpr:" + , show v + ] + + +instance Arbitrary a => Arbitrary (InsertBehavior a) where + arbitrary = do + info <- arbitrary + elements [ InsertOverwrite info + , InsertAppend info + , InsertOverwritePartition info () + , InsertAppendPartition info () + ] + shrink (InsertAppend _) = [] + shrink (InsertOverwrite x) = [InsertAppend x] + shrink (InsertAppendPartition x _) = [InsertAppend x] + shrink (InsertOverwritePartition x t) = + [ InsertAppend x + , InsertOverwrite x + , InsertAppendPartition x t + ] diff --git a/src/Database/Sql/Type/Names.hs b/src/Database/Sql/Type/Names.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Type/Names.hs @@ -0,0 +1,650 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveGeneric #-} + +module Database.Sql.Type.Names where + +import Data.Hashable +import Data.Text.Lazy (Text, pack) +import Data.Aeson +import Data.Semigroup +import Data.String +import Data.Functor.Identity +import Data.Functor.Identity.Orphans () +import Data.Data (Data, Typeable) + +import qualified Data.Map as M +import Data.Map (Map) + +import GHC.Exts (Constraint) +import GHC.Generics +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Data.Proxy + +import Control.Applicative (Alternative (..)) +import Control.Monad (void) + +import Test.QuickCheck + + +type ConstrainSNames (c :: * -> Constraint) r a = + ( c a + , c (TableRef r a) + , c (TableName r a) + , c (CreateTableName r a) + , c (DropTableName r a) + , c (SchemaName r a) + , c (CreateSchemaName r a) + , c (ColumnRef r a) + , c (NaturalColumns r a) + , c (UsingColumn r a) + , c (StarReferents r a) + , c (PositionExpr r a) + , c (ComposedQueryColumns r a) + ) + +type ConstrainSASNames (c :: (* -> *) -> Constraint) r = + ( c (TableRef r) + , c (TableName r) + , c (CreateTableName r) + , c (DropTableName r) + , c (SchemaName r) + , c (CreateSchemaName r) + , c (ColumnRef r) + , c (NaturalColumns r) + , c (UsingColumn r) + , c (StarReferents r) + , c (PositionExpr r) + , c (ComposedQueryColumns r) + ) + + +class Resolution r where + -- | TableRef refers to either a table in the catalog, or an alias + type TableRef r :: * -> * + + -- | TableName refers to a table in the catalog + type TableName r :: * -> * + + -- | CreateTableName refers to a table that might be in the catalog + -- + -- Used for CREATE TABLE, special rules for resolution + type CreateTableName r :: * -> * + + -- | DropTableName refers to a table that might be in the catalog + -- + -- Used for DROP TABLE, special rules for resolution + type DropTableName r :: * -> * + + -- | SchemaName refers to a schema in the catalog + type SchemaName r :: * -> * + + -- | CreateSchemaName refers to a table that might be in the catalog + -- + -- Used for CREATE SCHEMA, special rules for resolution + type CreateSchemaName r :: * -> * + + -- | ColumnRef refers to either a column in the catalog, or an alias + type ColumnRef r :: * -> * + + -- | NaturalColumns refers to columns compared in a natural join + type NaturalColumns r :: * -> * + + -- | UsingColumn refers to columns that appear in USING (...) + type UsingColumn r :: * -> * + + type StarReferents r :: * -> * + + type PositionExpr r :: * -> * + + type ComposedQueryColumns r :: * -> * + + +type FQCN = FullyQualifiedColumnName +data FullyQualifiedColumnName = FullyQualifiedColumnName + { fqcnDatabaseName :: Text + , fqcnSchemaName :: Text + , fqcnTableName :: Text + , fqcnColumnName :: Text + } deriving (Data, Generic, Ord, Eq, Show) + +type FQTN = FullyQualifiedTableName +data FullyQualifiedTableName = FullyQualifiedTableName + { fqtnDatabaseName :: Text + , fqtnSchemaName :: Text + , fqtnTableName :: Text + } deriving (Data, Generic, Eq, Ord, Show) + +qualifyColumnName :: FQTableName a -> UQColumnName b -> FQColumnName () +qualifyColumnName fqtn uqcn = uqcn{columnNameInfo = (), columnNameTable = pure $ void fqtn} + +fqcnToFQCN :: FQColumnName a -> FullyQualifiedColumnName +fqcnToFQCN (QColumnName _ (Identity (QTableName _ (Identity (QSchemaName _ (Identity (DatabaseName _ database)) schema _)) table)) column) = + FullyQualifiedColumnName database schema table column + +fqtnToFQTN :: FQTableName a -> FullyQualifiedTableName +fqtnToFQTN (QTableName _ (Identity (QSchemaName _ (Identity (DatabaseName _ database)) schema _)) table) = + FullyQualifiedTableName database schema table + +data DatabaseName a = DatabaseName a Text + deriving (Data, Generic, Read, Show, Eq, Ord, Functor, Foldable, Traversable) + +data SchemaType = NormalSchema | SessionSchema + deriving (Data, Generic, Read, Show, Eq, Ord) + +data QSchemaName f a = QSchemaName + { schemaNameInfo :: a + , schemaNameDatabase :: f (DatabaseName a) + , schemaNameName :: Text -- for a SessionSchema, this is the session id + , schemaNameType :: SchemaType + } deriving (Generic, Functor, Foldable, Traversable) + +deriving instance (Data (f (DatabaseName a)), Data a, Typeable f, Typeable a) => Data (QSchemaName f a) +deriving instance (Eq a, Eq (f (DatabaseName a))) => Eq (QSchemaName f a) +deriving instance (Ord a, Ord (f (DatabaseName a))) => Ord (QSchemaName f a) +deriving instance (Read a, Read (f (DatabaseName a))) => Read (QSchemaName f a) +deriving instance (Show a, Show (f (DatabaseName a))) => Show (QSchemaName f a) + +type UQSchemaName = QSchemaName No +type OQSchemaName = QSchemaName Maybe +type FQSchemaName = QSchemaName Identity + +mkNormalSchema :: Alternative f => Text -> a -> QSchemaName f a +mkNormalSchema name info = QSchemaName info empty name NormalSchema + +instance Hashable (DatabaseName a) where + hashWithSalt salt (DatabaseName _ database) = salt `hashWithSalt` database + +instance Arbitrary a => Arbitrary (DatabaseName a) where + arbitrary = do + Identifier name :: Identifier '["fooDatabase", "barDatabase"] <- arbitrary + DatabaseName <$> arbitrary <*> pure name + shrink (DatabaseName info name) = + [DatabaseName info name' | Identifier name' <- shrink (Identifier name :: Identifier '["fooDatabase", "barDatabase"])] + +instance Hashable SchemaType + +instance Hashable (f (DatabaseName a)) => Hashable (QSchemaName f a) where + hashWithSalt salt (QSchemaName _ database schema schemaType) = salt `hashWithSalt` database `hashWithSalt` schema `hashWithSalt` schemaType + +instance (Arbitrary (f (DatabaseName a)), Arbitrary a) => Arbitrary (QSchemaName f a) where + arbitrary = oneof + [ do + Identifier name :: Identifier '["public", "fooSchema"] <- arbitrary + QSchemaName <$> arbitrary <*> arbitrary <*> pure name <*> pure NormalSchema + , do + Identifier name :: Identifier '["session-asdf", "session-hjkl"] <- arbitrary + QSchemaName <$> arbitrary <*> arbitrary <*> pure name <*> pure SessionSchema + ] + shrink (QSchemaName info database name _) = + [QSchemaName info database' name' NormalSchema | (database', Identifier name') <- shrink (database, Identifier name :: Identifier '["public", "fooSchema"])] + + +arbitraryUnquotedIdentifier :: Gen Text +arbitraryUnquotedIdentifier = do + -- in Vertica: character a-zA-Z_, then a-zA-Z_ or $ or "unicode letter" + c <- elements openingChars + tailLength <- growingElements [1..31] -- identifiers are up to 128 bytes: limit to 32 chars + cs <- vectorOf tailLength $ elements subsequentChars + pure $ pack $ c:cs + where + openingChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['_'] + subsequentChars = openingChars ++ ['$', 'ñ', 'á'] + +arbitraryQuotedIdentifier :: Gen Text +arbitraryQuotedIdentifier = do + -- in Vertica: anything as long as it's enclosed by double-quotes; + -- double-quotes may appear in the string. When rendering, the escape for a + -- " is a " again, e.g. "enclosed""doublequotes" has a single " in it. + length' <- growingElements [1..32] + pack <$> vectorOf length' arbitrary + +arbitraryIdentifier :: Gen Text +arbitraryIdentifier = frequency + [(3, arbitraryUnquotedIdentifier), + (1, arbitraryQuotedIdentifier)] + + +-- | Identifiers picked first from (and shrunk to) symbols in type list. Used for testing. +data Identifier (ids :: [Symbol]) = Identifier Text deriving Eq + +class KnownSymbols (xs :: [Symbol]) where + symbolVals :: proxy xs -> [String] + +instance KnownSymbols '[] where + symbolVals _ = [] + +instance (KnownSymbol x, KnownSymbols xs) => KnownSymbols (x ': xs) where + symbolVals _ = symbolVal (Proxy :: Proxy x) : symbolVals (Proxy :: Proxy xs) + +instance KnownSymbols ids => Arbitrary (Identifier ids) where + arbitrary = do + arb <- Identifier <$> arbitraryIdentifier + growingElements $ ids ++ [arb] + where + ids = Identifier . pack <$> symbolVals (Proxy :: Proxy ids) + + shrink i = takeWhile (/= i) ids + where + ids = Identifier . pack <$> symbolVals (Proxy :: Proxy ids) + +data QTableName f a = QTableName + { tableNameInfo :: a + , tableNameSchema :: f (QSchemaName f a) + , tableNameName :: Text + } deriving (Generic, Functor, Foldable, Traversable) + +deriving instance (Data a, Data (f (QSchemaName f a)), Typeable f, Typeable a) => Data (QTableName f a) +deriving instance (Eq a, Eq (f (QSchemaName f a))) => Eq (QTableName f a) +deriving instance (Ord a, Ord (f (QSchemaName f a))) => Ord (QTableName f a) +deriving instance (Read a, Read (f (QSchemaName f a))) => Read (QTableName f a) +deriving instance (Show a, Show (f (QSchemaName f a))) => Show (QTableName f a) + +data No a = None deriving (Data, Generic, Eq, Show, Read, Ord, Functor, Foldable, Traversable) + +instance Applicative No where + pure = const None + None <*> None = None + +instance Arbitrary (No a) where + arbitrary = pure None + +instance Hashable (No a) where + hashWithSalt salt _ = hashWithSalt salt () + +instance ToJSON (No a) where + toJSON _ = Null + +instance FromJSON (No a) where + parseJSON _ = pure None + +instance Alternative No where + empty = None + None <|> None = None + +type UQTableName = QTableName No +type OQTableName = QTableName Maybe +type FQTableName = QTableName Identity + +newtype TableAliasId + = TableAliasId Integer + deriving (Data, Generic, Read, Show, Eq, Ord) + +data TableAlias a + = TableAlias a Text TableAliasId + deriving ( Data, Generic + , Read, Show, Eq, Ord + , Functor, Foldable, Traversable) + +tableAliasName :: TableAlias a -> UQTableName a +tableAliasName (TableAlias info name _) = QTableName info None name + + +data RNaturalColumns a = RNaturalColumns [RUsingColumn a] + deriving ( Data, Generic + , Read, Show, Eq, Ord + , Functor, Foldable, Traversable) + +data RUsingColumn a = RUsingColumn (RColumnRef a) (RColumnRef a) + deriving ( Data, Generic + , Read, Show, Eq, Ord + , Functor, Foldable, Traversable) + +instance Hashable (f (QSchemaName f a)) => Hashable (QTableName f a) where + hashWithSalt salt (QTableName _ schema table) = salt `hashWithSalt` schema `hashWithSalt` table + + +instance (Arbitrary (f (QSchemaName f a)), Arbitrary a) => Arbitrary (QTableName f a) where + arbitrary = do + Identifier name :: Identifier '["fooTable", "barTable"] <- arbitrary + QTableName <$> arbitrary <*> arbitrary <*> pure name + shrink (QTableName info schema name) = + [QTableName info schema' name' | (schema', Identifier name') <- shrink (schema, Identifier name :: Identifier '["fooTable", "barTable"])] + +data QFunctionName f a = QFunctionName + { functionNameInfo :: a + , functionNameSchema :: f (QSchemaName f a) + , functionNameName :: Text + } deriving (Generic, Functor, Foldable, Traversable) + +deriving instance (Data a, Data (f (QSchemaName f a)), Typeable f, Typeable a) => Data (QFunctionName f a) +deriving instance (Eq a, Eq (f (QSchemaName f a))) => Eq (QFunctionName f a) +deriving instance (Ord a, Ord (f (QSchemaName f a))) => Ord (QFunctionName f a) +deriving instance (Read a, Read (f (QSchemaName f a))) => Read (QFunctionName f a) +deriving instance (Show a, Show (f (QSchemaName f a))) => Show (QFunctionName f a) + +type FunctionName = QFunctionName Maybe + + +instance ( Arbitrary (f (QSchemaName f a)) + , Arbitrary a + , Eq (f SchemaType) + , Applicative f + ) => Arbitrary (QFunctionName f a) where + arbitrary = do + Identifier name :: Identifier '["fooFunc", "barFunc"] <- arbitrary + QFunctionName <$> arbitrary <*> arbitraryNormalSchema <*> pure name + where + isSessionSchema :: f (QSchemaName f a) -> Bool + isSessionSchema schema = fmap schemaNameType schema == pure SessionSchema + arbitraryNormalSchema = arbitrary `suchThat` (not . isSessionSchema) + shrink (QFunctionName info schema name) = + [QFunctionName info schema' name' | (schema', Identifier name') <- shrink (schema, Identifier name :: Identifier '["fooName", "barName"])] + +data QColumnName f a = QColumnName + { columnNameInfo :: a + , columnNameTable :: f (QTableName f a) + , columnNameName :: Text + } deriving (Generic, Functor, Foldable, Traversable) + +deriving instance (Data (f (QTableName f a)), Data a, Typeable f, Typeable a) => Data (QColumnName f a) +deriving instance (Eq (f (QTableName f a)), Eq a) => Eq (QColumnName f a) +deriving instance (Ord (f (QTableName f a)), Ord a) => Ord (QColumnName f a) +deriving instance (Read (f (QTableName f a)), Read a) => Read (QColumnName f a) +deriving instance (Show (f (QTableName f a)), Show a) => Show (QColumnName f a) + + +type UQColumnName = QColumnName No +type OQColumnName = QColumnName Maybe +type FQColumnName = QColumnName Identity + +instance IsString (UQColumnName ()) where + fromString s = QColumnName{..} + where + columnNameTable = None + columnNameName = fromString s + columnNameInfo = () + +newtype ColumnAliasId + = ColumnAliasId Integer + deriving (Data, Generic, Read, Show, Eq, Ord) + +instance (Arbitrary (f (QTableName f a)), Arbitrary a) => Arbitrary (QColumnName f a) where + arbitrary = do + Identifier name :: Identifier '["fooColumn", "barColumn"] <- arbitrary + QColumnName <$> arbitrary <*> arbitrary <*> pure name + shrink (QColumnName info table name) = + [QColumnName info table' name' | (table', Identifier name') <- shrink (table, Identifier name :: Identifier '["fooColumn", "barColumn"])] + +data ColumnAlias a + = ColumnAlias a Text ColumnAliasId + deriving ( Data, Generic + , Read, Show, Eq, Ord + , Functor, Foldable, Traversable) + +columnAliasName :: ColumnAlias a -> UQColumnName a +columnAliasName (ColumnAlias info name _) = QColumnName info None name + +data RColumnRef a + = RColumnRef (FQColumnName a) + | RColumnAlias (ColumnAlias a) + deriving ( Data, Generic + , Read, Show, Eq, Ord + , Functor, Foldable, Traversable) + + +data StructFieldName a = StructFieldName a Text + deriving (Data, Generic, Eq, Ord, Show, Functor, Foldable, Traversable) + +newtype FieldChain = FieldChain (Map (StructFieldName ()) FieldChain) + deriving (Eq, Ord, Show) + +instance Semigroup FieldChain where + FieldChain m <> FieldChain n + | M.null m || M.null n = FieldChain M.empty + | otherwise = FieldChain $ M.unionWith (<>) m n + + +data ParamName a + = ParamName a Text + deriving (Data, Generic, Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance Arbitrary a => Arbitrary (ParamName a) where + arbitrary = ParamName <$> arbitrary <*> arbitraryUnquotedIdentifier + shrink (ParamName info name) = [ ParamName info name' | Identifier name' <- shrink (Identifier name :: Identifier '["my_param_name"]) ] + + +instance ToJSON a => ToJSON (DatabaseName a) where + toJSON (DatabaseName info database) = object + [ "tag" .= String "DatabaseName" + , "info" .= info + , "database" .= database + ] + +instance ToJSON SchemaType + +instance (ToJSON (f (DatabaseName a)), ToJSON a) => ToJSON (QSchemaName f a) where + toJSON (QSchemaName info database schema schemaType) = object + [ "tag" .= String "QSchemaName" + , "info" .= info + , "database" .= database + , "schema" .= schema + , "schemaType" .= schemaType + ] + + +instance (ToJSON (f (QSchemaName f a)), ToJSON a) => ToJSON (QTableName f a) where + toJSON (QTableName info schema table) = object + [ "tag" .= String "QTableName" + , "info" .= info + , "schema" .= schema + , "table" .= table + ] + +instance ToJSON a => ToJSON (TableAlias a) where + toJSON (TableAlias info name (TableAliasId ident)) = object + [ "tag" .= String "TableAlias" + , "info" .= info + , "name" .= name + , "ident" .= ident + ] + +instance ToJSON a => ToJSON (RNaturalColumns a) where + toJSON (RNaturalColumns cols) = object + [ "tag" .= String "RNaturalColumns" + , "cols" .= cols + ] + +instance ToJSON a => ToJSON (RUsingColumn a) where + toJSON (RUsingColumn left right) = object + [ "tag" .= String "RUsingColumn" + , "left" .= left + , "right" .= right + ] + +instance (ToJSON (f (QSchemaName f a)), ToJSON a) => ToJSON (QFunctionName f a) where + toJSON (QFunctionName info schema function) = object + [ "tag" .= String "QFunctionName" + , "info" .= info + , "schema" .= schema + , "function" .= function + ] + + + +instance (ToJSON (f (QTableName f a)), ToJSON a) => ToJSON (QColumnName f a) where + toJSON (QColumnName info table column) = object + [ "tag" .= String "QColumnName" + , "info" .= info + , "table" .= table + , "column" .= column + ] + + +instance ToJSON a => ToJSON (RColumnRef a) where + toJSON (RColumnRef column) = object + [ "tag" .= String "RColumnRef" + , "column" .= column + ] + + toJSON (RColumnAlias alias) = object + [ "tag" .= String "RColumnAlias" + , "alias" .= alias + ] + +instance ToJSON a => ToJSON (ColumnAlias a) where + toJSON (ColumnAlias info name (ColumnAliasId ident)) = object + [ "tag" .= String "ColumnAlias" + , "info" .= info + , "name" .= name + , "ident" .= ident + ] + + +instance ToJSON a => ToJSON (StructFieldName a) where + toJSON (StructFieldName info name) = object + [ "tag" .= String "StructFieldName" + , "info" .= info + , "name" .= name + ] + + +instance ToJSON a => ToJSON (ParamName a) where + toJSON (ParamName info param) = object + [ "tag" .= String "ParamName" + , "info" .= info + , "param" .= param + ] + + +instance FromJSON a => FromJSON (DatabaseName a) where + parseJSON (Object o) = do + String "DatabaseName" <- o .: "tag" + DatabaseName <$> o .: "info" <*> o .: "database" + + parseJSON v = fail $ unwords + [ "don't know how to parse as DatabaseName:" + , show v + ] + +instance FromJSON SchemaType + +instance (FromJSON (f (DatabaseName a)), FromJSON a) => FromJSON (QSchemaName f a) where + parseJSON (Object o) = do + String "QSchemaName" <- o .: "tag" + QSchemaName <$> o .: "info" <*> o .: "database" <*> o .: "schema" <*> o .: "schemaType" + + parseJSON v = fail $ unwords + [ "don't know how to parse as QSchemaName:" + , show v + ] + +instance (FromJSON (f (QSchemaName f a)), FromJSON a) => FromJSON (QTableName f a) where + parseJSON (Object o) = do + String "QTableName" <- o .: "tag" + QTableName <$> o .: "info" <*> o .: "schema" <*> o .: "table" + + parseJSON v = fail $ unwords + [ "don't know how to parse as QTableName:" + , show v + ] + +instance FromJSON a => FromJSON (TableAlias a) where + parseJSON (Object o) = do + String "TableAlias" <- o .: "tag" + TableAlias <$> o .: "info" <*> o .: "name" <*> (TableAliasId <$> o .: "ident") + + parseJSON v = fail $ unwords + [ "don't know how to parse as TableAlias:" + , show v + ] + + +instance (FromJSON (f (QSchemaName f a)), FromJSON a) => FromJSON (QFunctionName f a) where + parseJSON (Object o) = do + String "QFunctionName" <- o .: "tag" + QFunctionName <$> o .: "info" <*> o .: "schema" <*> o .: "function" + + parseJSON v = fail $ unwords + [ "don't know how to parse as QFunctionName:" + , show v + ] + + +instance (FromJSON (f (QTableName f a)), FromJSON a) => FromJSON (QColumnName f a) where + parseJSON (Object o) = do + String "QColumnName" <- o .: "tag" + QColumnName <$> o .: "info" <*> o .: "table" <*> o .: "column" + + parseJSON v = fail $ unwords + [ "don't know how to parse as QColumnName:" + , show v + ] + + +instance FromJSON a => FromJSON (RColumnRef a) where + parseJSON (Object o) = do + o .: "tag" >>= \case + String "RColumnRef" -> RColumnRef <$> o .: "table" + String "RColumnAlias" -> RColumnAlias <$> o .: "alias" + String tag -> fail $ "unrecognized tag for RColumnRef object: " ++ show tag + _ -> fail $ "unexpected value type for tag on RColumnRef object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as RColumnRef:" + , show v + ] + +instance FromJSON a => FromJSON (ColumnAlias a) where + parseJSON (Object o) = do + String "ColumnAlias" <- o .: "tag" + ColumnAlias <$> o .: "info" <*> o .: "name" <*> (ColumnAliasId <$> o .: "ident") + + parseJSON v = fail $ unwords + [ "don't know how to parse as ColumnAlias:" + , show v + ] + +instance FromJSON a => FromJSON (StructFieldName a) where + parseJSON (Object o) = do + String "StructFieldName" <- o .: "tag" + StructFieldName + <$> o .: "info" + <*> o .: "name" + + parseJSON v = fail $ unwords + [ "don't know how to parse as StructFieldName:" + , show v + ] + + +instance FromJSON a => FromJSON (ParamName a) where + parseJSON (Object o) = do + String "ParamName" <- o .: "tag" + ParamName <$> o .: "info" <*> o .: "param" + + parseJSON v = fail $ unwords + [ "don't know how to parse as ParamName:" + , show v + ] diff --git a/src/Database/Sql/Type/Query.hs b/src/Database/Sql/Type/Query.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Type/Query.hs @@ -0,0 +1,2334 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Sql.Type.Query where + +import Database.Sql.Type.Names + +import Control.Applicative ((<|>)) + +import qualified Data.Char as Char +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BL + +import Data.Aeson +import Data.Foldable (toList) +import Data.String (IsString (..)) + +import Data.Data (Data) +import GHC.Generics (Generic) + +import Test.QuickCheck + + +data Query r a + = QuerySelect a (Select r a) + | QueryExcept a (ComposedQueryColumns r a) (Query r a) (Query r a) + | QueryUnion a Distinct (ComposedQueryColumns r a) (Query r a) (Query r a) + | QueryIntersect a (ComposedQueryColumns r a) (Query r a) (Query r a) + | QueryWith a [CTE r a] (Query r a) + | QueryOrder a [Order r a] (Query r a) + | QueryLimit a (Limit a) (Query r a) + | QueryOffset a (Offset a) (Query r a) + +deriving instance (ConstrainSNames Data r a, Data r) => Data (Query r a) +deriving instance Generic (Query r a) +deriving instance ConstrainSNames Eq r a => Eq (Query r a) +deriving instance ConstrainSNames Ord r a => Ord (Query r a) +deriving instance ConstrainSNames Show r a => Show (Query r a) +deriving instance ConstrainSASNames Functor r => Functor (Query r) +deriving instance ConstrainSASNames Foldable r => Foldable (Query r) +deriving instance ConstrainSASNames Traversable r => Traversable (Query r) + +newtype Distinct = Distinct Bool + deriving (Data, Generic, Eq, Ord, Show) + +notDistinct :: Distinct +notDistinct = Distinct False + +data CTE r a = CTE + { cteInfo :: a + , cteAlias :: TableAlias a + , cteColumns :: [ColumnAlias a] + , cteQuery :: Query r a + } + +deriving instance (ConstrainSNames Data r a, Data r) => Data (CTE r a) +deriving instance Generic (CTE r a) +deriving instance ConstrainSNames Eq r a => Eq (CTE r a) +deriving instance ConstrainSNames Ord r a => Ord (CTE r a) +deriving instance ConstrainSNames Show r a => Show (CTE r a) +deriving instance ConstrainSASNames Functor r => Functor (CTE r) +deriving instance ConstrainSASNames Foldable r => Foldable (CTE r) +deriving instance ConstrainSASNames Traversable r => Traversable (CTE r) + + +data Select r a = Select + { selectInfo :: a + , selectCols :: SelectColumns r a + , selectFrom :: Maybe (SelectFrom r a) + , selectWhere :: Maybe (SelectWhere r a) + , selectTimeseries :: Maybe (SelectTimeseries r a) + , selectGroup :: Maybe (SelectGroup r a) + , selectHaving :: Maybe (SelectHaving r a) + , selectNamedWindow :: Maybe (SelectNamedWindow r a) + , selectDistinct :: Distinct + } + +deriving instance (ConstrainSNames Data r a, Data r) => Data (Select r a) +deriving instance Generic (Select r a) +deriving instance ConstrainSNames Eq r a => Eq (Select r a) +deriving instance ConstrainSNames Ord r a => Ord (Select r a) +deriving instance ConstrainSNames Show r a => Show (Select r a) +deriving instance ConstrainSASNames Functor r => Functor (Select r) +deriving instance ConstrainSASNames Foldable r => Foldable (Select r) +deriving instance ConstrainSASNames Traversable r => Traversable (Select r) + + +data SelectColumns r a = SelectColumns + { selectColumnsInfo :: a + , selectColumnsList :: [Selection r a] + } + +deriving instance (ConstrainSNames Data r a, Data r) => Data (SelectColumns r a) +deriving instance Generic (SelectColumns r a) +deriving instance ConstrainSNames Eq r a => Eq (SelectColumns r a) +deriving instance ConstrainSNames Ord r a => Ord (SelectColumns r a) +deriving instance ConstrainSNames Show r a => Show (SelectColumns r a) +deriving instance ConstrainSASNames Functor r => Functor (SelectColumns r) +deriving instance ConstrainSASNames Foldable r => Foldable (SelectColumns r) +deriving instance ConstrainSASNames Traversable r => Traversable (SelectColumns r) + + +data SelectFrom r a + = SelectFrom a [Tablish r a] + +deriving instance (ConstrainSNames Data r a, Data r) => Data (SelectFrom r a) +deriving instance Generic (SelectFrom r a) +deriving instance ConstrainSNames Eq r a => Eq (SelectFrom r a) +deriving instance ConstrainSNames Ord r a => Ord (SelectFrom r a) +deriving instance ConstrainSNames Show r a => Show (SelectFrom r a) +deriving instance ConstrainSASNames Functor r => Functor (SelectFrom r) +deriving instance ConstrainSASNames Foldable r => Foldable (SelectFrom r) +deriving instance ConstrainSASNames Traversable r => Traversable (SelectFrom r) + + +data TablishAliases a + = TablishAliasesNone + | TablishAliasesT (TableAlias a) + | TablishAliasesTC (TableAlias a) [ColumnAlias a] + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + + +-- Tablish is a Table, Query, or join of 2 Tablishs +data Tablish r a + = TablishTable a (TablishAliases a) (TableRef r a) + | TablishSubQuery a (TablishAliases a) (Query r a) + | TablishJoin a (JoinType a) (JoinCondition r a) + (Tablish r a) (Tablish r a) + | TablishLateralView a (LateralView r a) (Maybe (Tablish r a)) + +deriving instance (ConstrainSNames Data r a, Data r) => Data (Tablish r a) +deriving instance Generic (Tablish r a) +deriving instance ConstrainSNames Eq r a => Eq (Tablish r a) +deriving instance ConstrainSNames Ord r a => Ord (Tablish r a) +deriving instance ConstrainSNames Show r a => Show (Tablish r a) +deriving instance ConstrainSASNames Functor r => Functor (Tablish r) +deriving instance ConstrainSASNames Foldable r => Foldable (Tablish r) +deriving instance ConstrainSASNames Traversable r => Traversable (Tablish r) + + +data JoinType a + = JoinInner a -- JoinInner also encompasses CROSS JOIN (see D508260) + | JoinLeft a + | JoinRight a + | JoinFull a + | JoinSemi a + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + + +data JoinCondition r a + = JoinNatural a (NaturalColumns r a) + | JoinOn (Expr r a) + | JoinUsing a [UsingColumn r a] + +deriving instance (ConstrainSNames Data r a, Data r) => Data (JoinCondition r a) +deriving instance Generic (JoinCondition r a) +deriving instance ConstrainSNames Eq r a => Eq (JoinCondition r a) +deriving instance ConstrainSNames Ord r a => Ord (JoinCondition r a) +deriving instance ConstrainSNames Show r a => Show (JoinCondition r a) +deriving instance ConstrainSASNames Functor r => Functor (JoinCondition r) +deriving instance ConstrainSASNames Foldable r => Foldable (JoinCondition r) +deriving instance ConstrainSASNames Traversable r => Traversable (JoinCondition r) + +data LateralView r a = LateralView + { lateralViewInfo :: a + , lateralViewOuter :: Maybe a + , lateralViewExprs :: [Expr r a] + , lateralViewWithOrdinality :: Bool + , lateralViewAliases :: TablishAliases a + } + +deriving instance (ConstrainSNames Data r a, Data r) => Data (LateralView r a) +deriving instance Generic (LateralView r a) +deriving instance ConstrainSNames Eq r a => Eq (LateralView r a) +deriving instance ConstrainSNames Ord r a => Ord (LateralView r a) +deriving instance ConstrainSNames Show r a => Show (LateralView r a) +deriving instance ConstrainSASNames Functor r => Functor (LateralView r) +deriving instance ConstrainSASNames Foldable r => Foldable (LateralView r) +deriving instance ConstrainSASNames Traversable r => Traversable (LateralView r) + + + +data SelectWhere r a + = SelectWhere a (Expr r a) + +deriving instance (ConstrainSNames Data r a, Data r) => Data (SelectWhere r a) +deriving instance Generic (SelectWhere r a) +deriving instance ConstrainSNames Eq r a => Eq (SelectWhere r a) +deriving instance ConstrainSNames Ord r a => Ord (SelectWhere r a) +deriving instance ConstrainSNames Show r a => Show (SelectWhere r a) +deriving instance ConstrainSASNames Functor r => Functor (SelectWhere r) +deriving instance ConstrainSASNames Foldable r => Foldable (SelectWhere r) +deriving instance ConstrainSASNames Traversable r => Traversable (SelectWhere r) + + +data SelectTimeseries r a = SelectTimeseries + { selectTimeseriesInfo :: a + , selectTimeseriesSliceName :: ColumnAlias a + , selectTimeseriesInterval :: Constant a + , selectTimeseriesPartition :: Maybe (Partition r a) + , selectTimeseriesOrder :: Expr r a + } + +deriving instance (ConstrainSNames Data r a, Data r) => Data (SelectTimeseries r a) +deriving instance Generic (SelectTimeseries r a) +deriving instance ConstrainSNames Eq r a => Eq (SelectTimeseries r a) +deriving instance ConstrainSNames Ord r a => Ord (SelectTimeseries r a) +deriving instance ConstrainSNames Show r a => Show (SelectTimeseries r a) +deriving instance ConstrainSASNames Functor r => Functor (SelectTimeseries r) +deriving instance ConstrainSASNames Foldable r => Foldable (SelectTimeseries r) +deriving instance ConstrainSASNames Traversable r => Traversable (SelectTimeseries r) + + +data PositionOrExpr r a + = PositionOrExprPosition a Int (PositionExpr r a) + | PositionOrExprExpr (Expr r a) + +deriving instance (ConstrainSNames Data r a, Data r) => Data (PositionOrExpr r a) +deriving instance Generic (PositionOrExpr r a) +deriving instance ConstrainSNames Eq r a => Eq (PositionOrExpr r a) +deriving instance ConstrainSNames Ord r a => Ord (PositionOrExpr r a) +deriving instance ConstrainSNames Show r a => Show (PositionOrExpr r a) +deriving instance ConstrainSASNames Functor r => Functor (PositionOrExpr r) +deriving instance ConstrainSASNames Foldable r => Foldable (PositionOrExpr r) +deriving instance ConstrainSASNames Traversable r => Traversable (PositionOrExpr r) + +data GroupingElement r a + = GroupingElementExpr a (PositionOrExpr r a) + | GroupingElementSet a [Expr r a] + +deriving instance (ConstrainSNames Data r a, Data r) => Data (GroupingElement r a) +deriving instance Generic (GroupingElement r a) +deriving instance ConstrainSNames Eq r a => Eq (GroupingElement r a) +deriving instance ConstrainSNames Ord r a => Ord (GroupingElement r a) +deriving instance ConstrainSNames Show r a => Show (GroupingElement r a) +deriving instance ConstrainSASNames Functor r => Functor (GroupingElement r) +deriving instance ConstrainSASNames Foldable r => Foldable (GroupingElement r) +deriving instance ConstrainSASNames Traversable r => Traversable (GroupingElement r) + + +data SelectGroup r a = SelectGroup + { selectGroupInfo :: a + , selectGroupGroupingElements :: [GroupingElement r a] + } + +deriving instance (ConstrainSNames Data r a, Data r) => Data (SelectGroup r a) +deriving instance Generic (SelectGroup r a) +deriving instance ConstrainSNames Eq r a => Eq (SelectGroup r a) +deriving instance ConstrainSNames Ord r a => Ord (SelectGroup r a) +deriving instance ConstrainSNames Show r a => Show (SelectGroup r a) +deriving instance ConstrainSASNames Functor r => Functor (SelectGroup r) +deriving instance ConstrainSASNames Foldable r => Foldable (SelectGroup r) +deriving instance ConstrainSASNames Traversable r => Traversable (SelectGroup r) + + +data SelectHaving r a + = SelectHaving a [Expr r a] + +deriving instance (ConstrainSNames Data r a, Data r) => Data (SelectHaving r a) +deriving instance Generic (SelectHaving r a) +deriving instance ConstrainSNames Eq r a => Eq (SelectHaving r a) +deriving instance ConstrainSNames Ord r a => Ord (SelectHaving r a) +deriving instance ConstrainSNames Show r a => Show (SelectHaving r a) +deriving instance ConstrainSASNames Functor r => Functor (SelectHaving r) +deriving instance ConstrainSASNames Foldable r => Foldable (SelectHaving r) +deriving instance ConstrainSASNames Traversable r => Traversable (SelectHaving r) + +data SelectNamedWindow r a + = SelectNamedWindow a [NamedWindowExpr r a ] + +deriving instance (ConstrainSNames Data r a, Data r) => Data (SelectNamedWindow r a) +deriving instance Generic (SelectNamedWindow r a) +deriving instance ConstrainSNames Eq r a => Eq (SelectNamedWindow r a) +deriving instance ConstrainSNames Ord r a => Ord (SelectNamedWindow r a) +deriving instance ConstrainSNames Show r a => Show (SelectNamedWindow r a) +deriving instance ConstrainSASNames Functor r => Functor (SelectNamedWindow r) +deriving instance ConstrainSASNames Foldable r => Foldable (SelectNamedWindow r) +deriving instance ConstrainSASNames Traversable r => Traversable (SelectNamedWindow r) + + +data Order r a + = Order a (PositionOrExpr r a) (OrderDirection (Maybe a)) (NullPosition (Maybe a)) + +deriving instance (ConstrainSNames Data r a, Data r) => Data (Order r a) +deriving instance Generic (Order r a) +deriving instance ConstrainSNames Eq r a => Eq (Order r a) +deriving instance ConstrainSNames Ord r a => Ord (Order r a) +deriving instance ConstrainSNames Show r a => Show (Order r a) +deriving instance ConstrainSASNames Functor r => Functor (Order r) +deriving instance ConstrainSASNames Foldable r => Foldable (Order r) +deriving instance ConstrainSASNames Traversable r => Traversable (Order r) + +data OrderDirection a + = OrderAsc a + | OrderDesc a + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + +data NullPosition a + = NullsFirst a + | NullsLast a + | NullsAuto a + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + + +data Offset a + = Offset a Text + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + +data Limit a + = Limit a Text + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + + +data Selection r a + = SelectStar a (Maybe (TableRef r a)) (StarReferents r a) + | SelectExpr a [ColumnAlias a] (Expr r a) + +deriving instance (ConstrainSNames Data r a, Data r) => Data (Selection r a) +deriving instance Generic (Selection r a) +deriving instance ConstrainSNames Eq r a => Eq (Selection r a) +deriving instance ConstrainSNames Ord r a => Ord (Selection r a) +deriving instance ConstrainSNames Show r a => Show (Selection r a) +deriving instance ConstrainSASNames Functor r => Functor (Selection r) +deriving instance ConstrainSASNames Foldable r => Foldable (Selection r) +deriving instance ConstrainSASNames Traversable r => Traversable (Selection r) + + +data Constant a + = StringConstant a ByteString + -- ^ nb: Encoding *probably* matches server encoding, but there are ways to cram arbitrary byte sequences into strings on both Hive and Vertica. + | NumericConstant a Text + | NullConstant a + | BooleanConstant a Bool + | TypedConstant a Text (DataType a) + | ParameterConstant a + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + +data DataTypeParam a + = DataTypeParamConstant (Constant a) + | DataTypeParamType (DataType a) + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + +data DataType a + = PrimitiveDataType a Text [DataTypeParam a] + | ArrayDataType a (DataType a) + | MapDataType a (DataType a) (DataType a) + | StructDataType a [(Text, DataType a)] + | UnionDataType a [DataType a] + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + + +data Operator a + = Operator Text + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + +instance IsString (Operator a) where + fromString = Operator . TL.pack + +data ArrayIndex a = ArrayIndex a Text + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + +data Expr r a + = BinOpExpr a (Operator a) (Expr r a) (Expr r a) + | CaseExpr a [(Expr r a, Expr r a)] (Maybe (Expr r a)) + | UnOpExpr a (Operator a) (Expr r a) + | LikeExpr a (Operator a) (Maybe (Escape r a)) (Pattern r a) (Expr r a) + | ConstantExpr a (Constant a) + | ColumnExpr a (ColumnRef r a) + | InListExpr a [Expr r a] (Expr r a) + | InSubqueryExpr a (Query r a) (Expr r a) + | BetweenExpr a (Expr r a) (Expr r a) (Expr r a) + | OverlapsExpr a (Expr r a, Expr r a) (Expr r a, Expr r a) + + | FunctionExpr a + (FunctionName a) + Distinct + [Expr r a] + [(ParamName a, Expr r a)] + (Maybe (Filter r a)) + (Maybe (OverSubExpr r a)) + + | AtTimeZoneExpr a (Expr r a) (Expr r a) + + | SubqueryExpr a (Query r a) + | ArrayExpr a [Expr r a] + | ExistsExpr a (Query r a) + | FieldAccessExpr a (Expr r a) (StructFieldName a) + | ArrayAccessExpr a (Expr r a) (Expr r a) + | TypeCastExpr a CastFailureAction (Expr r a) (DataType a) + | VariableSubstitutionExpr a + +deriving instance (ConstrainSNames Data r a, Data r) => Data (Expr r a) +deriving instance Generic (Expr r a) +deriving instance ConstrainSNames Eq r a => Eq (Expr r a) +deriving instance ConstrainSNames Ord r a => Ord (Expr r a) +deriving instance ConstrainSNames Show r a => Show (Expr r a) +deriving instance ConstrainSASNames Functor r => Functor (Expr r) +deriving instance ConstrainSASNames Foldable r => Foldable (Expr r) +deriving instance ConstrainSASNames Traversable r => Traversable (Expr r) + + +data CastFailureAction + = CastFailureToNull + | CastFailureError + deriving (Generic, Data, Eq, Ord, Show, ToJSON, FromJSON) + + +newtype Escape r a = Escape + { escapeExpr :: Expr r a + } + +deriving instance (ConstrainSNames Data r a, Data r) => Data (Escape r a) +deriving instance Generic (Escape r a) +deriving instance ConstrainSNames Eq r a => Eq (Escape r a) +deriving instance ConstrainSNames Ord r a => Ord (Escape r a) +deriving instance ConstrainSNames Show r a => Show (Escape r a) +deriving instance ConstrainSASNames Functor r => Functor (Escape r) +deriving instance ConstrainSASNames Foldable r => Foldable (Escape r) +deriving instance ConstrainSASNames Traversable r => Traversable (Escape r) + + +newtype Pattern r a = Pattern + { patternExpr :: Expr r a + } + +deriving instance (ConstrainSNames Data r a, Data r) => Data (Pattern r a) +deriving instance Generic (Pattern r a) +deriving instance ConstrainSNames Eq r a => Eq (Pattern r a) +deriving instance ConstrainSNames Ord r a => Ord (Pattern r a) +deriving instance ConstrainSNames Show r a => Show (Pattern r a) +deriving instance ConstrainSASNames Functor r => Functor (Pattern r) +deriving instance ConstrainSASNames Foldable r => Foldable (Pattern r) +deriving instance ConstrainSASNames Traversable r => Traversable (Pattern r) + +data Filter r a + = Filter + { filterInfo :: a + , filterExpr :: Expr r a + } + +deriving instance (ConstrainSNames Data r a, Data r) => Data (Filter r a) +deriving instance Generic (Filter r a) +deriving instance ConstrainSNames Eq r a => Eq (Filter r a) +deriving instance ConstrainSNames Ord r a => Ord (Filter r a) +deriving instance ConstrainSNames Show r a => Show (Filter r a) +deriving instance ConstrainSASNames Functor r => Functor (Filter r) +deriving instance ConstrainSASNames Foldable r => Foldable (Filter r) +deriving instance ConstrainSASNames Traversable r => Traversable (Filter r) + + +data Partition r a + = PartitionBy a [Expr r a] + | PartitionBest a + | PartitionNodes a + +deriving instance (ConstrainSNames Data r a, Data r) => Data (Partition r a) +deriving instance Generic (Partition r a) +deriving instance ConstrainSNames Eq r a => Eq (Partition r a) +deriving instance ConstrainSNames Ord r a => Ord (Partition r a) +deriving instance ConstrainSNames Show r a => Show (Partition r a) +deriving instance ConstrainSASNames Functor r => Functor (Partition r) +deriving instance ConstrainSASNames Foldable r => Foldable (Partition r) +deriving instance ConstrainSASNames Traversable r => Traversable (Partition r) + +data FrameType a + = RowFrame a + | RangeFrame a + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + +data FrameBound a + = Unbounded a + | CurrentRow a + | Preceding a (Constant a) + | Following a (Constant a) + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + +data Frame a = Frame + { frameInfo :: a + , frameType :: FrameType a + , frameStart :: FrameBound a + , frameEnd :: Maybe (FrameBound a) + } deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + +data OverSubExpr r a + = OverWindowExpr a (WindowExpr r a) + | OverWindowName a (WindowName a) + | OverPartialWindowExpr a (PartialWindowExpr r a) +deriving instance (ConstrainSNames Data r a, Data r) => Data (OverSubExpr r a) +deriving instance Generic (OverSubExpr r a) +deriving instance ConstrainSNames Eq r a => Eq (OverSubExpr r a) +deriving instance ConstrainSNames Ord r a => Ord (OverSubExpr r a) +deriving instance ConstrainSNames Show r a => Show (OverSubExpr r a) +deriving instance ConstrainSASNames Functor r => Functor (OverSubExpr r) +deriving instance ConstrainSASNames Foldable r => Foldable (OverSubExpr r) +deriving instance ConstrainSASNames Traversable r => Traversable (OverSubExpr r) + +data WindowExpr r a + = WindowExpr + { windowExprInfo :: a + , windowExprPartition :: Maybe (Partition r a) + , windowExprOrder :: [Order r a] + , windowExprFrame :: Maybe (Frame a) + } +deriving instance (ConstrainSNames Data r a, Data r) => Data (WindowExpr r a) +deriving instance Generic (WindowExpr r a) +deriving instance ConstrainSNames Eq r a => Eq (WindowExpr r a) +deriving instance ConstrainSNames Ord r a => Ord (WindowExpr r a) +deriving instance ConstrainSNames Show r a => Show (WindowExpr r a) +deriving instance ConstrainSASNames Functor r => Functor (WindowExpr r) +deriving instance ConstrainSASNames Foldable r => Foldable (WindowExpr r) +deriving instance ConstrainSASNames Traversable r => Traversable (WindowExpr r) + +data PartialWindowExpr r a + = PartialWindowExpr + { partWindowExprInfo :: a + , partWindowExprInherit :: WindowName a + , partWindowExprPartition :: Maybe (Partition r a) + , partWindowExprOrder :: [Order r a] + , partWindowExprFrame :: Maybe (Frame a) + } +deriving instance (ConstrainSNames Data r a, Data r) => Data (PartialWindowExpr r a) +deriving instance Generic (PartialWindowExpr r a) +deriving instance ConstrainSNames Eq r a => Eq (PartialWindowExpr r a) +deriving instance ConstrainSNames Ord r a => Ord (PartialWindowExpr r a) +deriving instance ConstrainSNames Show r a => Show (PartialWindowExpr r a) +deriving instance ConstrainSASNames Functor r => Functor (PartialWindowExpr r) +deriving instance ConstrainSASNames Foldable r => Foldable (PartialWindowExpr r) +deriving instance ConstrainSASNames Traversable r => Traversable (PartialWindowExpr r) + +data WindowName a = WindowName a Text + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + +data NamedWindowExpr r a + = NamedWindowExpr a (WindowName a) (WindowExpr r a) + | NamedPartialWindowExpr a (WindowName a) (PartialWindowExpr r a) +deriving instance (ConstrainSNames Data r a, Data r) => Data (NamedWindowExpr r a) +deriving instance Generic (NamedWindowExpr r a) +deriving instance ConstrainSNames Eq r a => Eq (NamedWindowExpr r a) +deriving instance ConstrainSNames Ord r a => Ord (NamedWindowExpr r a) +deriving instance ConstrainSNames Show r a => Show (NamedWindowExpr r a) +deriving instance ConstrainSASNames Functor r => Functor (NamedWindowExpr r) +deriving instance ConstrainSASNames Foldable r => Foldable (NamedWindowExpr r) +deriving instance ConstrainSASNames Traversable r => Traversable (NamedWindowExpr r) + +-- ToJSON + +instance ConstrainSNames ToJSON r a => ToJSON (Query r a) where + toJSON (QuerySelect info select) = object + [ "tag" .= String "QuerySelect" + , "info" .= info + , "select" .= select + ] + + toJSON (QueryExcept info columns lhs rhs) = object + [ "tag" .= String "Except" + , "info" .= info + , "columns" .= columns + , "lhs" .= lhs + , "rhs" .= rhs + ] + + toJSON (QueryUnion info distinct columns lhs rhs) = object + [ "tag" .= String "Union" + , "info" .= info + , "distinct" .= distinct + , "columns" .= columns + , "lhs" .= lhs + , "rhs" .= rhs + ] + + toJSON (QueryIntersect info columns lhs rhs) = object + [ "tag" .= String "Intersect" + , "info" .= info + , "columns" .= columns + , "lhs" .= lhs + , "rhs" .= rhs + ] + + toJSON (QueryWith info ctes query) = object + [ "tag" .= String "With" + , "info" .= info + , "ctes" .= ctes + , "query" .= query + ] + + toJSON (QueryOrder info orders query) = object + [ "tag" .= String "QueryOrder" + , "info" .= info + , "orders" .= orders + , "query" .= query + ] + + toJSON (QueryLimit info limit query) = object + [ "tag" .= String "QueryLimit" + , "info" .= info + , "limit" .= limit + , "query" .= query + ] + + toJSON (QueryOffset info offset query) = object + [ "tag" .= String "QueryOffset" + , "info" .= info + , "offset" .= offset + , "query" .= query + ] + + +instance ToJSON Distinct where + toJSON (Distinct bool) = toJSON bool + + +instance ConstrainSNames ToJSON r a => ToJSON (CTE r a) where + toJSON (CTE {..}) = object + [ "tag" .= String "CTE" + , "alias" .= cteAlias + , "columns" .= cteColumns + , "query" .= cteQuery + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (Select r a) where + toJSON (Select {..}) = object + [ "tag" .= String "Select" + , "cols" .= selectCols + , "from" .= selectFrom + , "where" .= selectWhere + , "timeseries" .= selectTimeseries + , "group" .= selectGroup + , "having" .= selectHaving + , "window" .= selectNamedWindow + , "distinct" .= selectDistinct + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (SelectColumns r a) where + toJSON (SelectColumns info columns) = object + [ "tag" .= String "SelectColumns" + , "info" .= info + , "columns" .= columns + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (SelectFrom r a) where + toJSON (SelectFrom info tables) = object + [ "tag" .= String "SelectFrom" + , "info" .= info + , "tables" .= tables + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (SelectWhere r a) where + toJSON (SelectWhere info conditions) = object + [ "tag" .= String "SelectWhere" + , "info" .= info + , "conditions" .= conditions + ] + + +instance ConstrainSNames ToJSON r a=> ToJSON (SelectTimeseries r a) where + toJSON SelectTimeseries{..} = object + [ "tag" .= String "SelectTimeseries" + , "info" .= selectTimeseriesInfo + , "slice_name" .= selectTimeseriesSliceName + , "interval" .= selectTimeseriesInterval + , "partition" .= selectTimeseriesPartition + , "order" .= selectTimeseriesOrder + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (PositionOrExpr r a) where + toJSON (PositionOrExprPosition info pos expr) = object + [ "tag" .= String "PositionOrExprPosition" + , "info" .= info + , "position" .= pos + , "expr" .= expr + ] + toJSON (PositionOrExprExpr expr) = object + [ "tag" .= String "PositionOrExprExpr" + , "expr" .= expr + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (GroupingElement r a) where + toJSON (GroupingElementExpr info posOrExpr) = object + [ "tag" .= String "GroupingElementExpr" + , "info" .= info + , "position_or_expr" .= posOrExpr + ] + toJSON (GroupingElementSet info exprs) = object + [ "tag" .= String "GroupingElementSet" + , "info" .= info + , "exprs" .= exprs + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (SelectGroup r a) where + toJSON SelectGroup{..} = object + [ "tag" .= String "SelectGroup" + , "info" .= selectGroupInfo + , "grouping_elements" .= selectGroupGroupingElements + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (SelectHaving r a) where + toJSON (SelectHaving info conditions) = object + [ "tag" .= String "SelectHaving" + , "info" .= info + , "conditions" .= conditions + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (SelectNamedWindow r a) where + toJSON (SelectNamedWindow info windows) = object + [ "tag" .= String "SelectNamedWindow" + , "info" .= info + , "windows" .= windows + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (Selection r a) where + toJSON (SelectStar info table referents) = object + [ "tag" .= String "SelectStar" + , "info" .= info + , "table" .= table + , "referents" .= referents + ] + + toJSON (SelectExpr info aliases expr) = object + [ "tag" .= String "SelectExpr" + , "info" .= info + , "aliases" .= aliases + , "expr" .= expr + ] + + +instance ToJSON a => ToJSON (Constant a) where + toJSON (StringConstant info value) = object + [ "tag" .= String "StringConstant" + , "info" .= info + , case TL.decodeUtf8' value of + Left _ -> "value" .= BL.unpack value + Right str -> "value" .= str + ] + + toJSON (NumericConstant info value) = object + [ "tag" .= String "NumericConstant" + , "info" .= info + , "value" .= value + ] + + toJSON (NullConstant info) = object + [ "tag" .= String "NullConstant" + , "info" .= info + ] + + toJSON (BooleanConstant info value) = object + [ "tag" .= String "BooleanConstant" + , "info" .= info + , "value" .= value + ] + + toJSON (TypedConstant info value type_) = object + [ "tag" .= String "TypedConstant" + , "info" .= info + , "value" .= value + , "type" .= type_ + ] + + toJSON (ParameterConstant info) = object + [ "tag" .= String "ParameterConstant" + , "info" .= info + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (Expr r a) where + + toJSON (BinOpExpr info op lhs rhs) = object + [ "tag" .= String "BinOpExpr" + , "info" .= info + , "op" .= op + , "lhs" .= lhs + , "rhs" .= rhs + ] + + toJSON (UnOpExpr info op expr) = object + [ "tag" .= String "UnOpExpr" + , "info" .= info + , "op" .= op + , "expr" .= expr + ] + + toJSON (LikeExpr info op escape pattern expr) = object + [ "tag" .= String "LikeExpr" + , "info" .= info + , "op" .= op + , "escape" .= fmap escapeExpr escape + , "pattern" .= patternExpr pattern + , "expr" .= expr + ] + + toJSON (CaseExpr info whens melse) = object + [ "tag" .= String "CaseExpr" + , "info" .= info + + , "whens" .= + let conditionToJSON (c, r) = + object ["condition" .= c + , "result" .= r + ] + in map conditionToJSON whens + + , "else" .= melse + ] + + toJSON (ConstantExpr info constant) = object + [ "tag" .= String "ConstantExpr" + , "info" .= info + , "constant" .= constant + ] + + toJSON (ColumnExpr info column) = object + [ "tag" .= String "ColumnExpr" + , "info" .= info + , "column" .= column + ] + + toJSON (InListExpr info array expr) = object + [ "tag" .= String "InListExpr" + , "info" .= info + , "array" .= array + , "expr" .= expr + ] + + toJSON (InSubqueryExpr info query expr) = object + [ "tag" .= String "InSubqueryExpr" + , "info" .= info + , "query" .= query + , "expr" .= expr + ] + + toJSON (BetweenExpr info expr start end) = object + [ "tag" .= String "BetweenExpr" + , "info" .= info + , "expr" .= expr + , "start" .= start + , "end" .= end + ] + + toJSON (OverlapsExpr info lhs rhs) = object + [ "tag" .= String "OverlapsExpr" + , "info" .= info + , "ranges" .= + let rangeToJSON (start, end) = + object [ "start" .= start, "end" .= end ] + in map rangeToJSON [lhs, rhs] + ] + + toJSON (AtTimeZoneExpr info expr tz) = object + [ "tag" .= String "AtTimeZoneExpr" + , "info" .= info + , "expr" .= expr + , "tz" .= tz + ] + + toJSON (SubqueryExpr info query) = object + [ "tag" .= String "SubqueryExpr" + , "info" .= info + , "query" .= query + ] + + toJSON (FunctionExpr info function distinct args params filter' over) = object + [ "tag" .= String "FunctionExpr" + , "info" .= info + , "function" .= function + , "distinct" .= distinct + , "args" .= args + , "params" .= params + , "filter" .= filter' + , "over" .= over + ] + + toJSON (ExistsExpr info query) = object + [ "tag" .= String "ExistsExpr" + , "info" .= info + , "query" .= query + ] + + toJSON (ArrayExpr info values) = object + [ "tag" .= String "ArrayExpr" + , "info" .= info + , "values" .= values + ] + + toJSON (FieldAccessExpr info struct field) = object + [ "tag" .= String "FieldAccessExpr" + , "info" .= info + , "struct" .= struct + , "field" .= field + ] + + toJSON (ArrayAccessExpr info expr idx) = object + [ "tag" .= String "ArrayAccessExpr" + , "info" .= info + , "expr" .= expr + , "idx" .= idx + ] + + toJSON (TypeCastExpr info onFail expr type_) = object + [ "tag" .= String "TypeCastExpr" + , "info" .= info + , "onfail" .= onFail + , "expr" .= expr + , "type" .= type_ + ] + + toJSON (VariableSubstitutionExpr info) = object + [ "tag" .= String "VariableSubstitutionExpr" + , "info" .= info + ] + + +instance ToJSON a => ToJSON (ArrayIndex a) where + toJSON (ArrayIndex info value) = object + [ "tag" .= String "ArrayIndex" + , "info" .= info + , "value" .= value + ] + + +instance ToJSON a => ToJSON (DataTypeParam a) where + toJSON (DataTypeParamConstant constant) = object + [ "tag" .= String "DataTypeParamConstant" + , "param" .= constant + ] + toJSON (DataTypeParamType type_) = object + [ "tag" .= String "DataTypeParamType" + , "param" .= type_ + ] + + +instance ToJSON a => ToJSON (DataType a) where + toJSON (PrimitiveDataType info name args) = object + [ "tag" .= String "PrimitiveDataType" + , "info" .= info + , "name" .= name + , "args" .= args + ] + toJSON (ArrayDataType info itemType) = object + [ "tag" .= String "ArrayDataType" + , "info" .= info + , "itemType" .= itemType + ] + toJSON (MapDataType info keyType valueType) = object + [ "tag" .= String "MapDataType" + , "info" .= info + , "keyType" .= keyType + , "valueType" .= valueType + ] + toJSON (StructDataType info fields) = object + [ "tag" .= String "StructDataType" + , "info" .= info + , "fields" .= fields + ] + toJSON (UnionDataType info types) = object + [ "tag" .= String "UnionDataType" + , "info" .= info + , "types" .= types + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (Filter r a) where + toJSON (Filter info expr) = object + [ "tag" .= String "Filter" + , "info" .= info + , "expr" .= expr + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (OverSubExpr r a) where + toJSON (OverWindowExpr info windowExpr) = object + [ "tag" .= String "OverWindowExpr" + , "info" .= info + , "windowExpr" .= windowExpr + ] + + toJSON (OverWindowName info windowName) = object + [ "tag" .= String "OverWindowName" + , "info" .= info + , "windowName" .= windowName + ] + + toJSON (OverPartialWindowExpr info partialWindowExpr) = object + [ "tag" .= String "OverPartialWindowExpr" + , "info" .= info + , "partialWindowExpr" .= partialWindowExpr + ] + +instance ConstrainSNames ToJSON r a => ToJSON (WindowExpr r a) where + toJSON (WindowExpr info partition order frame) = object + [ "tag" .= String "WindowExpr" + , "info" .= info + , "partition" .= partition + , "order" .= order + , "frame" .= frame + ] + +instance ConstrainSNames ToJSON r a => ToJSON (PartialWindowExpr r a) where + toJSON (PartialWindowExpr info inherit partition order frame) = object + [ "tag" .= String "PartialWindowExpr" + , "info" .= info + , "inherit" .= inherit + , "partition" .= partition + , "order" .= order + , "frame" .= frame + ] + +instance ToJSON a => ToJSON (WindowName a) where + toJSON (WindowName info name) = object + [ "tag" .= String "WindowName" + , "info" .= info + , "name" .= name + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (NamedWindowExpr r a) where + toJSON (NamedWindowExpr info name window) = object + [ "tag" .= String "NamedWindowExpr" + , "info" .= info + , "name" .= name + , "window" .= window + ] + toJSON (NamedPartialWindowExpr info name partialWindow) = object + [ "tag" .= String "NamedWindowExpr" + , "info" .= info + , "name" .= name + , "partialWindow" .= partialWindow + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (Partition r a) where + toJSON (PartitionBest info) = object + [ "tag" .= String "PartitionBest" + , "info" .= info + ] + + toJSON (PartitionNodes info) = object + [ "tag" .= String "PartitionNodes" + , "info" .= info + ] + + toJSON (PartitionBy info expr) = object + [ "tag" .= String "PartitionBy" + , "info" .= info + , "expr" .= expr + ] + +instance ConstrainSNames ToJSON r a => ToJSON (Order r a) where + toJSON (Order info posOrExpr direction nullPos) = object + [ "tag" .= String "Order" + , "info" .= info + , "position_or_expr" .= posOrExpr + , "direction" .= direction + , "nullPos" .= nullPos + ] + +instance ToJSON a => ToJSON (FrameType a) where + toJSON (RowFrame info) = object + [ "tag" .= String "RowFrame" + , "info" .= info + ] + + toJSON (RangeFrame info) = object + [ "tag" .= String "RangeFrame" + , "info" .= info + ] + + +instance ToJSON a => ToJSON (FrameBound a) where + toJSON (Unbounded info) = object + [ "tag" .= String "Unbounded" + , "info" .= info + ] + + toJSON (CurrentRow info) = object + [ "tag" .= String "CurrentRow" + , "info" .= info + ] + + toJSON (Preceding info bound) = object + [ "tag" .= String "Preceding" + , "info" .= info + , "bound" .= bound + ] + + toJSON (Following info bound) = object + [ "tag" .= String "Following" + , "info" .= info + , "bound" .= bound + ] + + +instance ToJSON a => ToJSON (Frame a) where + toJSON (Frame info ftype start end) = object + [ "tag" .= String "Frame" + , "info" .= info + , "ftype" .= ftype + , "start" .= start + , "end" .= end + ] + + +instance ToJSON a => ToJSON (Offset a) where + toJSON (Offset info offset) = object + [ "tag" .= String "Offset" + , "info" .= info + , "offset" .= offset + ] + + +instance ToJSON a => ToJSON (Limit a) where + toJSON (Limit info limit) = object + [ "tag" .= String "Limit" + , "info" .= info + , "limit" .= limit + ] + + +instance ToJSON (Operator a) where + toJSON (Operator op) = object + [ "tag" .= String "Operator" + , "operator" .= op + ] + + +instance ToJSON a => ToJSON (JoinType a) where + toJSON (JoinInner info) = object + [ "tag" .= String "JoinInner" + , "info" .= info + ] + toJSON (JoinLeft info) = object + [ "tag" .= String "JoinLeft" + , "info" .= info + ] + toJSON (JoinRight info) = object + [ "tag" .= String "JoinRight" + , "info" .= info + ] + toJSON (JoinFull info) = object + [ "tag" .= String "JoinFull" + , "info" .= info + ] + toJSON (JoinSemi info) = object + [ "tag" .= String "JoinSemi" + , "info" .= info + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (JoinCondition r a) where + toJSON (JoinNatural info columns) = object [ "tag" .= String "JoinNatural", "info" .= info, "columns" .= columns ] + toJSON (JoinOn expr) = object + [ "tag" .= String "JoinOn" + , "expr" .= expr + ] + toJSON (JoinUsing info columns) = object + [ "tag" .= String "JoinUsing" + , "info" .= info + , "columns" .= columns + ] + + +instance ToJSON a => ToJSON (TablishAliases a) where + toJSON (TablishAliasesNone) = object + [ "tag" .= String "TablishAliasesNone" + ] + toJSON (TablishAliasesT table) = object + [ "tag" .= String "TablishAliasesT" + , "table" .= table + ] + toJSON (TablishAliasesTC table columns) = object + [ "tag" .= String "TablishAliasesTC" + , "table" .= table + , "columns" .= columns + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (Tablish r a) where + toJSON (TablishTable info aliases table) = object + [ "tag" .= String "TablishTable" + , "info" .= info + , "aliases" .= aliases + , "table" .= table + ] + + toJSON (TablishSubQuery info alias query) = object + [ "tag" .= String "TablishSubQuery" + , "info" .= info + , "alias" .= alias + , "query" .= query + ] + + toJSON (TablishJoin info join condition outer inner) = object + [ "tag" .= String "TablishJoin" + , "info" .= info + , "join" .= join + , "condition" .= condition + , "outer" .= outer + , "inner" .= inner + ] + + toJSON (TablishLateralView info view lhs) = object + [ "tag" .= String "TablishLateralView" + , "info" .= info + , "view" .= view + , "lhs" .= lhs + ] + + +instance ConstrainSNames ToJSON r a => ToJSON (LateralView r a) where + toJSON LateralView{..} = object + [ "tag" .= String "LateralView" + , "info" .= lateralViewInfo + , "outer" .= lateralViewOuter + , "exprs" .= lateralViewExprs + , "with_ordinality" .= lateralViewWithOrdinality + , "aliases" .= lateralViewAliases + ] + + +instance ToJSON a => ToJSON (OrderDirection a) where + toJSON (OrderAsc info) = object + [ "tag" .= String "OrderAsc" + , "info" .= info + ] + + toJSON (OrderDesc info) = object + [ "tag" .= String "OrderDesc" + , "info" .= info + ] + + +instance ToJSON a => ToJSON (NullPosition a) where + toJSON (NullsFirst info) = object + [ "tag" .= String "NullsFirst" + , "info" .= info + ] + + toJSON (NullsLast info) = object + [ "tag" .= String "NullsLast" + , "info" .= info + ] + + toJSON (NullsAuto info) = object + [ "tag" .= String "NullsAuto" + , "info" .= info + ] + + +-- FromJSON + +instance ConstrainSNames FromJSON r a => FromJSON (Query r a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "QuerySelect" -> QuerySelect + <$> o .: "info" + <*> o .: "select" + + String "QueryExcept" -> QueryExcept + <$> o .: "info" + <*> o .: "columns" + <*> o .: "lhs" + <*> o .: "rhs" + + String "QueryUnion" -> QueryUnion + <$> o .: "info" + <*> o .: "distinct" + <*> o .: "columns" + <*> o .: "lhs" + <*> o .: "rhs" + + String "QueryIntersect" -> QueryIntersect + <$> o .: "info" + <*> o .: "columns" + <*> o .: "lhs" + <*> o .: "rhs" + + String "QueryWith" -> QueryWith + <$> o .: "info" + <*> o .: "ctes" + <*> o .: "query" + + String "QueryOrder" -> QueryOrder + <$> o .: "info" + <*> o .: "orders" + <*> o .: "query" + + String "QueryLimit" -> QueryLimit + <$> o .: "info" + <*> o .: "limit" + <*> o .: "query" + + String "QueryOffset" -> QueryOffset + <$> o .: "info" + <*> o .: "offset" + <*> o .: "query" + + _ -> fail "unrecognized tag on query object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as Query:" + , show v + ] + + +instance FromJSON Distinct where + parseJSON (Bool bool) = return $ Distinct bool + parseJSON v = fail $ unwords + [ "don't know how to parse as Distinct:" + , show v + ] + +instance ConstrainSNames FromJSON r a => FromJSON (CTE r a) where + parseJSON (Object o) = do + String "CTE" <- o .: "tag" + cteInfo <- o .: "info" + cteAlias <- o .: "alias" + cteColumns <- o .: "columns" + cteQuery <- o .: "query" + return CTE{..} + + parseJSON v = fail $ unwords + [ "don't know how to parse as CTE:" + , show v + ] + + +instance FromJSON a => FromJSON (OrderDirection a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "OrderAsc" -> OrderAsc <$> o .: "info" + String "OrderDesc" -> OrderDesc <$> o .: "info" + _ -> fail "unrecognized tag on order direction object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as OrderDirection:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (Selection r a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "SelectStar" -> + SelectStar + <$> o .: "info" + <*> o .: "table" + <*> o .: "referents" + + String "SelectExpr" -> + SelectExpr + <$> o .: "info" + <*> o .: "aliases" + <*> o .: "expr" + + _ -> fail "unrecognized tag on selection object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as Selection:" + , show v + ] + + +instance FromJSON a => FromJSON (Constant a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "StringConstant" -> do + info <- o .: "info" + value <- TL.encodeUtf8 <$> o .: "value" + <|> BL.pack <$> o .: "value" + <|> fail "expected string or array for StringConstant value" + pure $ StringConstant info value + + String "NumericConstant" -> + NumericConstant + <$> o .: "info" + <*> o .: "value" + + String "NullConstant" -> + NullConstant <$> o .: "info" + + String "BooleanConstant" -> + BooleanConstant + <$> o .: "info" + <*> o .: "value" + + String "TypedConstant" -> + TypedConstant + <$> o .: "info" + <*> o .: "value" + <*> o .: "type" + + String "ParameterConstant" -> + ParameterConstant <$> o .: "info" + + _ -> fail "unrecognized tag on constant object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as Constant:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (Expr r a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "BinOpExpr" -> + BinOpExpr + <$> o .: "info" + <*> o .: "op" + <*> o .: "lhs" + <*> o .: "rhs" + + String "UnOpExpr" -> + UnOpExpr + <$> o .: "info" + <*> o .: "op" + <*> o .: "expr" + + String "LikeExpr" -> + LikeExpr + <$> o .: "info" + <*> o .: "op" + <*> (fmap Escape <$> o .: "escape") + <*> (Pattern <$> o .: "pattern") + <*> o .: "expr" + + String "CaseExpr" -> do + let jsonToWhen (Object w) = + (,) <$> w .: "condition" + <*> w .: "result" + + jsonToWhen v = fail $ unwords + [ "don't know how to parse as (Expr, Expr):" + , show v + ] + + whens <- mapM jsonToWhen =<< o .: "whens" + + CaseExpr <$> o .: "info" <*> pure whens <*> o .: "else" + + String "ConstantExpr" -> + ConstantExpr + <$> o .: "info" + <*> o .: "constant" + + String "ColumnExpr" -> + ColumnExpr + <$> o .: "info" + <*> o .: "column" + + String "InListExpr" -> + InListExpr + <$> o .: "info" + <*> o .: "array" + <*> o .: "expr" + + String "InSubqueryExpr" -> + InSubqueryExpr + <$> o .: "info" + <*> o .: "query" + <*> o .: "expr" + + String "BetweenExpr" -> + BetweenExpr + <$> o .: "info" + <*> o .: "expr" + <*> o .: "start" + <*> o .: "end" + + String "OverlapsExpr" -> do + info <- o .: "info" + Array ranges <- o .: "ranges" + + let jsonToRange (Object r) = (,) <$> r .: "start" + <*> r .: "end" + jsonToRange v = fail $ unwords + [ "don't know how to parse as (Expr, Expr):" + , show v + ] + + [range1, range2] <- mapM jsonToRange $ toList ranges + + return $ OverlapsExpr info range1 range2 + + String "FunctionExpr" -> + FunctionExpr + <$> o .: "info" + <*> o .: "function" + <*> o .: "distinct" + <*> o .: "args" + <*> o .: "params" + <*> o .: "filter" + <*> o .: "over" + + String "AtTimeZoneExpr" -> + AtTimeZoneExpr + <$> o .: "info" + <*> o .: "expr" + <*> o .: "tz" + + String "ArrayExpr" -> + ArrayExpr + <$> o .: "info" + <*> o .: "values" + + String "SubqueryExpr" -> + SubqueryExpr + <$> o .: "info" + <*> o .: "query" + + String "ExistsExpr" -> + ExistsExpr + <$> o .: "info" + <*> o .: "query" + + String "FieldAccessExpr" -> + FieldAccessExpr + <$> o .: "info" + <*> o .: "struct" + <*> o .: "field" + + String "ArrayAccessExpr" -> + ArrayAccessExpr + <$> o .: "info" + <*> o .: "expr" + <*> o .: "idx" + + String "TypeCastExpr" -> + TypeCastExpr + <$> o .: "info" + <*> o .: "onfailure" + <*> o .: "expr" + <*> o .: "type" + + String "VariableSubstitutionExpr" -> + VariableSubstitutionExpr <$> o .: "info" + + _ -> fail "unrecognized tag on expression object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as Expr:" + , show v + ] + + +instance FromJSON a => FromJSON (ArrayIndex a) where + parseJSON (Object o) = do + String "ArrayIndex" <- o .: "tag" + ArrayIndex + <$> o .: "info" + <*> o .: "value" + + parseJSON v = fail $ unwords + [ "don't know how to parse as ArrayIndex:" + , show v + ] + + +instance FromJSON a => FromJSON (DataTypeParam a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "DataTypeParamConstant" -> + DataTypeParamConstant <$> o .: "param" + String "DataTypeParamType" -> + DataTypeParamType <$> o .: "param" + + _ -> fail "unrecognized tag on data type param object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as DataTypeParam:" + , show v + ] + +instance FromJSON a => FromJSON (DataType a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "PrimitiveDataType" -> + PrimitiveDataType + <$> o .: "info" + <*> o .: "name" + <*> o .: "args" + String "ArrayDataType" -> + ArrayDataType + <$> o .: "info" + <*> o .: "itemType" + String "MapDataType" -> + MapDataType + <$> o .: "info" + <*> o .: "keyType" + <*> o .: "valueType" + String "StructDataType" -> + StructDataType + <$> o .: "info" + <*> o .: "fields" + String "UnionDataType" -> + UnionDataType + <$> o .: "info" + <*> o .: "types" + + _ -> fail "unrecognized tag on data type object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as DataType:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (Filter r a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "Filter" -> + Filter + <$> o .: "info" + <*> o .: "expr" + _ -> fail "unrecognized tag on Filter object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as Filter:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (OverSubExpr r a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "OverWindowExpr" -> + OverWindowExpr + <$> o .: "info" + <*> o .: "windowExpr" + String "OverWindowName" -> + OverWindowName + <$> o .: "info" + <*> o .: "windowName" + String "OverPartialWindowExpr" -> + OverPartialWindowExpr + <$> o .: "info" + <*> o .: "partialWindowExpr" + _ -> fail "unrecognized tag on OverSubExpr object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as OverSubExpr:" + , show v + ] + +instance ConstrainSNames FromJSON r a => FromJSON (WindowExpr r a) where + parseJSON (Object o) = do + String "WindowExpr" <- o .: "tag" + WindowExpr + <$> o .: "info" + <*> o .: "partition" + <*> o .: "order" + <*> o .: "frame" + + parseJSON v = fail $ unwords + [ "don't know how to parse as WindowExpr:" + , show v + ] + +instance ConstrainSNames FromJSON r a => FromJSON (PartialWindowExpr r a) where + parseJSON (Object o) = + do + String "PartialWindowExpr" <- o .: "tag" + PartialWindowExpr + <$> o .: "info" + <*> o .: "inherit" + <*> o .: "partition" + <*> o .: "order" + <*> o .: "frame" + + parseJSON v = fail $ unwords + [ "don't know how to parse as PartialWindowExpr:" + , show v + ] + +instance FromJSON a => FromJSON (WindowName a) where + parseJSON (Object o) = + do + String "WindowName" <- o .: "tag" + WindowName + <$> o .: "info" + <*> o .: "name" + + parseJSON v = fail $ unwords + [ "don't know how to parse as WindowName:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (NamedWindowExpr r a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "NamedWindowExpr" -> + NamedWindowExpr + <$> o .: "info" + <*> o .: "name" + <*> o .: "window" + String "NamedPartialWindowExpr" -> + NamedPartialWindowExpr + <$> o .: "info" + <*> o .: "name" + <*> o .: "partialWindow" + _ -> fail "unrecognized tag on NamedWindowExpr object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as NamedWindowExpr:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (Partition r a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "PartitionBest" -> PartitionBest <$> o .: "info" + String "PartitionNodes" -> PartitionNodes <$> o .: "info" + String "PartitionBy" -> PartitionBy <$> o .: "info" <*> o .: "expr" + + _ -> fail "unrecognized tag on partition object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as Partition:" + , show v + ] + +instance ConstrainSNames FromJSON r a => FromJSON (Order r a) where + parseJSON (Object o) = do + String "Order" <- o .: "tag" + Order + <$> o .: "info" + <*> o .: "position_or_expr" + <*> o .: "direction" + <*> o .: "nullPos" + + parseJSON v = fail $ unwords + [ "don't know how to parse as Order:" + , show v + ] + + +instance FromJSON a => FromJSON (NullPosition a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "NullsFirst" -> NullsFirst <$> o .: "info" + String "NullsLast" -> NullsLast <$> o .: "info" + String "NullsAuto" -> NullsAuto <$> o .: "info" + + _ -> fail "unrecognized tag on null position object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as NullPosition:" + , show v + ] + + +instance FromJSON a => FromJSON (FrameType a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "RowFrame" -> RowFrame <$> o .: "info" + String "RangeFrame" -> RangeFrame <$> o .: "info" + + _ -> fail "unrecognized tag on frame type object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as FrameType:" + , show v + ] + + +instance FromJSON a => FromJSON (FrameBound a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "Unbounded" -> Unbounded <$> o .: "info" + String "CurrentRow" -> CurrentRow <$> o .: "info" + String "Preceding" -> Preceding <$> o .: "info" <*> o .: "bound" + String "Following" -> Following <$> o .: "info" <*> o .: "bound" + + _ -> fail "unrecognized tag on frame bound object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as FrameBound:" + , show v + ] + + +instance FromJSON a => FromJSON (Frame a) where + parseJSON (Object o) = do + String "Frame" <- o .: "tag" + Frame <$> o .: "info" + <*> o .: "ftype" + <*> o .: "start" + <*> o .: "end" + + parseJSON v = fail $ unwords + [ "don't know how to parse as Frame:" + , show v + ] + + +instance FromJSON a => FromJSON (Offset a) where + parseJSON (Object o) = do + String "Offset" <- o .: "tag" + Offset <$> o .: "info" <*> o .: "offset" + + parseJSON v = fail $ unwords + [ "don't know how to parse as Offset:" + , show v + ] + + +instance FromJSON a => FromJSON (Limit a) where + parseJSON (Object o) = do + String "Limit" <- o .: "tag" + Limit <$> o .: "info" <*> o .: "limit" + + parseJSON v = fail $ unwords + [ "don't know how to parse as Limit:" + , show v + ] + + +instance FromJSON (Operator a) where + parseJSON (Object o) = do + String "Operator" <- o .: "tag" + Operator <$> o .: "operator" + + parseJSON v = fail $ unwords + [ "don't know how to parse as Operator:" + , show v + ] + + +instance FromJSON a => FromJSON (JoinType a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "JoinInner" -> JoinInner <$> o .: "info" + String "JoinLeft" -> JoinLeft <$> o .: "info" + String "JoinRight" -> JoinRight <$> o .: "info" + String "JoinFull" -> JoinFull <$> o .: "info" + String "JoinSemi" -> JoinSemi <$> o .: "info" + _ -> fail "unrecognized tag on JoinType object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as JoinType:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (JoinCondition r a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "JoinNatural" -> JoinNatural <$> o .: "info" <*> o .: "columns" + String "JoinOn" -> JoinOn <$> o .: "expr" + String "JoinUsing" -> JoinUsing <$> o .: "info" <*> o .: "columns" + _ -> fail "unrecognized tag on JoinCondition object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as JoinCondition:" + , show v + ] + + +instance FromJSON a => FromJSON (TablishAliases a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "TablishAliasesNone" -> return TablishAliasesNone + String "TablishAliasesT" -> TablishAliasesT <$> o .: "table" + String "TablishAliasesTC" -> TablishAliasesTC <$> o .: "table" <*> o .: "columns" + _ -> fail "unrecognized tag on TablishAliases object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as TablishAliases:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (Tablish r a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "TablishTable" -> + TablishTable + <$> o .: "info" + <*> o .: "aliases" + <*> o .: "table" + + String "TablishSubQuery" -> + TablishSubQuery + <$> o .: "info" + <*> o .: "alias" + <*> o .: "query" + + String "TablishJoin" -> + TablishJoin + <$> o .: "info" + <*> o .: "join" + <*> o .: "condition" + <*> o .: "outer" + <*> o .: "inner" + + String "TablishLateralView" -> + TablishLateralView + <$> o .: "info" + <*> o .: "view" + <*> o .: "lhs" + + _ -> fail "unrecognized tag on tablish object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as Tablish:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (LateralView r a) where + parseJSON (Object o) = do + String "LateralView" <- o .: "tag" + lateralViewInfo <- o .: "info" + lateralViewOuter <- o .: "outer" + lateralViewExprs <- o .: "exprs" + lateralViewWithOrdinality <- o .: "with_ordinality" + lateralViewAliases <- o .: "aliases" + pure LateralView{..} + + parseJSON v = fail $ unwords + [ "don't know how to parse as LateralView:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (Select r a) where + parseJSON (Object o) = do + String "Select" <- o .: "tag" + selectInfo <- o .: "info" + selectCols <- o .: "cols" + selectFrom <- o .: "from" + selectWhere <- o .: "where" + selectTimeseries <- o .:? "timeseries" + selectGroup <- o .: "group" + selectHaving <- o .: "having" + selectNamedWindow <- o .: "window" + selectDistinct <- o .: "distinct" + return Select{..} + + parseJSON v = fail $ unwords + [ "don't know how to parse as Select:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (SelectColumns r a) where + parseJSON (Object o) = do + String "SelectColumns" <- o .: "tag" + SelectColumns <$> o .: "info" <*> o .: "columns" + + parseJSON v = fail $ unwords + [ "don't know how to parse as SelectColumns:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (SelectFrom r a) where + parseJSON (Object o) = do + String "SelectFrom" <- o .: "tag" + SelectFrom <$> o .: "info" <*> o .: "tables" + + parseJSON v = fail $ unwords + [ "don't know how to parse as SelectFrom:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (SelectWhere r a) where + parseJSON (Object o) = do + String "SelectWhere" <- o .: "tag" + SelectWhere <$> o .: "info" <*> o .: "conditions" + + parseJSON v = fail $ unwords + [ "don't know how to parse as SelectWhere:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (SelectTimeseries r a) where + parseJSON (Object o) = do + String "SelectTimeseries" <- o .: "tag" + selectTimeseriesInfo <- o .: "info" + selectTimeseriesSliceName <- o .: "slice_name" + selectTimeseriesInterval <- o .: "interval" + selectTimeseriesPartition <- o .: "partition" + selectTimeseriesOrder <- o .: "order" + pure SelectTimeseries{..} + + parseJSON v = fail $ unwords + [ "don't know how to parse as SelectTimeseries:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (PositionOrExpr r a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "PositionOrExprPosition" -> PositionOrExprPosition <$> o .: "info" <*> o .: "position" <*> o .: "expr" + String "PositionOrExprExpr" -> PositionOrExprExpr <$> o .: "expr" + _ -> fail "unrecognized tag on PositionOrExpr object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as PositionOrExpr:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (GroupingElement r a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "GroupingElementExpr" -> GroupingElementExpr <$> o .: "info" <*> o .: "position_or_expr" + String "GroupingElementSet" -> GroupingElementSet <$> o .: "info" <*> o .: "exprs" + _ -> fail "unrecognized tag on GroupingElement object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as GroupingElement:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (SelectGroup r a) where + parseJSON (Object o) = do + String "SelectGroup" <- o .: "tag" + selectGroupInfo <- o .: "info" + selectGroupGroupingElements <- o .: "grouping_elements" + pure $ SelectGroup{..} + + parseJSON v = fail $ unwords + [ "don't know how to parse as SelectGroup:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (SelectHaving r a) where + parseJSON (Object o) = do + String "SelectHaving" <- o .: "tag" + SelectHaving <$> o .: "info" <*> o .: "conditions" + + parseJSON v = fail $ unwords + [ "don't know how to parse as SelectHaving:" + , show v + ] + + +instance ConstrainSNames FromJSON r a => FromJSON (SelectNamedWindow r a) where + parseJSON (Object o) = do + String "SelectNamedWindow" <- o .: "tag" + SelectNamedWindow + <$> o .: "info" + <*> o .: "windows" + + parseJSON v = fail $ unwords + [ "don't know how to parse as SelectNamedWindow:" + , show v + ] + + +-- Arbitrary helpers + +arbitraryDate :: Gen Text +arbitraryDate = do + y <- choose (0,3000) :: Gen Int + m <- choose (1,12) :: Gen Int + d <- choose (1,28) :: Gen Int + pure $ TL.intercalate "-" $ map (TL.pack . show) [y,m,d] + +arbitraryTime :: Gen Text +arbitraryTime = do + h <- choose (0,23) :: Gen Int + m <- choose (0,59) :: Gen Int + s <- choose (0,59) :: Gen Int + pure $ TL.intercalate ":" $ map (TL.pack . show) [h,m,s] + +arbitraryTimestamp :: Gen Text +arbitraryTimestamp = do + d <- arbitraryDate + t <- arbitraryTime + pure $ TL.unwords [d, t] + +arbitraryInterval :: Gen Text +arbitraryInterval = do + n <- (TL.pack . show) <$> (arbitrary :: Gen Int) + period <- elements ["days", "weeks", "hours"] + pure $ TL.unwords [n, period] + +arbitraryText :: Gen Text +arbitraryText = TL.pack <$> oneof + [ arbitrary + , listOf $ arbitrary `suchThat` Char.isPrint + ] + +arbitraryByteString :: Gen ByteString +arbitraryByteString = oneof + [ BL.pack <$> arbitrary + , TL.encodeUtf8 <$> arbitraryText + ] + +shrinkByteString :: ByteString -> [ByteString] +shrinkByteString str + | BL.null str = [] + | BL.length str == 1 = [""] + | otherwise = + [ "" + , BL.take halfLen str + , BL.drop halfLen str + ] ++ if any (not . Char.isPrint . Char.chr . fromIntegral) $ BL.unpack str + then [BL.filter (Char.isPrint . Char.chr . fromIntegral) str] + else [] + where + halfLen = BL.length str `div` 2 + + +-- Arbitrary queries + +instance Arbitrary a => Arbitrary (Constant a) where + arbitrary = oneof + [ StringConstant <$> arbitrary + <*> arbitraryByteString + , NumericConstant <$> arbitrary <*> oneof + [ fmap (TL.pack . show) (arbitrary :: Gen Int) + , fmap (TL.pack . show) (arbitrary :: Gen Float) + ] + , NullConstant <$> arbitrary + , BooleanConstant <$> arbitrary <*> arbitrary + , do + info <- arbitrary + (text, dataType) <- oneof + [ do + value <- arbitraryText + info' <- arbitrary + let name = "VARCHAR" + pure (value, PrimitiveDataType info' name []) + , do + value <- arbitraryText + info' <- arbitrary + len <- arbitrary `suchThat` (>0) :: Gen Int + let name = "VARCHAR" + lenConst <- NumericConstant <$> arbitrary <*> pure (TL.pack $ show len) + pure (value, PrimitiveDataType info' name [DataTypeParamConstant lenConst]) + , do + value <- arbitraryTimestamp + info' <- arbitrary + name <- elements ["TIMESTAMP", "TIMESTAMP WITH TIME ZONE"] + pure (value, PrimitiveDataType info' name []) + , do + value <- fmap (TL.pack . show) $ (arbitrary :: Gen Int) + info' <- arbitrary + let name = "INT" + pure (value, PrimitiveDataType info' name []) + , do + value <- arbitraryInterval + info' <- arbitrary + let name = "INTERVAL" + pure (value, PrimitiveDataType info' name []) + ] + pure $ TypedConstant info text dataType + , ParameterConstant <$> arbitrary + ] + shrink (StringConstant info s) = StringConstant info <$> shrinkByteString s + + shrink (NumericConstant info n) = + case reads $ TL.unpack n of + [] -> [] + (prefix :: Float, _):_ -> NumericConstant info . TL.pack . show <$> shrink prefix + + shrink (NullConstant _) = [] + + shrink (BooleanConstant _ True) = [] + shrink (BooleanConstant info False) = [BooleanConstant info True] + + shrink (TypedConstant _ _ (PrimitiveDataType _ "VARCHAR" [])) = [] + shrink (TypedConstant info value (PrimitiveDataType info' "TIMESTAMP WITH TIME ZONE" args)) = + [TypedConstant info value (PrimitiveDataType info' "TIMESTAMP" args)] + shrink (TypedConstant info value (PrimitiveDataType info' _ _)) = + [TypedConstant info value (PrimitiveDataType info' "VARCHAR" [])] + shrink (TypedConstant _ _ _) = + fail "TODO: shrink for complex data types" + + shrink (ParameterConstant _) = [] + +scaleDown :: Int -> Gen a -> Gen a +scaleDown n = scale (`div` n) + +instance (Arbitrary (PositionExpr r a), Arbitrary a) => Arbitrary (Partition r a) where + arbitrary = oneof + [ PartitionBy <$> arbitrary <*> (scaleDown 5 arbitrary) + , PartitionBest <$> arbitrary + , PartitionNodes <$> arbitrary + ] + shrink (PartitionBest _) = [] + shrink (PartitionNodes info) = [PartitionBest info] + shrink (PartitionBy info _) = [PartitionBest info] + +instance (Arbitrary (PositionExpr r a), Arbitrary a) => Arbitrary (PositionOrExpr r a) where + arbitrary = oneof + [ PositionOrExprPosition <$> arbitrary <*> arbitrary <*> arbitrary + , PositionOrExprExpr <$> arbitrary + ] + shrink (PositionOrExprPosition info _ expr) = PositionOrExprPosition info 1 <$> shrink expr + shrink (PositionOrExprExpr expr) = PositionOrExprExpr <$> shrink expr + +instance (Arbitrary (PositionExpr r a), Arbitrary a) => Arbitrary (Order r a) where + arbitrary = Order <$> arbitrary <*> (scaleDown 5 arbitrary) <*> arbitrary <*> arbitrary + +instance Arbitrary a => Arbitrary (OrderDirection a) where + arbitrary = oneof + [ OrderAsc <$> arbitrary + , OrderDesc <$> arbitrary + ] + shrink (OrderAsc _) = [] + shrink (OrderDesc info) = [OrderAsc info] + +instance Arbitrary a => Arbitrary (NullPosition a) where + arbitrary = oneof + [ NullsFirst <$> arbitrary + , NullsLast <$> arbitrary + , NullsAuto <$> arbitrary + ] + shrink (NullsFirst _) = [] + shrink (NullsLast info) = [NullsFirst info] + shrink (NullsAuto info) = [NullsFirst info] + +instance Arbitrary a => Arbitrary (FrameType a) where + arbitrary = oneof + [ RowFrame <$> arbitrary + , RangeFrame <$> arbitrary + ] + shrink (RowFrame _) = [] + shrink (RangeFrame info) = [RowFrame info] + +instance Arbitrary a => Arbitrary (FrameBound a) where + arbitrary = oneof + [ Unbounded <$> arbitrary + , CurrentRow <$> arbitrary + , Preceding <$> arbitrary <*> arbitrary + , Following <$> arbitrary <*> arbitrary + ] + shrink (Unbounded _) = [] + shrink (CurrentRow info) = [Unbounded info] + shrink (Preceding info _) = [Unbounded info] + shrink (Following info _) = [Unbounded info] + +instance Arbitrary a => Arbitrary (Frame a) where + arbitrary = do + frameInfo <- arbitrary + frameType <- arbitrary + frameStart <- arbitrary + frameEnd <- arbitrary + pure $ Frame{..} + shrink (Frame i t s e) = [Frame i t' s' e' | (t', s', e') <- shrink (t, s, e)] + +instance (Arbitrary (PositionExpr r a), Arbitrary a) => Arbitrary (OverSubExpr r a) where + arbitrary = do + info <- arbitrary + oneof + [ OverWindowExpr info <$> arbitrary + , OverWindowName info <$> arbitrary + , OverPartialWindowExpr info <$> arbitrary + ] + shrink (OverWindowExpr info e) = OverWindowExpr info <$> shrink e + shrink (OverWindowName _ _) = [] -- Ideally resolve name, once implemented + shrink (OverPartialWindowExpr info e) = + OverPartialWindowExpr info <$> shrink e + +instance (Arbitrary (PositionExpr r a), Arbitrary a) => Arbitrary (WindowExpr r a) where + arbitrary = do + windowExprInfo <- arbitrary + windowExprPartition <- arbitrary + windowExprOrder <- scaleDown 5 arbitrary + windowExprFrame <- arbitrary + pure $ WindowExpr{..} + shrink (WindowExpr i p o f) = [WindowExpr i p' o' f' | (p', o', f') <- shrink (p, o, f)] + +instance Arbitrary a => Arbitrary (WindowName a) where + arbitrary = + do + info <- arbitrary + name <- TL.pack <$> arbitrary + pure $ WindowName info name + +instance (Arbitrary (PositionExpr r a), Arbitrary a) => Arbitrary (PartialWindowExpr r a) where + arbitrary = + do + partWindowExprInfo <- arbitrary + partWindowExprInherit <- arbitrary + partWindowExprPartition <- arbitrary + partWindowExprOrder <- scaleDown 5 arbitrary + partWindowExprFrame <- arbitrary + pure $ PartialWindowExpr{..} + + shrink (PartialWindowExpr i n p o f) = + [PartialWindowExpr i n p' o' f' | (p', o', f') <- shrink (p, o, f)] + +instance Arbitrary Distinct where + arbitrary = Distinct <$> arbitrary + shrink (Distinct bool) = Distinct <$> shrink bool + +instance (Arbitrary (PositionExpr r a), Arbitrary a) => Arbitrary (Filter r a) where + arbitrary = Filter <$> arbitrary <*> arbitrary + shrink (Filter info expr) = Filter info <$> shrink expr + +instance (Arbitrary (PositionExpr r a), Arbitrary a) => Arbitrary (Expr r a) where + arbitrary = sized $ \size -> do + info <- arbitrary + frequency + [ (5, ConstantExpr info <$> arbitrary) + , (1, FunctionExpr info <$> arbitrary <*> arbitrary <*> (scaleDown 5 arbitrary) <*> (scaleDown 5 arbitrary) <*> (if size > 5 then arbitrary else pure Nothing) <*> (if size > 5 then arbitrary else pure Nothing)) + ] + shrink (ConstantExpr info c) = ConstantExpr info <$> shrink c + shrink (FunctionExpr i n d e p f o) = + [FunctionExpr i n' d' e' p' f' o' | (n', d', e', p', (f', o')) <- shrink (n, d, e, p, (f, o))] + shrink _ = [] -- NB shrinking is only partially implemented; stubbing this + -- out to avoid compiler warnings about non-exhaustive + -- pattern matching diff --git a/src/Database/Sql/Type/Schema.hs b/src/Database/Sql/Type/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Type/Schema.hs @@ -0,0 +1,641 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Database.Sql.Type.Schema where + +import Prelude hiding ((&&), (||), not) + +import Database.Sql.Type.Names +import Database.Sql.Type.TableProps +import Database.Sql.Type.Scope + +import Control.Arrow (first) +import Control.Monad.Except +import Control.Monad.Writer +import Data.Functor.Identity + +import qualified Data.HashMap.Strict as HMS + +import Data.Maybe (mapMaybe, maybeToList) +import Data.Predicate.Class + + +overWithColumns :: (r a -> s a) -> WithColumns r a -> WithColumns s a +overWithColumns f (WithColumns r cs) = WithColumns (f r) cs + + +resolvedColumnHasName :: QColumnName f a -> RColumnRef a -> Bool +resolvedColumnHasName (QColumnName _ _ name) (RColumnAlias (ColumnAlias _ name' _)) = name' == name +resolvedColumnHasName (QColumnName _ _ name) (RColumnRef (QColumnName _ _ name')) = name' == name + +makeCatalog :: CatalogMap -> Path -> CurrentDatabase -> Catalog +makeCatalog catalog path currentDb = Catalog{..} + where + catalogResolveTableNameHelper oqtn@(QTableName tInfo (Just oqsn@(QSchemaName sInfo (Just db@(DatabaseName _ _)) schemaName schemaType)) tableName) = do + let fqsn = QSchemaName sInfo (pure db) schemaName schemaType + fqtn = QTableName tInfo (pure fqsn) tableName + default' = RTableName fqtn (persistentTable []) + missingD = Left $ MissingDatabase db + missingS = Left $ MissingSchema oqsn + missingT = Left $ MissingTable oqtn + tableNameResolved = Right $ TableNameResolved oqtn default' + case HMS.lookup (void db) catalog of + Nothing -> tell [missingD, missingS, missingT, tableNameResolved] >> pure default' + Just database -> + case HMS.lookup (QSchemaName () None schemaName schemaType) database of + Nothing -> tell [missingS, missingT, tableNameResolved] >> pure default' + Just schema -> do + case HMS.lookup (QTableName () None tableName) schema of + Nothing -> tell [missingT, tableNameResolved] >> pure default' + Just table -> do + let rtn = RTableName fqtn table + tell [Right $ TableNameResolved oqtn rtn] + pure rtn + + catalogResolveTableNameHelper _ = error "only call catalogResolveTableNameHelper with fully qualified table name" + + catalogResolveTableName oqtn@(QTableName _ (Just (QSchemaName _ (Just (DatabaseName _ _)) _ _)) _) = + catalogResolveTableNameHelper oqtn + + catalogResolveTableName (QTableName tInfo (Just oqsn@(QSchemaName _ Nothing _ _)) tableName) = + catalogResolveTableNameHelper $ QTableName tInfo (Just $ inCurrentDb oqsn) tableName + + catalogResolveTableName oqtn@(QTableName tInfo Nothing tableName) = do + let getTableFromSchema uqsn@(QSchemaName _ None schemaName schemaType) = do + db <- HMS.lookup currentDb catalog + schema <- HMS.lookup uqsn db + table <- HMS.lookup (QTableName () None tableName) schema + let db' = fmap (const tInfo) currentDb + fqsn = QSchemaName tInfo (pure db') schemaName schemaType + fqtn = QTableName tInfo (pure fqsn) tableName + pure $ RTableName fqtn table + + case mapMaybe getTableFromSchema path of + rtn:_ -> do + tell [Right $ TableNameResolved oqtn rtn] + pure rtn + [] -> throwError $ MissingTable oqtn + + -- TODO session schemas should have the name set to the session ID + catalogResolveSchemaName :: forall a . OQSchemaName a -> CatalogObjectResolver a (FQSchemaName a) + catalogResolveSchemaName (QSchemaName sInfo (Just db) schemaName schemaType) = + pure $ QSchemaName sInfo (pure db) schemaName schemaType + catalogResolveSchemaName oqsn@(QSchemaName _ Nothing _ _) = + pure $ inCurrentDb oqsn + + catalogHasDatabase databaseName = + case HMS.member (void databaseName) catalog of + False -> DoesNotExist + True -> Exists + + catalogHasSchema schemaName = + case HMS.lookup currentDb catalog of + Just db -> case HMS.member (void schemaName) db of + False -> DoesNotExist + True -> Exists + Nothing -> DoesNotExist + + catalogResolveTableRefHelper oqtn@(QTableName tInfo (Just oqsn@(QSchemaName sInfo (Just db@(DatabaseName _ _)) schemaName schemaType)) tableName) = do + let fqsn = QSchemaName sInfo (pure db) schemaName schemaType + fqtn = QTableName tInfo (pure fqsn) tableName + + case HMS.lookup (void db) catalog of + Nothing -> throwError $ MissingDatabase db + Just database -> case HMS.lookup (QSchemaName () None schemaName schemaType) database of + Nothing -> throwError $ MissingSchema oqsn + Just tables -> do + case HMS.lookup (QTableName () None tableName) tables of + Nothing -> throwError $ MissingTable oqtn + Just table@SchemaMember{..} -> do + let makeRColumnRef (QColumnName () None name) = RColumnRef $ QColumnName tInfo (pure fqtn) name + tableRef = RTableRef fqtn table + tell [Right $ TableRefResolved oqtn tableRef] + pure $ WithColumns tableRef [(Just tableRef, map makeRColumnRef columnsList)] + + catalogResolveTableRefHelper _ = error "only call catalogResolveTableRefHelper with fully qualified table name" + + catalogResolveTableRef _ oqtn@(QTableName _ (Just (QSchemaName _ (Just (DatabaseName _ _)) _ _)) _) = + catalogResolveTableRefHelper oqtn + + catalogResolveTableRef _ (QTableName tInfo (Just oqsn@(QSchemaName _ Nothing _ _)) tableName) = + catalogResolveTableRefHelper $ QTableName tInfo (Just $ inCurrentDb oqsn) tableName + + catalogResolveTableRef boundCTEs oqtn@(QTableName tInfo Nothing tableName) = do + case filter (resolvedTableHasName oqtn . fst) $ map (first RTableAlias) boundCTEs of + [(t, cs)] -> do + tell [Right $ TableRefResolved oqtn t] + pure $ WithColumns t [(Just t, cs)] + _:_ -> throwError $ AmbiguousTable oqtn + [] -> do + let getTableFromSchema uqsn@(QSchemaName _ None schemaName schemaType) = do + db <- HMS.lookup currentDb catalog + schema <- HMS.lookup uqsn db + table@SchemaMember{..} <- HMS.lookup (QTableName () None tableName) schema + let db' = fmap (const tInfo) currentDb + fqsn = QSchemaName tInfo (pure db') schemaName schemaType + fqtn = QTableName tInfo (pure fqsn) tableName + makeRColumnRef (QColumnName () None name) = RColumnRef $ QColumnName tInfo (pure fqtn) name + tableRef = RTableRef fqtn table + pure $ WithColumns tableRef [(Just tableRef, map makeRColumnRef columnsList)] + + case mapMaybe getTableFromSchema path of + table@(WithColumns tableRef _):_ -> do + tell [Right $ TableRefResolved oqtn tableRef] + pure table + [] -> throwError $ MissingTable oqtn + + catalogResolveCreateSchemaName oqsn = do + fqsn@(QSchemaName _ (Identity db) schemaName schemaType) <- case schemaNameType oqsn of + NormalSchema -> catalogResolveSchemaName oqsn + SessionSchema -> error "can't create the session schema" + existence <- case HMS.lookup (void db) catalog of + Nothing -> tell [Left $ MissingDatabase db] >> pure DoesNotExist + Just database -> if HMS.member (QSchemaName () None schemaName schemaType) database + then pure Exists + else pure DoesNotExist + let rcsn = RCreateSchemaName fqsn existence + tell [Right $ CreateSchemaNameResolved oqsn rcsn] + pure rcsn + + catalogResolveCreateTableName name = do + oqtn@(QTableName tInfo (Just oqsn@(QSchemaName sInfo (Just db) schemaName schemaType)) tableName) <- + case name of + oqtn@(QTableName _ Nothing _) -> pure $ inHeadOfPath oqtn + QTableName tInfo (Just oqsn@(QSchemaName _ Nothing _ _)) tableName -> pure $ QTableName tInfo (pure $ inCurrentDb oqsn) tableName + _ -> pure name + + let missingD = Left $ MissingDatabase db + missingS = Left $ MissingSchema oqsn + existence <- case HMS.lookup (void db) catalog of + Nothing -> tell [missingD, missingS] >> pure DoesNotExist + Just database -> case HMS.lookup (QSchemaName () None schemaName schemaType) database of + Nothing -> tell [missingS] >> pure DoesNotExist + Just schema -> if HMS.member (QTableName () None tableName) schema + then pure Exists + else pure DoesNotExist + + let fqsn = QSchemaName sInfo (pure db) schemaName schemaType + rctn = RCreateTableName (QTableName tInfo (pure fqsn) tableName) existence + tell [Right $ CreateTableNameResolved oqtn rctn] + + pure rctn + + inCurrentDb :: Applicative g => QSchemaName f a -> QSchemaName g a + inCurrentDb (QSchemaName sInfo _ schemaName schemaType) = + let db = fmap (const sInfo) currentDb + in QSchemaName sInfo (pure db) schemaName schemaType + + inHeadOfPath :: Applicative g => QTableName f a -> QTableName g a + inHeadOfPath (QTableName tInfo _ tableName) = + let db = fmap (const tInfo) currentDb + QSchemaName _ None schemaName schemaType = head path + qsn = QSchemaName tInfo (pure db) schemaName schemaType + in QTableName tInfo (pure qsn) tableName + + catalogResolveColumnName :: forall a . [(Maybe (RTableRef a), [RColumnRef a])] -> OQColumnName a -> CatalogObjectResolver a (RColumnRef a) + catalogResolveColumnName boundColumns oqcn@(QColumnName cInfo (Just oqtn@(QTableName tInfo (Just oqsn@(QSchemaName sInfo (Just db) schema schemaType)) table)) column) = do + case filter (maybe False (resolvedTableHasDatabase db && resolvedTableHasSchema oqsn && resolvedTableHasName oqtn) . fst) boundColumns of + [] -> throwError $ UnintroducedTable oqtn + _:_:_ -> throwError $ AmbiguousTable oqtn + [(_, columns)] -> + case filter (resolvedColumnHasName oqcn) columns of + [] -> do + let c = RColumnRef $ QColumnName cInfo (pure $ QTableName tInfo (pure $ QSchemaName sInfo (pure db) schema schemaType) table) column + tell [ Left $ MissingColumn oqcn + , Right $ ColumnRefResolved oqcn c + ] + pure c + [c] -> do + let c' = fmap (const cInfo) c + tell [Right $ ColumnRefResolved oqcn c'] + pure c' + _ -> throwError $ AmbiguousColumn oqcn + + catalogResolveColumnName boundColumns oqcn@(QColumnName cInfo (Just oqtn@(QTableName tInfo (Just oqsn@(QSchemaName sInfo Nothing schema schemaType)) table)) column) = do + case filter (maybe False (resolvedTableHasSchema oqsn && resolvedTableHasName oqtn) . fst) boundColumns of + [] -> throwError $ UnintroducedTable oqtn + _:_:_ -> throwError $ AmbiguousTable oqtn + [(table', columns)] -> + case filter (resolvedColumnHasName oqcn) columns of + [] -> do + let Just (RTableRef (QTableName _ (Identity (QSchemaName _ (Identity (DatabaseName _ db)) _ _)) _) _) = table' -- this pattern match shouldn't fail: + -- the `maybe False` prevents Nothings, and the `resolvedTableHasSchema` prevents RTableAliases + c = RColumnRef $ QColumnName cInfo (pure $ QTableName tInfo (pure $ QSchemaName sInfo (pure $ DatabaseName sInfo db) schema schemaType) table) column + tell [ Left $ MissingColumn oqcn + , Right $ ColumnRefResolved oqcn c + ] + pure c + [c] -> do + let c' = fmap (const cInfo) c + tell [Right $ ColumnRefResolved oqcn c'] + pure c' + _ -> throwError $ AmbiguousColumn oqcn + + catalogResolveColumnName boundColumns oqcn@(QColumnName cInfo (Just oqtn@(QTableName tInfo Nothing table)) column) = do + let setInfo :: Functor f => f a -> f a + setInfo = fmap (const cInfo) + + case [ (t, cs) | (mt, cs) <- boundColumns, t <- maybeToList mt, resolvedTableHasName oqtn t ] of + [] -> throwError $ UnintroducedTable oqtn + [(table', columns)] -> do + case filter (resolvedColumnHasName oqcn) columns of + [] -> case table' of + RTableAlias _ -> throwError $ MissingColumn oqcn + RTableRef fqtn@(QTableName _ (Identity (QSchemaName _ (Identity (DatabaseName _ db)) schema schemaType)) _) _ -> do + let c = RColumnRef $ QColumnName cInfo (pure $ setInfo fqtn) column + tell [ Left $ MissingColumn $ QColumnName cInfo (Just $ QTableName tInfo (Just $ QSchemaName cInfo (Just $ DatabaseName cInfo db) schema schemaType) table) column + , Right $ ColumnRefResolved oqcn c] + pure c + [c] -> do + let c' = setInfo c + tell [Right $ ColumnRefResolved oqcn c'] + pure c' + _ -> throwError $ AmbiguousColumn oqcn + tables -> do + tell [Left $ AmbiguousTable oqtn] + case filter (resolvedColumnHasName oqcn) $ snd =<< tables of + [] -> throwError $ MissingColumn oqcn + [c] -> do + let c' = setInfo c + tell [Right $ ColumnRefResolved oqcn c'] + pure c' + _ -> throwError $ AmbiguousColumn oqcn + + catalogResolveColumnName boundColumns oqcn@(QColumnName cInfo Nothing _) = do + let columns = snd =<< boundColumns + case filter (resolvedColumnHasName oqcn) columns of + [] -> throwError $ MissingColumn oqcn + [c] -> do + let c' = fmap (const cInfo) c + tell [Right $ ColumnRefResolved oqcn c'] + pure c' + _ -> throwError $ AmbiguousColumn oqcn + + catalogHasTable tableName = + let getTableFromSchema uqsn = do + database <- HMS.lookup currentDb catalog + schema <- HMS.lookup uqsn database + pure $ HMS.member tableName schema + in case any id $ mapMaybe getTableFromSchema path of + False -> DoesNotExist + True -> Exists + + overCatalogMap f = + let (cm, extra) = f catalog + in seq cm $ (makeCatalog cm path currentDb, extra) + + catalogMap = catalog + + catalogWithPath newPath = makeCatalog catalog newPath currentDb + + catalogWithDatabase = makeCatalog catalog path + +defaultSchemaMember :: SchemaMember +defaultSchemaMember = SchemaMember{..} + where + tableType = Table + persistence = Persistent + columnsList = [] + viewQuery = Nothing + +unknownDatabase :: a -> DatabaseName a +unknownDatabase info = DatabaseName info "" + +unknownSchema :: a -> FQSchemaName a +unknownSchema info = QSchemaName info (pure $ unknownDatabase info) "" NormalSchema + +unknownTable :: a -> FQTableName a +unknownTable info = QTableName info (pure $ unknownSchema info) "" + +makeDefaultingCatalog :: CatalogMap -> Path -> CurrentDatabase -> Catalog +makeDefaultingCatalog catalog path currentDb = Catalog{..} + where + catalogResolveTableNameHelper oqtn@(QTableName tInfo (Just oqsn@(QSchemaName sInfo (Just db@(DatabaseName _ _)) schemaName schemaType)) tableName) = do + let fqsn = QSchemaName sInfo (pure db) schemaName schemaType + fqtn = QTableName tInfo (pure fqsn) tableName + default' = RTableName fqtn (persistentTable []) + missingD = Left $ MissingDatabase db + missingS = Left $ MissingSchema oqsn + missingT = Left $ MissingTable oqtn + tableNameResolved = Right $ TableNameResolved oqtn default' + case HMS.lookup (void db) catalog of + Nothing -> tell [missingD, missingS, missingT, tableNameResolved] >> pure default' + Just database -> + case HMS.lookup (QSchemaName () None schemaName schemaType) database of + Nothing -> tell [missingS, missingT, tableNameResolved] >> pure default' + Just schema -> do + case HMS.lookup (QTableName () None tableName) schema of + Nothing -> tell [missingT, tableNameResolved] >> pure default' + Just table -> do + let rtn = RTableName fqtn table + tell [Right $ TableNameResolved oqtn rtn] + pure rtn + + catalogResolveTableNameHelper _ = error "only call catalogResolveTableNameHelper with fully qualified table name" + + catalogResolveTableName oqtn@(QTableName _ (Just (QSchemaName _ (Just (DatabaseName _ _)) _ _)) _) = + catalogResolveTableNameHelper oqtn + + catalogResolveTableName (QTableName tInfo (Just oqsn@(QSchemaName _ Nothing _ _)) tableName) = + catalogResolveTableNameHelper $ QTableName tInfo (Just $ inCurrentDb oqsn) tableName + + catalogResolveTableName oqtn@(QTableName tInfo Nothing tableName) = do + let getTableFromSchema uqsn@(QSchemaName _ None schemaName schemaType) = do + db <- HMS.lookup currentDb catalog + schema <- HMS.lookup uqsn db + table <- HMS.lookup (QTableName () None tableName) schema + let db' = fmap (const tInfo) currentDb + fqsn = QSchemaName tInfo (pure db') schemaName schemaType + fqtn = QTableName tInfo (pure fqsn) tableName + pure $ RTableName fqtn table + + case mapMaybe getTableFromSchema path of + rtn:_ -> do + tell [Right $ TableNameResolved oqtn rtn] + pure rtn + [] -> do + let rtn = RTableName (inHeadOfPath oqtn) $ persistentTable [] + tell [ Left $ MissingTable oqtn + , Right $ TableNameDefaulted oqtn rtn + ] + pure rtn + + inCurrentDb :: Applicative g => QSchemaName f a -> QSchemaName g a + inCurrentDb (QSchemaName sInfo _ schemaName schemaType) = + let db = fmap (const sInfo) currentDb + in QSchemaName sInfo (pure db) schemaName schemaType + + inHeadOfPath :: Applicative g => QTableName f a -> QTableName g a + inHeadOfPath (QTableName tInfo _ tableName) = + let db = fmap (const tInfo) currentDb + QSchemaName _ None schemaName schemaType = head path + fqsn = QSchemaName tInfo (pure db) schemaName schemaType + in QTableName tInfo (pure fqsn) tableName + + -- TODO session schemas should have the name set to the session ID + catalogResolveSchemaName :: forall a . OQSchemaName a -> CatalogObjectResolver a (FQSchemaName a) + catalogResolveSchemaName (QSchemaName sInfo (Just db) schemaName schemaType) = + pure $ QSchemaName sInfo (pure db) schemaName schemaType + catalogResolveSchemaName oqsn@(QSchemaName _ Nothing _ _) = + pure $ inCurrentDb oqsn + + catalogHasDatabase databaseName = + case HMS.member (void databaseName) catalog of + False -> DoesNotExist + True -> Exists + + catalogHasSchema schemaName = + case HMS.lookup currentDb catalog of + Just db -> case HMS.member (void schemaName) db of + False -> DoesNotExist + True -> Exists + Nothing -> DoesNotExist + + catalogResolveTableRefHelper oqtn@(QTableName tInfo (Just oqsn@(QSchemaName sInfo (Just db@(DatabaseName _ _)) schemaName schemaType)) tableName) = do + let fqsn = QSchemaName sInfo (pure db) schemaName schemaType + fqtn = QTableName tInfo (pure fqsn) tableName + defaultTableRef = RTableRef fqtn defaultSchemaMember + missingD = Left $ MissingDatabase db + missingS = Left $ MissingSchema oqsn + missingT = Left $ MissingTable oqtn + tableRefResolved = Right $ TableRefResolved oqtn defaultTableRef + default' = WithColumns defaultTableRef [(Just defaultTableRef, [])] + + case HMS.lookup (void db) catalog of + Nothing -> tell [missingD, missingS, missingT, tableRefResolved] >> pure default' + Just database -> case HMS.lookup (QSchemaName () None schemaName schemaType) database of + Nothing -> tell [missingS, missingT, tableRefResolved] >> pure default' + Just schema -> do + case HMS.lookup (QTableName () None tableName) schema of + Nothing -> tell [missingT, tableRefResolved] >> pure default' + Just table@SchemaMember{..} -> do + let makeRColumnRef (QColumnName () None name) = RColumnRef $ QColumnName tInfo (pure fqtn) name + tableRef = RTableRef fqtn table + tell [Right $ TableRefResolved oqtn tableRef] + pure $ WithColumns tableRef [(Just tableRef, map makeRColumnRef columnsList)] + + catalogResolveTableRefHelper _ = error "only call catalogResolveTableRefHelper with fully qualified table name" + + catalogResolveTableRef _ oqtn@(QTableName _ (Just (QSchemaName _ (Just (DatabaseName _ _)) _ _)) _) = + catalogResolveTableRefHelper oqtn + + catalogResolveTableRef _ (QTableName tInfo (Just oqsn@(QSchemaName _ Nothing _ _)) tableName) = + catalogResolveTableRefHelper $ QTableName tInfo (Just $ inCurrentDb oqsn) tableName + + catalogResolveTableRef boundCTEs oqtn@(QTableName tInfo Nothing tableName) = do + case filter (resolvedTableHasName oqtn . fst) $ map (first RTableAlias) boundCTEs of + ts@((t, _):rest) -> do + if (null rest) + then tell [ Right $ TableRefResolved oqtn t ] + else tell [ Left $ AmbiguousTable oqtn + , Right $ TableRefDefaulted oqtn t + ] + let ts' = map (first Just) ts + pure $ WithColumns t ts' + [] -> do + let getTableFromSchema uqsn@(QSchemaName _ None schemaName schemaType) = do + db <- HMS.lookup currentDb catalog + schema <- HMS.lookup uqsn db + table@SchemaMember{..} <- HMS.lookup (QTableName () None tableName) schema + let db' = fmap (const tInfo) currentDb + fqsn = QSchemaName tInfo (pure db') schemaName schemaType + fqtn = QTableName tInfo (pure fqsn) tableName + makeRColumnRef (QColumnName () None name) = RColumnRef $ QColumnName tInfo (pure fqtn) name + tableRef = RTableRef fqtn table + pure $ WithColumns tableRef [(Just tableRef, map makeRColumnRef columnsList)] + + case mapMaybe getTableFromSchema path of + table@(WithColumns tableRef _):_ -> do + tell [Right $ TableRefResolved oqtn tableRef] + pure table + [] -> do + let tableRef = RTableRef (inHeadOfPath oqtn) defaultSchemaMember + tell [ Left $ MissingTable oqtn + , Right $ TableRefDefaulted oqtn tableRef + ] + -- TODO: deal with columns + pure $ WithColumns tableRef [(Just tableRef, [])] + + catalogResolveCreateSchemaName oqsn = do + fqsn@(QSchemaName _ (Identity db) schemaName schemaType) <- case schemaNameType oqsn of + NormalSchema -> catalogResolveSchemaName oqsn + SessionSchema -> error "can't create the session schema" + existence <- case HMS.lookup (void db) catalog of + Nothing -> tell [Left $ MissingDatabase db] >> pure DoesNotExist + Just database -> if HMS.member (QSchemaName () None schemaName schemaType) database + then pure Exists + else pure DoesNotExist + let rcsn = RCreateSchemaName fqsn existence + tell [Right $ CreateSchemaNameResolved oqsn rcsn] + pure rcsn + + catalogResolveCreateTableName name = do + oqtn@(QTableName tInfo (Just oqsn@(QSchemaName sInfo (Just db) schemaName schemaType)) tableName) <- + case name of + oqtn@(QTableName _ Nothing _) -> pure $ inHeadOfPath oqtn + (QTableName tInfo (Just oqsn@(QSchemaName _ Nothing _ _)) tableName) -> pure $ QTableName tInfo (pure $ inCurrentDb oqsn) tableName + _ -> pure name + + let missingD = Left $ MissingDatabase db + missingS = Left $ MissingSchema oqsn + existence <- case HMS.lookup (void db) catalog of + Nothing -> tell [missingD, missingS] >> pure DoesNotExist + Just database -> case HMS.lookup (QSchemaName () None schemaName schemaType) database of + Nothing -> tell [missingS] >> pure DoesNotExist + Just schema -> if HMS.member (QTableName () None tableName) schema + then pure Exists + else pure DoesNotExist + + let fqsn = QSchemaName sInfo (pure db) schemaName schemaType + rctn = RCreateTableName (QTableName tInfo (pure fqsn) tableName) existence + tell [Right $ CreateTableNameResolved oqtn rctn] + + pure rctn + + catalogResolveColumnName :: forall a . [(Maybe (RTableRef a), [RColumnRef a])] -> OQColumnName a -> CatalogObjectResolver a (RColumnRef a) + catalogResolveColumnName boundColumns oqcn@(QColumnName cInfo (Just oqtn@(QTableName tInfo (Just oqsn@(QSchemaName sInfo (Just db) schema schemaType)) table)) column) = do + case filter (maybe False (resolvedTableHasDatabase db && resolvedTableHasSchema oqsn && resolvedTableHasName oqtn) . fst) boundColumns of + [] -> tell [Left $ UnintroducedTable oqtn] + _:_:_ -> tell [Left $ AmbiguousTable oqtn] + [(_, columns)] -> + case filter (resolvedColumnHasName oqcn) columns of + [] -> tell [Left $ MissingColumn oqcn] + [_] -> pure () + _ -> tell [Left $ AmbiguousColumn oqcn] + let columnRef = RColumnRef $ QColumnName cInfo (pure $ QTableName tInfo (pure $ QSchemaName sInfo (pure db) schema schemaType) table) column + tell [Right $ ColumnRefResolved oqcn columnRef] + pure columnRef + + catalogResolveColumnName boundColumns oqcn@(QColumnName cInfo (Just oqtn@(QTableName tInfo (Just oqsn@(QSchemaName sInfo Nothing schema schemaType)) table)) column) = do + let filtered = filter (maybe False (resolvedTableHasSchema oqsn && resolvedTableHasName oqtn) . fst) boundColumns + fqtnDefault = QTableName tInfo (Identity $ inCurrentDb oqsn) table + fqtn <- case filtered of + [] -> tell [Left $ UnintroducedTable oqtn] >> pure fqtnDefault + _:_:_ -> tell [Left $ AmbiguousTable oqtn] >> pure fqtnDefault + [(table', columns)] -> do + let Just (RTableRef (QTableName _ (Identity (QSchemaName _ (Identity (DatabaseName _ db)) _ _)) _) _) = table' -- this pattern match shouldn't fail: + -- the `maybe False` prevents Nothings, and the `resolvedTableHasSchema` prevents RTableAliases + oqcnKnownDb = QColumnName cInfo (Just $ QTableName tInfo (Just $ QSchemaName sInfo (Just $ DatabaseName cInfo db) schema schemaType) table) column + fqtnKnownDb = QTableName tInfo (Identity $ QSchemaName sInfo (Identity $ DatabaseName cInfo db) schema schemaType) table + case filter (resolvedColumnHasName oqcn) columns of + [] -> tell [Left $ MissingColumn oqcnKnownDb] >> pure fqtnKnownDb + [_] -> pure fqtnKnownDb + _ -> tell [Left $ AmbiguousColumn oqcnKnownDb] >> pure fqtnKnownDb + + let columnRef = RColumnRef $ QColumnName cInfo (pure fqtn) column + tell [Right $ ColumnRefResolved oqcn columnRef] + pure columnRef + + catalogResolveColumnName boundColumns oqcn@(QColumnName cInfo (Just oqtn@(QTableName tInfo Nothing table)) column) = do + let setInfo :: Functor f => f a -> f a + setInfo = fmap (const cInfo) + + case [ (t, cs) | (mt, cs) <- boundColumns, t <- maybeToList mt, resolvedTableHasName oqtn t ] of + [] -> do + let c = RColumnRef $ QColumnName cInfo (pure $ QTableName tInfo (pure $ unknownSchema tInfo) table) column + tell [ Left $ UnintroducedTable oqtn + , Right $ ColumnRefDefaulted oqcn c + ] + pure c + [(table', columns)] -> do + case filter (resolvedColumnHasName oqcn) columns of + [] -> case table' of + RTableAlias _ -> do + let c = RColumnRef $ QColumnName cInfo (pure $ QTableName tInfo (pure $ unknownSchema tInfo) table) column + tell [ Left $ MissingColumn oqcn + , Right $ ColumnRefDefaulted oqcn c + ] + pure c + RTableRef fqtn@(QTableName _ (Identity (QSchemaName _ (Identity (DatabaseName _ db)) schema schemaType)) _) _ -> do + let c = RColumnRef $ QColumnName cInfo (pure $ setInfo fqtn) column + tell [ Left $ MissingColumn $ QColumnName cInfo (Just $ QTableName tInfo (Just $ QSchemaName cInfo (Just $ DatabaseName cInfo db) schema schemaType) table) column + , Right $ ColumnRefResolved oqcn c] + pure c + c:rest -> do + let c' = setInfo c + if (null rest) + then tell [Right $ ColumnRefResolved oqcn c'] + else tell [ Left $ AmbiguousColumn oqcn + , Right $ ColumnRefDefaulted oqcn c' + ] + pure c' + tables -> do + tell [Left $ AmbiguousTable oqtn] + case filter (resolvedColumnHasName oqcn) $ snd =<< tables of + [] -> do + let c = RColumnRef $ QColumnName cInfo (pure $ QTableName tInfo (pure $ unknownSchema tInfo) table) column + tell [ Left $ MissingColumn oqcn + , Right $ ColumnRefDefaulted oqcn c + ] + pure c + c:rest -> do + let c' = setInfo c + if (null rest) + then tell [Right $ ColumnRefResolved oqcn c'] + else tell [ Left $ AmbiguousColumn oqcn + , Right $ ColumnRefDefaulted oqcn c' + ] + pure c' + + catalogResolveColumnName boundColumns oqcn@(QColumnName cInfo Nothing column) = do + let columns = snd =<< boundColumns + case filter (resolvedColumnHasName oqcn) columns of + [] -> do + let table = + case boundColumns of + [(Just (RTableRef t _), _)] -> t + _ -> unknownTable cInfo + c = RColumnRef $ QColumnName cInfo (pure table) column + tell [ Left $ MissingColumn oqcn + , Right $ ColumnRefDefaulted oqcn c + ] + pure c + c:rest -> do + let c' = fmap (const cInfo) c + if (null rest) + then tell [ Right $ ColumnRefResolved oqcn c' ] + else tell [ Left $ AmbiguousColumn oqcn + , Right $ ColumnRefDefaulted oqcn c' + ] + pure c' + + catalogHasTable tableName = + let getTableFromSchema uqsn = do + database <- HMS.lookup currentDb catalog + schema <- HMS.lookup uqsn database + pure $ HMS.member tableName schema + in case any id $ mapMaybe getTableFromSchema path of + False -> DoesNotExist + True -> Exists + + overCatalogMap f = + let (cm, extra) = f catalog + in seq cm $ (makeDefaultingCatalog cm path currentDb, extra) + + catalogMap = catalog + + catalogWithPath newPath = makeDefaultingCatalog catalog newPath currentDb + + catalogWithDatabase = makeDefaultingCatalog catalog path diff --git a/src/Database/Sql/Type/Scope.hs b/src/Database/Sql/Type/Scope.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Type/Scope.hs @@ -0,0 +1,369 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} + +module Database.Sql.Type.Scope where + +import Database.Sql.Type.Names +import Database.Sql.Type.TableProps +import Database.Sql.Type.Unused +import Database.Sql.Type.Query + +import Control.Monad.Identity +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Except +import Control.Monad.Writer + +import Data.Aeson +import qualified Data.HashMap.Strict as HMS +import Data.HashMap.Strict (HashMap) + +import Data.List (subsequences) +import Data.Hashable (Hashable) + +import Test.QuickCheck + +import Data.Data (Data) +import GHC.Generics (Generic) + + +-- | A ColumnSet records the table-bindings (if any) of columns. +-- +-- Can be used to represent columns that are in ambient scope, +-- which can be referenced, based on arcane and dialect specific rules. +-- The fst component will be Nothing for collections of column +-- aliases bound in a containing select statement (which thus have no +-- corresponding Tablish), or for subqueries/lateral views with no table alias. +-- +-- Can also be used to represent "what stars expand into". + +type ColumnSet a = [(Maybe (RTableRef a), [RColumnRef a])] + + +data Bindings a = Bindings + { boundCTEs :: [(TableAlias a, [RColumnRef a])] + , boundColumns :: ColumnSet a + } + +emptyBindings :: Bindings a +emptyBindings = Bindings [] [] + +data SelectScope a = SelectScope + { bindForHaving :: forall r m . MonadReader (ResolverInfo a) m => m r -> m r + , bindForWhere :: forall r m . MonadReader (ResolverInfo a) m => m r -> m r + , bindForOrder :: forall r m . MonadReader (ResolverInfo a) m => m r -> m r + , bindForGroup :: forall r m . MonadReader (ResolverInfo a) m => m r -> m r + , bindForNamedWindow :: forall r m . MonadReader (ResolverInfo a) m => m r -> m r + } + +type FromColumns a = ColumnSet a +type SelectionAliases a = [RColumnRef a] + +data ResolverInfo a = ResolverInfo + { catalog :: Catalog + , onCTECollision :: forall x . (x -> x) -> (x -> x) + , bindings :: Bindings a + , selectScope :: FromColumns a -> SelectionAliases a -> SelectScope a + , lcolumnsAreVisibleInLateralViews :: Bool + } + +mapBindings :: (Bindings a -> Bindings a) -> ResolverInfo a -> ResolverInfo a +mapBindings f ResolverInfo{..} = ResolverInfo{bindings = f bindings, ..} + + +bindColumns :: MonadReader (ResolverInfo a) m => ColumnSet a -> m r -> m r +bindColumns columns = local (mapBindings $ \ Bindings{..} -> Bindings{boundColumns = columns ++ boundColumns, ..}) + + +bindFromColumns :: MonadReader (ResolverInfo a) m => FromColumns a -> m r -> m r +bindFromColumns = bindColumns + +bindAliasedColumns :: MonadReader (ResolverInfo a) m => SelectionAliases a -> m r -> m r +bindAliasedColumns selectionAliases = bindColumns [(Nothing, selectionAliases)] + +bindBothColumns :: MonadReader (ResolverInfo a) m => FromColumns a -> SelectionAliases a -> m r -> m r +bindBothColumns fromColumns selectionAliases = bindColumns $ (Nothing, onlyNewAliases selectionAliases) : fromColumns + where + onlyNewAliases = filter $ \case + alias@(RColumnAlias _) -> not $ inFromColumns alias + RColumnRef _ -> False + + inFromColumns alias = + let alias' = void alias + cols = map void (snd =<< fromColumns) + in alias' `elem` cols + +data RawNames +deriving instance Data RawNames +instance Resolution RawNames where + type TableRef RawNames = OQTableName + type TableName RawNames = OQTableName + type CreateTableName RawNames = OQTableName + type DropTableName RawNames = OQTableName + type SchemaName RawNames = OQSchemaName + type CreateSchemaName RawNames = OQSchemaName + type ColumnRef RawNames = OQColumnName + type NaturalColumns RawNames = Unused + type UsingColumn RawNames = UQColumnName + type StarReferents RawNames = Unused + type PositionExpr RawNames = Unused + type ComposedQueryColumns RawNames = Unused + +data ResolvedNames +deriving instance Data ResolvedNames +newtype StarColumnNames a = StarColumnNames [RColumnRef a] + deriving (Generic, Data, Eq, Ord, Show, Functor) + +newtype ColumnAliasList a = ColumnAliasList [ColumnAlias a] + deriving (Generic, Data, Eq, Ord, Show, Functor) + +instance Resolution ResolvedNames where + type TableRef ResolvedNames = RTableRef + type TableName ResolvedNames = RTableName + type CreateTableName ResolvedNames = RCreateTableName + type DropTableName ResolvedNames = RDropTableName + type SchemaName ResolvedNames = FQSchemaName + type CreateSchemaName ResolvedNames = RCreateSchemaName + type ColumnRef ResolvedNames = RColumnRef + type NaturalColumns ResolvedNames = RNaturalColumns + type UsingColumn ResolvedNames = RUsingColumn + type StarReferents ResolvedNames = StarColumnNames + type PositionExpr ResolvedNames = Expr ResolvedNames + type ComposedQueryColumns ResolvedNames = ColumnAliasList + +type Resolver r a = + StateT Integer -- column alias generation (counts down from -1, unlike parse phase) + (ReaderT (ResolverInfo a) + (CatalogObjectResolver a)) + (r a) + + +data SchemaMember = SchemaMember + { tableType :: TableType + , persistence :: Persistence () + , columnsList :: [UQColumnName ()] + , viewQuery :: Maybe (Query ResolvedNames ()) -- this will always be Nothing for tables + } deriving (Generic, Data, Eq, Ord, Show) + +persistentTable :: [UQColumnName ()] -> SchemaMember +persistentTable cols = SchemaMember Table Persistent cols Nothing + + +type SchemaMap = HashMap (UQTableName ()) SchemaMember +type DatabaseMap = HashMap (UQSchemaName ()) SchemaMap +type CatalogMap = HashMap (DatabaseName ()) DatabaseMap +type Path = [UQSchemaName ()] +type CurrentDatabase = DatabaseName () + +data Catalog = Catalog + { catalogResolveSchemaName :: forall a . OQSchemaName a -> CatalogObjectResolver a (FQSchemaName a) + , catalogResolveTableName :: forall a . OQTableName a -> CatalogObjectResolver a (RTableName a) + , catalogHasDatabase :: DatabaseName () -> Existence + , catalogHasSchema :: UQSchemaName () -> Existence + , catalogHasTable :: UQTableName () -> Existence -- | nb DoesNotExist does not imply that we can't resolve to this name (defaulting) + , catalogResolveTableRef :: forall a . [(TableAlias a, [RColumnRef a])] -> OQTableName a -> CatalogObjectResolver a (WithColumns RTableRef a) + , catalogResolveCreateSchemaName :: forall a . OQSchemaName a -> CatalogObjectResolver a (RCreateSchemaName a) + , catalogResolveCreateTableName :: forall a . OQTableName a -> CatalogObjectResolver a (RCreateTableName a) + , catalogResolveColumnName :: forall a . [(Maybe (RTableRef a), [RColumnRef a])] -> OQColumnName a -> CatalogObjectResolver a (RColumnRef a) + , overCatalogMap :: forall a . (CatalogMap -> (CatalogMap, a)) -> (Catalog, a) + , catalogMap :: !CatalogMap + , catalogWithPath :: Path -> Catalog + , catalogWithDatabase :: CurrentDatabase -> Catalog + } + +instance Eq Catalog where + x == y = catalogMap x == catalogMap y + +instance Show Catalog where + show = show . catalogMap + + +-- returned by methods in Catalog +type CatalogObjectResolver a = + (ExceptT (ResolutionError a) -- error + (Writer [Either (ResolutionError a) (ResolutionSuccess a)])) -- warnings and successes + +data ResolutionError a + = MissingDatabase (DatabaseName a) + | MissingSchema (OQSchemaName a) + | MissingTable (OQTableName a) + | AmbiguousTable (OQTableName a) + | MissingColumn (OQColumnName a) + | AmbiguousColumn (OQColumnName a) + | UnintroducedTable (OQTableName a) + | UnexpectedTable (FQTableName a) + | UnexpectedSchema (FQSchemaName a) + | BadPositionalReference a Int + deriving (Eq, Show, Functor) + +data ResolutionSuccess a + = TableNameResolved (OQTableName a) (RTableName a) + | TableNameDefaulted (OQTableName a) (RTableName a) + | CreateTableNameResolved (OQTableName a) (RCreateTableName a) + | CreateSchemaNameResolved (OQSchemaName a) (RCreateSchemaName a) + | TableRefResolved (OQTableName a) (RTableRef a) + | TableRefDefaulted (OQTableName a) (RTableRef a) + | ColumnRefResolved (OQColumnName a) (RColumnRef a) + | ColumnRefDefaulted (OQColumnName a) (RColumnRef a) + deriving (Eq, Show, Functor) + +isGuess :: ResolutionSuccess a -> Bool +isGuess (TableNameResolved _ _) = False +isGuess (TableNameDefaulted _ _) = True +isGuess (CreateTableNameResolved _ _) = False +isGuess (CreateSchemaNameResolved _ _) = False +isGuess (TableRefResolved _ _) = False +isGuess (TableRefDefaulted _ _) = True +isGuess (ColumnRefResolved _ _) = False +isGuess (ColumnRefDefaulted _ _) = True + +isCertain :: ResolutionSuccess a -> Bool +isCertain = not . isGuess + + +data WithColumns r a = WithColumns + { withColumnsValue :: r a + , withColumnsColumns :: ColumnSet a + } + +data WithColumnsAndOrders r a = WithColumnsAndOrders (r a) (ColumnSet a) [Order ResolvedNames a] + +-- R for "resolved" +data RTableRef a + = RTableRef (FQTableName a) SchemaMember + | RTableAlias (TableAlias a) + deriving (Generic, Data, Show, Eq, Ord, Functor, Foldable, Traversable) + +resolvedTableHasName :: QTableName f a -> RTableRef a -> Bool +resolvedTableHasName (QTableName _ _ name) (RTableAlias (TableAlias _ name' _)) = name' == name +resolvedTableHasName (QTableName _ _ name) (RTableRef (QTableName _ _ name') _) = name' == name + +resolvedTableHasSchema :: QSchemaName f a -> RTableRef a -> Bool +resolvedTableHasSchema _ (RTableAlias _) = False +resolvedTableHasSchema (QSchemaName _ _ name schemaType) (RTableRef (QTableName _ (Identity (QSchemaName _ _ name' schemaType')) _) _) = + name == name' && schemaType == schemaType' + +resolvedTableHasDatabase :: DatabaseName a -> RTableRef a -> Bool +resolvedTableHasDatabase _ (RTableAlias _) = False +resolvedTableHasDatabase (DatabaseName _ name) (RTableRef (QTableName _ (Identity (QSchemaName _ (Identity (DatabaseName _ name')) _ _)) _) _) = name' == name + + +data RTableName a = RTableName (FQTableName a) SchemaMember + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + +data RDropTableName a + = RDropExistingTableName (FQTableName a) SchemaMember + | RDropMissingTableName (OQTableName a) + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + +data RCreateTableName a = RCreateTableName (FQTableName a) Existence + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + +data RCreateSchemaName a = RCreateSchemaName (FQSchemaName a) Existence + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + + +instance Arbitrary SchemaMember where + arbitrary = do + tableType <- arbitrary + persistence <- arbitrary + columnsList <- arbitrary + viewQuery <- pure Nothing -- TODO holding off til we have arbitrary queries + pure SchemaMember{..} + shrink (SchemaMember type_ persistence cols _) = + [ SchemaMember type_' persistence' cols' Nothing | -- TODO same + (type_', persistence', cols') <- shrink (type_, persistence, cols) ] + +shrinkHashMap :: (Eq k, Hashable k) => forall v. HashMap k v -> [HashMap k v] +shrinkHashMap = map HMS.fromList . subsequences . HMS.toList + +instance Arbitrary SchemaMap where + arbitrary = HMS.fromList <$> arbitrary + shrink = shrinkHashMap + +instance Arbitrary DatabaseMap where + arbitrary = HMS.fromList <$> arbitrary + shrink = shrinkHashMap + +instance Arbitrary CatalogMap where + arbitrary = HMS.fromList <$> arbitrary + shrink = shrinkHashMap + +instance ToJSON a => ToJSON (RTableRef a) where + toJSON (RTableRef fqtn _) = object + [ "tag" .= String "RTableRef" + , "fqtn" .= fqtn + ] + toJSON (RTableAlias alias) = object + [ "tag" .= String "RTableAlias" + , "alias" .= alias + ] + +instance ToJSON a => ToJSON (RTableName a) where + toJSON (RTableName fqtn _) = object + [ "tag" .= String "RTableName" + , "fqtn" .= fqtn + ] + +instance ToJSON a => ToJSON (RDropTableName a) where + toJSON (RDropExistingTableName fqtn _) = object + [ "tag" .= String "RDropExistingTableName" + , "fqtn" .= fqtn + ] + toJSON (RDropMissingTableName oqtn) = object + [ "tag" .= String "RDropMissingTableName" + , "oqtn" .= oqtn + ] + +instance ToJSON a => ToJSON (RCreateTableName a) where + toJSON (RCreateTableName fqtn existence) = object + [ "tag" .= String "RCreateTableName" + , "fqtn" .= fqtn + , "existence" .= existence + ] + +instance ToJSON a => ToJSON (RCreateSchemaName a) where + toJSON (RCreateSchemaName fqsn existence) = object + [ "tag" .= String "RCreateSchemaName" + , "fqsn" .= fqsn + , "existence" .= existence + ] + +instance ToJSON a => ToJSON (StarColumnNames a) where + toJSON (StarColumnNames cols) = object + [ "tag" .= String "StarColumnNames" + , "cols" .= cols + ] + +instance ToJSON a => ToJSON (ColumnAliasList a) where + toJSON (ColumnAliasList cols) = object + [ "tag" .= String "ColumnAliasList" + , "cols" .= cols + ] diff --git a/src/Database/Sql/Type/TableProps.hs b/src/Database/Sql/Type/TableProps.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Type/TableProps.hs @@ -0,0 +1,147 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} + +module Database.Sql.Type.TableProps where + +import Data.Aeson + +import Test.QuickCheck + +import Data.Data (Data) +import GHC.Generics (Generic) + + +-- nb (Vertica): +-- both global and local temporary tables have type TemporaryTable +-- as data flow respects session boundaries; they are distinguished +-- by the fact that local temporary tables live in v_temp_schema + +data Persistence a + = Temporary a + | Persistent + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + +data Externality a + = External a + | Internal + deriving (Generic, Data, Eq, Ord, Show, Functor, Foldable, Traversable) + +data Existence + = Exists + | DoesNotExist + deriving (Generic, Data, Eq, Ord, Show) + +data TableType + = Table + | View + deriving (Generic, Data, Eq, Ord, Show) + + +instance ToJSON a => ToJSON (Persistence a) where + toJSON Persistent = object + [ "tag" .= String "Persistent" + ] + + toJSON (Temporary info) = object + [ "tag" .= String "Temporary" + , "info" .= info + ] + +instance ToJSON a => ToJSON (Externality a) where + toJSON (External a) = object + [ "tag" .= String "External" + , "info" .= a + ] + + toJSON Internal = object ["tag" .= String "Internal"] + +instance ToJSON Existence where + toJSON Exists = object ["tag" .= String "Exists"] + toJSON DoesNotExist = object ["tag" .= String "DoesNotExist"] + +instance ToJSON TableType where + toJSON Table = object ["tag" .= String "Table"] + toJSON View = object ["tag" .= String "View"] + + +instance FromJSON a => FromJSON (Persistence a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "Persistent" -> pure Persistent + String "Temporary" -> Temporary <$> o .: "info" + _ -> fail "unrecognized tag on Persistence object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as Persistence:" + , show v + ] + +instance FromJSON a => FromJSON (Externality a) where + parseJSON (Object o) = o .: "tag" >>= \case + String "External" -> External <$> o .: "info" + String "Internal" -> pure Internal + _ -> fail "unrecognized tag on Externality object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as Externality:" + , show v + ] + +instance FromJSON Existence where + parseJSON (Object o) = o .: "tag" >>= \case + String "Exists" -> pure Exists + String "DoesNotExist" -> pure DoesNotExist + _ -> fail "unrecognized tag on Existence object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as Existence:" + , show v + ] + +instance FromJSON TableType where + parseJSON (Object o) = o .: "tag" >>= \case + String "Table" -> pure Table + String "View" -> pure View + _ -> fail "unrecognized tag on TableType object" + + parseJSON v = fail $ unwords + [ "don't know how to parse as TableType:" + , show v + ] + + +instance Arbitrary a => Arbitrary (Persistence a) where + arbitrary = oneof [ Temporary <$> arbitrary + , pure Persistent + ] + shrink (Temporary info) = + [ Persistent ] ++ + [ Temporary info' | info' <- shrink info ] + shrink Persistent = [] + +instance Arbitrary TableType where + arbitrary = oneof [ pure Table + , pure View + ] + shrink Table = [] + shrink View = [] diff --git a/src/Database/Sql/Type/Unused.hs b/src/Database/Sql/Type/Unused.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Type/Unused.hs @@ -0,0 +1,51 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} + +module Database.Sql.Type.Unused where + +import Data.Aeson +import Data.Data (Data) +import GHC.Generics (Generic) +import Test.QuickCheck + +data Unused a = Unused + deriving (Data, Generic, Eq, Ord, Show, Functor, Foldable, Traversable) + +instance ToJSON (Unused a) where + toJSON Unused = object [("tag", "Unused")] + +instance FromJSON (Unused a) where + parseJSON (Object o) = do + String "Unused" <- o .: "tag" + return Unused + + parseJSON v = fail $ unwords + [ "don't know how to parse as Unused:" + , show v + ] + +instance Arbitrary (Unused a) where + arbitrary = pure Unused diff --git a/src/Database/Sql/Util/Columns.hs b/src/Database/Sql/Util/Columns.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Util/Columns.hs @@ -0,0 +1,505 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +{-# LANGUAGE FlexibleContexts #-} +module Database.Sql.Util.Columns ( Clause, ColumnAccess + , HasColumns(..), getColumns + , bindClause, clauseObservation + ) where + +import Data.Either +import Data.Map (Map) +import qualified Data.Map as M +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text.Lazy (Text) + +import Control.Monad.Identity +import Control.Monad.Reader +import Control.Monad.Writer + +import Database.Sql.Type + + +type Clause = Text -- SELECT, WHERE, GROUPBY, etc... for nested clauses, + -- report the innermost clause. +type ColumnAccess = (FQCN, Clause) + +-- To support dereferencing of column aliases, employ the following algorithm: +-- +-- Traverse the resolved AST to write two maps. +-- +-- 1. "alias map" which is Map ColumnAlias (Set RColumnRef) +-- +-- To populate the alias map, emit at the site of every alias definition, +-- i.e. for every SelectExpr. The key is always the ColumnAlias. The value is +-- the set of columns/aliases referenced in the expr. +-- +-- 2. "clause map" which is Map RColumnRef (Set Clause) +-- +-- To populate the clause map, emit the current-clause for every RColumnRef. +-- +-- Then at the end, stitch the results together by walking over the clause +-- map. If the key is an RColumnRef/FQColumnName, emit the column, for every +-- clause. If the key is an RColumnAlias/ColumnAlias, look it up recursively +-- into the alias map until everything is an RColumnRef/FQColumnName, and then +-- emit every column for every clause. +type AliasInfo = (ColumnAliasId, Set (RColumnRef ())) +type AliasMap = Map ColumnAliasId (Set (RColumnRef ())) +type ClauseInfo = (RColumnRef (), Set Clause) +type ClauseMap = Map (RColumnRef ()) (Set Clause) +type Observation = Either AliasInfo ClauseInfo -- Stuff both info-types into an Either, so we only traverse the AST once. + +aliasObservation :: ColumnAlias a -> Set (RColumnRef b) -> Observation +aliasObservation (ColumnAlias _ _ cid) refs = Left (cid, S.map void refs) + +clauseObservation :: RColumnRef a -> Clause -> Observation +clauseObservation ref clause = Right (void ref, S.singleton clause) + +toAliasMap :: [Observation] -> AliasMap +toAliasMap = M.fromListWith S.union . lefts + +toClauseMap :: [Observation] -> ClauseMap +toClauseMap = M.fromListWith S.union . rights + +type Observer = ReaderT Clause (Writer [Observation]) () + +class HasColumns q where + goColumns :: q -> Observer + +baseClause :: Clause +baseClause = "BASE" + +bindClause :: MonadReader Clause m => Clause -> m r -> m r +bindClause clause = local (const clause) + +getColumns :: HasColumns q => q -> Set ColumnAccess +getColumns q = foldMap columnAccesses $ M.toList clauseMap + where + observations = execWriter $ runReaderT (goColumns q) baseClause + aliasMap = toAliasMap observations + clauseMap = toClauseMap observations + + columnAccesses :: ClauseInfo -> Set ColumnAccess + columnAccesses (ref, clauses) = + S.fromList [(fqcn, clause) | fqcn <- S.toList $ getAllFQCNs ref + , clause <- S.toList clauses] + + getAllFQCNs :: RColumnRef () -> Set FQCN + getAllFQCNs ref = recur [ref] [] S.empty + + --recur :: refsToVisit -> allRefsVisited -> fqcnsVisited -> all the fqcns! + recur :: [RColumnRef ()] -> [RColumnRef ()] -> Set FQCN -> Set FQCN + recur [] _ fqcns = fqcns + recur (ref:refs) visited fqcns = + if ref `elem` visited + then recur refs visited fqcns + else case ref of + RColumnRef fqcn -> recur refs (ref:visited) (S.insert (fqcnToFQCN fqcn) fqcns) + RColumnAlias (ColumnAlias _ _ cid) -> case M.lookup cid aliasMap of + Nothing -> error $ "column alias missing from aliasMap: " ++ show cid + Just moarRefs -> recur (refs ++ S.toList moarRefs) (ref:visited) fqcns + + +instance HasColumns a => HasColumns (NonEmpty a) where + goColumns ne = mapM_ goColumns ne + +instance HasColumns a => HasColumns (Maybe a) where + goColumns Nothing = return () + goColumns (Just a) = goColumns a + + +instance HasColumns (Statement d ResolvedNames a) where + goColumns (QueryStmt q) = goColumns q + goColumns (InsertStmt i) = goColumns i + goColumns (UpdateStmt u) = goColumns u + goColumns (DeleteStmt d) = goColumns d + goColumns (TruncateStmt _) = return () + goColumns (CreateTableStmt c) = goColumns c + goColumns (AlterTableStmt a) = goColumns a + goColumns (DropTableStmt _) = return () + goColumns (CreateViewStmt c) = goColumns c + goColumns (DropViewStmt _) = return () + goColumns (CreateSchemaStmt _) = return () + goColumns (GrantStmt _) = return () + goColumns (RevokeStmt _) = return () + goColumns (BeginStmt _) = return () + goColumns (CommitStmt _) = return () + goColumns (RollbackStmt _) = return () + goColumns (ExplainStmt _ s) = goColumns s + goColumns (EmptyStmt _) = return () + +instance HasColumns (Query ResolvedNames a) where + goColumns (QuerySelect _ select) = goColumns select + goColumns (QueryExcept _ _ lhs rhs) = mapM_ goColumns [lhs, rhs] + goColumns (QueryUnion _ _ _ lhs rhs) = mapM_ goColumns [lhs, rhs] + goColumns (QueryIntersect _ _ lhs rhs) = mapM_ goColumns [lhs, rhs] + goColumns (QueryWith _ ctes query) = goColumns query >> mapM_ goColumns ctes + goColumns (QueryOrder _ orders query) = sequence_ + [ bindClause "ORDER" $ mapM_ (handleOrderTopLevel query) orders + , goColumns query + ] + goColumns (QueryLimit _ _ query) = goColumns query + goColumns (QueryOffset _ _ query) = goColumns query + +handleOrderTopLevel :: Query ResolvedNames a -> Order ResolvedNames a -> Observer +handleOrderTopLevel query (Order _ posOrExpr _ _) = case posOrExpr of + PositionOrExprPosition _ pos _ -> handlePos pos query + PositionOrExprExpr expr -> goColumns expr + +handlePos :: Int -> Query ResolvedNames a -> Observer +handlePos pos (QuerySelect _ select) = do + let selections = selectColumnsList $ selectCols select + starsConcatted = selections >>= (\case + SelectStar _ _ (StarColumnNames refs) -> refs + SelectExpr _ cAliases _ -> map RColumnAlias cAliases + ) + posRef = starsConcatted !! (pos - 1) -- SQL is 1 indexed, Haskell is 0 indexed + clause <- ask + tell $ [clauseObservation posRef clause] +handlePos pos (QueryExcept _ _ lhs rhs) = handlePos pos lhs >> handlePos pos rhs +handlePos pos (QueryUnion _ _ _ lhs rhs) = handlePos pos lhs >> handlePos pos rhs +handlePos pos (QueryIntersect _ _ lhs rhs) = handlePos pos lhs >> handlePos pos rhs +handlePos pos (QueryWith _ _ q) = handlePos pos q +handlePos pos (QueryOrder _ _ q) = handlePos pos q +handlePos pos (QueryLimit _ _ q) = handlePos pos q +handlePos pos (QueryOffset _ _ q) = handlePos pos q + + +instance HasColumns (CTE ResolvedNames a) where + goColumns CTE{..} = do + -- recurse to emit clause infos + goColumns cteQuery + + -- also emit alias infos + case cteColumns of + [] -> return () + aliases -> tell $ zipWith aliasObservation aliases (queryColumnDeps cteQuery) + +-- for every column returned by the query, what columns did it depend on? +queryColumnDeps :: Query ResolvedNames a -> [Set (RColumnRef ())] +queryColumnDeps query = + -- Get the entire query's aliasMap ahead of time: if a QueryWith defines + -- aliases via the CTEs, those aliases can be selected in the main query! + let aliasMap = toAliasMap $ execWriter $ runReaderT (goColumns query) baseClause + in queryColumnDepsHelper aliasMap query + where + queryColumnDepsHelper :: AliasMap -> Query ResolvedNames a -> [Set (RColumnRef ())] + queryColumnDepsHelper aliasMap (QuerySelect _ s) = + let selectionDeps :: Selection ResolvedNames a -> [Set (RColumnRef ())] + selectionDeps (SelectStar _ _ (StarColumnNames refs)) = map colDeps refs + selectionDeps (SelectExpr _ aliases _) = map aliasDeps aliases + + colDeps :: RColumnRef a -> Set (RColumnRef ()) + colDeps ref@(RColumnRef _) = S.singleton $ void ref + colDeps (RColumnAlias alias) = aliasDeps alias + + aliasDeps :: ColumnAlias a -> Set (RColumnRef ()) + aliasDeps (ColumnAlias _ _ cid) = + case M.lookup cid aliasMap of + Just deps -> deps + Nothing -> error $ "column alias missing from aliasesMap: " ++ show cid + + selections = selectColumnsList $ selectCols s + + in concatMap selectionDeps selections + + queryColumnDepsHelper aliasMap (QueryExcept _ _ lhs rhs) = + zipWith S.union (queryColumnDepsHelper aliasMap lhs) (queryColumnDepsHelper aliasMap rhs) + + queryColumnDepsHelper aliasMap (QueryUnion _ _ _ lhs rhs) = + zipWith S.union (queryColumnDepsHelper aliasMap lhs) (queryColumnDepsHelper aliasMap rhs) + + queryColumnDepsHelper aliasMap (QueryIntersect _ _ lhs rhs) = + zipWith S.union (queryColumnDepsHelper aliasMap lhs) (queryColumnDepsHelper aliasMap rhs) + + queryColumnDepsHelper aliasMap (QueryWith _ _ q) = queryColumnDepsHelper aliasMap q + queryColumnDepsHelper aliasMap (QueryOrder _ _ q) = queryColumnDepsHelper aliasMap q + queryColumnDepsHelper aliasMap (QueryLimit _ _ q) = queryColumnDepsHelper aliasMap q + queryColumnDepsHelper aliasMap (QueryOffset _ _ q) = queryColumnDepsHelper aliasMap q + + +instance HasColumns (Insert ResolvedNames a) where + goColumns Insert{..} = bindClause "INSERT" $ goColumns insertValues + +instance HasColumns (InsertValues ResolvedNames a) where + goColumns (InsertExprValues _ e) = goColumns e + goColumns (InsertSelectValues q) = goColumns q + goColumns (InsertDefaultValues _) = return () + goColumns (InsertDataFromFile _ _) = return () + +instance HasColumns (DefaultExpr ResolvedNames a) where + goColumns (DefaultValue _) = return () + goColumns (ExprValue e) = goColumns e + + +instance HasColumns (Update ResolvedNames a) where + goColumns Update{..} = bindClause "UPDATE" $ do + mapM_ (goColumns . snd) updateSetExprs + mapM_ goColumns updateFrom + mapM_ goColumns updateWhere + + +instance HasColumns (Delete ResolvedNames a) where + goColumns (Delete _ _ expr) = bindClause "WHERE" $ goColumns expr + + +instance HasColumns (CreateTable d ResolvedNames a) where + goColumns CreateTable{..} = bindClause "CREATE" $ do + -- TODO handle createTableExtra, and the dialect instances + goColumns createTableDefinition + +instance HasColumns (TableDefinition d ResolvedNames a) where + goColumns (TableColumns _ cs) = goColumns cs + goColumns (TableLike _ _) = return () + goColumns (TableAs _ _ query) = goColumns query + goColumns (TableNoColumnInfo _) = return () + +instance HasColumns (ColumnOrConstraint d ResolvedNames a) where + goColumns (ColumnOrConstraintColumn c) = goColumns c + goColumns (ColumnOrConstraintConstraint _) = return () + +instance HasColumns (ColumnDefinition d ResolvedNames a) where + goColumns ColumnDefinition{..} = goColumns columnDefinitionDefault + + +instance HasColumns (AlterTable ResolvedNames a) where + goColumns (AlterTableRenameTable _ _ _) = return () + goColumns (AlterTableRenameColumn _ _ _ _) = return () + goColumns (AlterTableAddColumns _ _ _) = return () + + +instance HasColumns (CreateView ResolvedNames a) where + goColumns CreateView{..} = bindClause "CREATE" $ goColumns createViewQuery + + +instance HasColumns (Select ResolvedNames a) where + goColumns select@(Select {..}) = sequence_ + [ bindClause "SELECT" $ goColumns $ selectCols + , bindClause "FROM" $ goColumns selectFrom + , bindClause "WHERE" $ goColumns selectWhere + , bindClause "TIMESERIES" $ goColumns selectTimeseries + , bindClause "GROUPBY" $ handleGroup select selectGroup + , bindClause "HAVING" $ goColumns selectHaving + , bindClause "NAMEDWINDOW" $ goColumns selectNamedWindow + ] + +instance HasColumns (SelectColumns ResolvedNames a) where + goColumns (SelectColumns _ selections) = mapM_ goColumns selections + +instance HasColumns (SelectFrom ResolvedNames a) where + goColumns (SelectFrom _ tablishes) = mapM_ goColumns tablishes + +instance HasColumns (SelectWhere ResolvedNames a) where + goColumns (SelectWhere _ condition) = goColumns condition + +instance HasColumns (SelectTimeseries ResolvedNames a) where + goColumns (SelectTimeseries _ alias _ partition order) = do + -- recurse to emit clause infos + goColumns partition + bindClause "ORDER" $ goColumns order + + -- also emit alias infos + clause <- ask + let observations = execWriter $ runReaderT (goColumns order) clause + cols = S.fromList $ map fst $ rights observations + tell $ [aliasObservation alias cols] + +instance HasColumns (Partition ResolvedNames a) where + goColumns (PartitionBy _ exprs) = bindClause "PARTITION" $ mapM_ goColumns exprs + goColumns (PartitionBest _) = return () + goColumns (PartitionNodes _) = return () + +handleGroup :: Select ResolvedNames a -> Maybe (SelectGroup ResolvedNames a) -> Observer +handleGroup _ Nothing = return () +handleGroup select (Just (SelectGroup _ groupingElements)) = mapM_ handleElement groupingElements + where + handleElement (GroupingElementExpr _ (PositionOrExprExpr expr)) = + goColumns expr + handleElement (GroupingElementExpr _ (PositionOrExprPosition _ pos _)) = + handlePos pos $ QuerySelect (selectInfo select) select + handleElement (GroupingElementSet _ exprs) = + mapM_ goColumns exprs + +instance HasColumns (SelectHaving ResolvedNames a) where + goColumns (SelectHaving _ havings) = mapM_ goColumns havings + +instance HasColumns (SelectNamedWindow ResolvedNames a) where + goColumns (SelectNamedWindow _ windowExprs) = mapM_ goColumns windowExprs + + +instance HasColumns (Selection ResolvedNames a) where + goColumns (SelectStar _ _ starColumns) = goColumns starColumns + goColumns (SelectExpr _ aliases expr) = do + -- recurse to emit clause infos + goColumns expr + + -- also emit alias infos + clause <- ask + let observations = execWriter $ runReaderT (goColumns expr) clause + cols = S.fromList $ map fst $ rights observations + tell $ map (\a -> aliasObservation a cols) aliases + +instance HasColumns (StarColumnNames a) where + goColumns (StarColumnNames rColumnRefs) = mapM_ goColumns rColumnRefs + +instance HasColumns (RColumnRef a) where + -- treat RColumnRef and RColumnAlias the same, here :) + goColumns ref = do + clause <- ask + tell $ [clauseObservation ref clause] + + +instance HasColumns (Tablish ResolvedNames a) where + goColumns (TablishTable _ tablishAliases tableRef) = do + -- no clause infos to emit + -- but there are potentially alias infos + case tablishAliases of + TablishAliasesNone -> return () + TablishAliasesT _ -> return () + TablishAliasesTC _ cAliases -> case tableRef of + RTableRef fqtn SchemaMember{..} -> + let fqcns = map (\uqcn -> uqcn { columnNameTable = Identity $ void fqtn }) columnsList + cRefSets = map (S.singleton . RColumnRef) fqcns + in tell $ zipWith aliasObservation cAliases cRefSets + RTableAlias _ -> return () + + goColumns (TablishSubQuery _ tablishAliases query) = do + -- recurse to emit clause infos + bindClause "SUBQUERY" $ goColumns query + + -- also emit alias infos (if any) + case tablishAliases of + TablishAliasesNone -> return () + TablishAliasesT _ -> return () + TablishAliasesTC _ cAliases -> + tell $ zipWith aliasObservation cAliases (queryColumnDeps query) + + goColumns (TablishJoin _ _ cond lhs rhs) = do + bindClause "JOIN" $ goColumns cond + goColumns lhs + goColumns rhs + + goColumns (TablishLateralView _ LateralView{..} lhs) = do + -- recurse to emit clause infos + bindClause "LATERALVIEW" $ do + goColumns lhs + mapM_ goColumns lateralViewExprs + + -- also emit alias infos (if any) + -- + -- NB this is tricky. In general, lateral views (like UNNEST) can + -- expand their input exprs into variable numbers of columns. E.g. in + -- Presto, UNNEST will expand arrays into 1 col and maps into 2 + -- cols. Since we don't keep track of column types, we can't map column + -- aliases to the (Set RColumnRefs) they refer to in the general case + -- :-( So let's just handle the particular case where lateralViewExpr + -- is a singleton list :-) + case lateralViewAliases of + TablishAliasesNone -> return () + TablishAliasesT _ -> return () + TablishAliasesTC _ cAliases -> case lateralViewExprs of + [FunctionExpr _ _ _ [e] _ _ _] -> + let observations = execWriter $ runReaderT (goColumns e) baseClause + refs = S.fromList $ map fst $ rights observations + in tell $ zipWith aliasObservation cAliases (repeat refs) + _ -> return () -- alas, the general case + +instance HasColumns (LateralView ResolvedNames a) where + goColumns (LateralView _ _ exprs _ _) = mapM_ goColumns exprs + +instance HasColumns (JoinCondition ResolvedNames a) where + goColumns (JoinNatural _ cs) = goColumns cs + goColumns (JoinOn expr) = goColumns expr + goColumns (JoinUsing _ cs) = mapM_ goColumns cs + +instance HasColumns (RNaturalColumns a) where + goColumns (RNaturalColumns cs) = mapM_ goColumns cs + +instance HasColumns (RUsingColumn a) where + goColumns (RUsingColumn c1 c2) = goColumns c1 >> goColumns c2 + + +instance HasColumns (NamedWindowExpr ResolvedNames a) where + goColumns (NamedWindowExpr _ _ expr) = goColumns expr + goColumns (NamedPartialWindowExpr _ _ expr) = goColumns expr + + +handleOrderForWindow :: Order ResolvedNames a -> Observer +handleOrderForWindow (Order _ (PositionOrExprPosition _ _ _) _ _) = error "unexpected positional reference" +handleOrderForWindow (Order _ (PositionOrExprExpr expr) _ _) = goColumns expr + +instance HasColumns (WindowExpr ResolvedNames a) where + goColumns (WindowExpr _ partition orders _) = do + goColumns partition + bindClause "ORDER" $ mapM_ handleOrderForWindow orders + +instance HasColumns (PartialWindowExpr ResolvedNames a) where + goColumns (PartialWindowExpr _ _ partition orders _) = do + goColumns partition + bindClause "ORDER" $ mapM_ handleOrderForWindow orders + + +instance HasColumns (Expr ResolvedNames a) where + goColumns (BinOpExpr _ _ lhs rhs) = mapM_ goColumns [lhs, rhs] + goColumns (CaseExpr _ whens else') = do + mapM_ ( \ (when', then') -> goColumns when' >> goColumns then') whens + goColumns else' + goColumns (UnOpExpr _ _ expr) = goColumns expr + goColumns (LikeExpr _ _ escape pattern expr) = do + goColumns escape + goColumns pattern + goColumns expr + goColumns (ConstantExpr _ _) = return () + goColumns (ColumnExpr _ c) = goColumns c + goColumns (InListExpr _ exprs expr) = mapM_ goColumns (expr:exprs) + goColumns (InSubqueryExpr _ query expr) = do + goColumns query + goColumns expr + goColumns (BetweenExpr _ expr start end) = mapM_ goColumns [expr, start, end] + goColumns (OverlapsExpr _ (e1, e2) (e3, e4)) = mapM_ goColumns [e1, e2, e3, e4] + goColumns (FunctionExpr _ _ _ exprs params filter' over) = do + mapM_ goColumns exprs + mapM_ (goColumns . snd) params + goColumns filter' + goColumns over + goColumns (AtTimeZoneExpr _ expr tz) = mapM_ goColumns [expr, tz] + goColumns (SubqueryExpr _ query) = bindClause "SUBQUERY" $ goColumns query + goColumns (ArrayExpr _ exprs) = mapM_ goColumns exprs + goColumns (ExistsExpr _ query) = goColumns query + goColumns (FieldAccessExpr _ expr _) = goColumns expr -- NB we aren't emitting any special info about field access (for now) + goColumns (ArrayAccessExpr _ expr idx) = mapM_ goColumns [expr, idx] -- NB we aren't emitting any special info about array access (for now) + goColumns (TypeCastExpr _ _ expr _) = goColumns expr + goColumns (VariableSubstitutionExpr _) = return () + +instance HasColumns (Escape ResolvedNames a) where + goColumns (Escape expr) = goColumns expr + +instance HasColumns (Pattern ResolvedNames a) where + goColumns (Pattern expr) = goColumns expr + +instance HasColumns (Filter ResolvedNames a) where + goColumns (Filter _ expr) = goColumns expr + +instance HasColumns (OverSubExpr ResolvedNames a) where + goColumns (OverWindowExpr _ expr) = goColumns expr + goColumns (OverWindowName _ _) = return () + goColumns (OverPartialWindowExpr _ expr) = goColumns expr diff --git a/src/Database/Sql/Util/Eval.hs b/src/Database/Sql/Util/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Util/Eval.hs @@ -0,0 +1,392 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Database.Sql.Util.Eval where + +import Database.Sql.Type.Query +import Database.Sql.Type.Names +import Database.Sql.Type.Scope +import Database.Sql.Position + +import Database.Sql.Util.Scope (selectionNames) + +import qualified Data.Text.Lazy as TL +import Data.Foldable +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map (Map) +import qualified Data.Map as M +import Control.Monad.Except +import Control.Monad.Identity +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer +import Data.Proxy + + +data RecordSet e = RecordSet + { recordSetLabels :: [RColumnRef ()] + , recordSetItems :: EvalRow e [EvalValue e] + } + +data EvalContext e = EvalContext + { evalAliasMap :: Map TableAliasId (RecordSet e) + , evalFromTable :: RTableName Range -> Maybe (RecordSet e) + , evalRow :: Map (RColumnRef ()) (EvalValue e) + } + +data ContextType = ExprContext | TableContext + + +exprToTable :: Evaluation e => EvalT e 'ExprContext (EvalMonad e) a -> Map (RColumnRef ()) (EvalValue e) -> EvalT e 'TableContext (EvalMonad e) a +exprToTable (EvalT e) r = EvalT $ local (\ EvalContext{..} -> EvalContext{evalRow = M.union evalRow r, ..}) e + +tableToExpr :: Evaluation e => EvalT e 'TableContext (EvalMonad e) a -> EvalT e 'ExprContext (EvalMonad e) a +tableToExpr (EvalT e) = EvalT e + +newtype EvalT e (t :: ContextType) m a = EvalT (ReaderT (EvalContext e) (ExceptT String m) a) + deriving (Functor, Applicative, Monad, MonadReader (EvalContext e), MonadError String, MonadWriter w, MonadState s) + +type Eval e t = EvalT e t Identity + +runEval :: Evaluation e => Eval e t a -> (RTableName Range -> Maybe (RecordSet e)) -> Either String a +runEval = (runIdentity .) . runEvalT + +runEvalT :: Evaluation e => EvalT e t m a -> (RTableName Range -> Maybe (RecordSet e)) -> m (Either String a) +runEvalT (EvalT e) evalFromTable = runExceptT $ runReaderT e $ EvalContext{..} + where + evalAliasMap = M.empty + evalRow = M.empty + +class Evaluate e q where + type EvalResult e q :: * + eval :: Proxy e -> q -> EvalResult e q + +introduceAlias :: Evaluation e => Proxy e -> TableAlias () -> RecordSet e -> EvalT e 'TableContext (EvalMonad e) a -> EvalT e 'TableContext (EvalMonad e) a +introduceAlias _ (TableAlias _ _ alias) tbl = local $ \ EvalContext{..} -> EvalContext{evalAliasMap = M.insert alias tbl evalAliasMap, ..} + +makeRecordSet :: (Evaluation e, Foldable (EvalRow e)) => Proxy e -> [RColumnRef ()] -> EvalRow e [EvalValue e] -> RecordSet e +makeRecordSet _ cols rows = + let numColumns = length cols + in if any ((/= numColumns) . length) rows + then error "wrong number of columns in record when constructing RecordSet" + else RecordSet cols rows + +emptyRecordSet :: Evaluation e => Proxy e -> RecordSet e +emptyRecordSet p = makeRecordSet p [] $ pure [] + +class (Monad (EvalRow e), Monad (EvalMonad e), Traversable (EvalRow e)) => Evaluation e where + type EvalValue e :: * + type EvalRow e :: * -> * + type EvalMonad e :: * -> * + addItems :: Proxy e -> EvalRow e [EvalValue e] -> EvalRow e [EvalValue e] -> EvalT e 'TableContext (EvalMonad e) (EvalRow e [EvalValue e]) + removeItems :: Proxy e -> EvalRow e [EvalValue e] -> EvalRow e [EvalValue e] -> EvalT e 'TableContext (EvalMonad e) (EvalRow e [EvalValue e]) + unionItems :: Proxy e -> EvalRow e [EvalValue e] -> EvalRow e [EvalValue e] -> EvalT e 'TableContext (EvalMonad e) (EvalRow e [EvalValue e]) + intersectItems :: Proxy e -> EvalRow e [EvalValue e] -> EvalRow e [EvalValue e] -> EvalT e 'TableContext (EvalMonad e) (EvalRow e [EvalValue e]) + distinctItems :: Proxy e -> EvalRow e [EvalValue e] -> EvalRow e [EvalValue e] + offsetItems :: Proxy e -> Int -> RecordSet e -> RecordSet e + limitItems :: Proxy e -> Int -> RecordSet e -> RecordSet e + filterBy :: Expr ResolvedNames Range -> RecordSet e -> EvalT e 'TableContext (EvalMonad e) (RecordSet e) + inList :: EvalValue e -> [EvalValue e] -> EvalT e 'ExprContext (EvalMonad e) (EvalValue e) + inSubquery :: EvalValue e -> EvalRow e [EvalValue e] -> EvalT e 'ExprContext (EvalMonad e) (EvalValue e) + existsSubquery :: EvalRow e [EvalValue e] -> EvalT e 'ExprContext (EvalMonad e) (EvalValue e) + atTimeZone :: EvalValue e -> EvalValue e -> EvalT e 'ExprContext (EvalMonad e) (EvalValue e) + handleConstant :: Proxy e -> Constant a -> EvalT e 'ExprContext (EvalMonad e) (EvalValue e) + handleCases :: Proxy e -> [(Expr ResolvedNames Range, Expr ResolvedNames Range)] -> Maybe (Expr ResolvedNames Range) -> EvalT e 'ExprContext (EvalMonad e) (EvalValue e) + handleFunction :: Proxy e -> FunctionName Range -> Distinct -> [Expr ResolvedNames Range] -> [(ParamName Range, Expr ResolvedNames Range)] -> Maybe (Filter ResolvedNames Range) -> Maybe (OverSubExpr ResolvedNames Range) -> EvalT e 'ExprContext (EvalMonad e) (EvalValue e) + handleGroups :: [RColumnRef ()] -> EvalRow e ([EvalValue e], EvalRow e [EvalValue e]) -> EvalRow e (RecordSet e) + handleLike :: Proxy e -> Operator a -> Maybe (Escape ResolvedNames Range) -> Pattern ResolvedNames Range -> Expr ResolvedNames Range -> EvalT e 'ExprContext (EvalMonad e) (EvalValue e) + handleOrder :: Proxy e -> [Order ResolvedNames Range] -> RecordSet e -> EvalT e 'TableContext (EvalMonad e) (RecordSet e) + handleSubquery :: EvalRow e [EvalValue e] -> EvalT e 'ExprContext (EvalMonad e) (EvalValue e) + handleJoin :: Proxy e -> JoinType a -> JoinCondition ResolvedNames Range -> RecordSet e -> RecordSet e -> EvalT e 'TableContext (EvalMonad e) (RecordSet e) + handleStructField :: Expr ResolvedNames Range -> StructFieldName a -> EvalT e 'ExprContext (EvalMonad e) (EvalValue e) + handleTypeCast :: CastFailureAction -> Expr ResolvedNames Range -> DataType a -> EvalT e 'ExprContext (EvalMonad e) (EvalValue e) + binop :: Proxy e -> TL.Text -> Maybe (EvalValue e -> EvalValue e -> EvalT e 'ExprContext (EvalMonad e) (EvalValue e)) + unop :: Proxy e -> TL.Text -> Maybe (EvalValue e -> EvalT e 'ExprContext (EvalMonad e) (EvalValue e)) + +instance Evaluation e => Evaluate e (Query ResolvedNames Range) where + type EvalResult e (Query ResolvedNames Range) = EvalT e 'TableContext (EvalMonad e) (RecordSet e) + eval p (QuerySelect _ select) = eval p select + eval p (QueryExcept _ (ColumnAliasList cs) lhs rhs) = do + exclude <- recordSetItems <$> eval p rhs + RecordSet{recordSetItems = unfiltered, ..} <- eval p lhs + let labels = map (RColumnAlias . void) cs + makeRecordSet p labels <$> removeItems p exclude unfiltered + + eval p (QueryUnion _ (Distinct False) (ColumnAliasList cs) lhs rhs) = do + RecordSet{recordSetItems = lhsRows, ..} <- eval p lhs + RecordSet{recordSetItems = rhsRows} <- eval p rhs + let labels = map (RColumnAlias . void) cs + makeRecordSet p labels <$> unionItems p lhsRows rhsRows + + eval p (QueryUnion info (Distinct True) cs lhs rhs) = do + result@RecordSet{recordSetItems} <- eval p (QueryUnion info (Distinct False) cs lhs rhs) + pure $ result{recordSetItems = distinctItems p recordSetItems} + + eval p (QueryIntersect _ (ColumnAliasList cs) lhs rhs) = do + RecordSet{recordSetItems = litems, ..} <- eval p lhs + ritems <- recordSetItems <$> eval p rhs + let labels = map (RColumnAlias . void) cs + makeRecordSet p labels <$> intersectItems p litems ritems + + eval p (QueryWith _ [] query) = eval p query + eval p (QueryWith info (CTE{..}:ctes) query) = do + RecordSet{..} <- eval p cteQuery + columns <- override cteColumns recordSetLabels + let result = makeRecordSet p columns recordSetItems + introduceAlias p (void cteAlias) result $ eval p $ QueryWith info ctes query + where + override [] ys = pure ys + override (alias:xs) (_:ys) = do + ys' <- override xs ys + pure $ (RColumnAlias $ void alias) : ys' + override _ [] = throwError "more aliases than columns in CTE" + + eval p (QueryLimit _ limit query) = eval p limit <$> eval p query + eval p (QueryOffset _ offset query) = eval p offset <$> eval p query + eval p (QueryOrder _ orders query) = eval p query >>= handleOrder p orders + +instance Evaluation e => Evaluate e (Select ResolvedNames Range) where + type EvalResult e (Select ResolvedNames Range) = EvalT e 'TableContext (EvalMonad e) (RecordSet e) + eval p Select{..} = do + -- nb. if we handle named windows at resolution time (T637160) + -- then we shouldn't need to do anything with them here + unfiltered <- maybe (pure $ emptyRecordSet p) (eval p) selectFrom + filtered <- maybe pure (eval p) selectWhere unfiltered + interpolated <- maybe pure (eval p) selectTimeseries filtered + groups <- maybe (const $ pure . pure) (eval p) selectGroup selectCols interpolated + having <- maybe pure (eval p) selectHaving groups + records <- mapM (eval p selectCols) having + let rows = recordSetItems =<< records + labels = map void $ selectionNames =<< selectColumnsList selectCols + indistinct = makeRecordSet p labels rows + + pure $ case selectDistinct of + Distinct True -> indistinct { recordSetItems = distinctItems p $ recordSetItems indistinct } + Distinct False -> indistinct + +instance Evaluation e => Evaluate e (SelectFrom ResolvedNames Range) where + type EvalResult e (SelectFrom ResolvedNames Range) = EvalT e 'TableContext (EvalMonad e) (RecordSet e) + eval p (SelectFrom _ []) = pure $ emptyRecordSet p + eval p (SelectFrom info (t:ts)) = do + RecordSet rcols rrows <- eval p $ SelectFrom info ts + RecordSet lcols lrows <- eval p t + pure $ makeRecordSet p (lcols ++ rcols) $ (++) <$> lrows <*> rrows + + +appendRecordSets :: Evaluation e => Proxy e -> NonEmpty (RecordSet e) -> EvalT e 'TableContext (EvalMonad e) (RecordSet e) +appendRecordSets p (RecordSet cs rs :| sets) = makeRecordSet p cs <$> foldM (addItems p) rs (map recordSetItems sets) + + +instance Evaluation e => Evaluate e (Tablish ResolvedNames Range) where + type EvalResult e (Tablish ResolvedNames Range) = EvalT e 'TableContext (EvalMonad e) (RecordSet e) + eval _ (TablishTable _ _ (RTableRef tableName table)) = asks evalFromTable <*> pure (RTableName tableName table) >>= \case + Nothing -> throwError $ "missing table: " ++ show (void tableName) + Just result -> pure result + eval _ (TablishTable _ _ (RTableAlias (TableAlias _ aliasName alias))) = asks (M.lookup alias . evalAliasMap) >>= \case + Nothing -> throwError $ "missing table alias: " ++ show aliasName + Just result -> pure result + + eval p (TablishSubQuery _ _ query) = eval p query + eval p (TablishJoin _ joinType cond lhs rhs) = do + x <- eval p lhs + y <- eval p rhs + handleJoin p joinType cond x y + + eval _ (TablishLateralView _ _ _) = error "lateral view not yet supported" + + +instance Evaluation e => Evaluate e (JoinCondition ResolvedNames Range) where + type EvalResult e (JoinCondition ResolvedNames Range) = RecordSet e -> RecordSet e -> EvalT e 'TableContext (EvalMonad e) (RecordSet e) + eval p (JoinOn expr) = \ (RecordSet lcols lrows) (RecordSet rcols rrows) -> do + filterBy expr $ makeRecordSet p (lcols ++ rcols) $ (++) <$> lrows <*> rrows + + eval p (JoinUsing info columns) = \ (RecordSet lcols lrows) (RecordSet rcols rrows) -> do + fmap (adjust columns) $ filterBy (mkExpr columns) $ makeRecordSet p (lcols ++ rcols) $ (++) <$> lrows <*> rrows + where + mkExpr :: [RUsingColumn Range] -> Expr ResolvedNames Range + mkExpr [] = ConstantExpr info $ BooleanConstant info True + mkExpr (RUsingColumn l r : cs) = + BinOpExpr info "AND" + (BinOpExpr info ("=") (ColumnExpr info l) (ColumnExpr info r)) + (mkExpr cs) + + adjust :: [RUsingColumn Range] -> RecordSet e -> RecordSet e + adjust [] = id + adjust (c:cs) = adjust cs . adjust' c + adjust' (RUsingColumn l r) = \ RecordSet{..} -> + RecordSet + { recordSetLabels = map fst . remove r . skip l . zip recordSetLabels $ repeat () + , recordSetItems = fmap (map snd . remove r . skip l . zip recordSetLabels) recordSetItems + } + + match column (label, _) = label == void column + skip column = break $ match column + remove column (skipped, next:rest) = + case break (match column) rest of + (skipped2, _:rest2) -> skipped ++ [next] ++ skipped2 ++ rest2 + (_, []) -> error "failed to find rhs using column" + remove _ (_, []) = error "failed to find lhs using column" + + eval p (JoinNatural info (RNaturalColumns columns)) = eval p (JoinUsing info columns :: JoinCondition ResolvedNames Range) + +makeRowMap :: [RColumnRef ()] -> [a] -> Map (RColumnRef ()) a +makeRowMap = (M.fromList .) . zip + + +-- | SelectColumns tells us how to map from the records provided by the +-- FROM to (unfiltered, &c) records provided by our select. Evaluating it +-- gives us that function. +instance Evaluation e => Evaluate e (SelectColumns ResolvedNames Range) where + type EvalResult e (SelectColumns ResolvedNames Range) = RecordSet e -> EvalT e 'TableContext (EvalMonad e) (RecordSet e) + eval p (SelectColumns _ columns) (RecordSet cs rs) = do + let cs' = map void $ selectionNames =<< columns + rs' <- forM rs $ \ r -> do + r' <- forM columns $ \ column -> + exprToTable (eval p column) $ makeRowMap cs r + pure $ concat r' + pure $ makeRecordSet p cs' rs' + +instance Evaluation e => Evaluate e (SelectWhere ResolvedNames Range) where + type EvalResult e (SelectWhere ResolvedNames Range) = RecordSet e -> EvalT e 'TableContext (EvalMonad e) (RecordSet e) + eval _ (SelectWhere _ expr) = filterBy expr + +instance Evaluation e => Evaluate e (SelectGroup ResolvedNames Range) where + type EvalResult e (SelectGroup ResolvedNames Range) = SelectColumns ResolvedNames Range -> RecordSet e -> EvalT e 'TableContext (EvalMonad e) (EvalRow e (RecordSet e)) + eval _ (SelectGroup _ elts) columns (RecordSet cs rs) = do + gs <- forM rs $ \ r -> do + RecordSet{..} <- eval Proxy columns $ RecordSet cs $ pure r + let selectMap = makeRowMap recordSetLabels (head $ toList recordSetItems) + g <- exprToTable (mapM (eval Proxy) (eltToExprs =<< elts)) $ M.union selectMap $ makeRowMap cs r + pure (g, pure r) + pure $ handleGroups cs gs + where + eltToExprs (GroupingElementSet _ exprs) = exprs + eltToExprs (GroupingElementExpr _ (PositionOrExprExpr expr)) = [expr] + eltToExprs (GroupingElementExpr _ (PositionOrExprPosition _ _ expr)) = [expr] + +instance Evaluation e => Evaluate e (SelectHaving ResolvedNames Range) where + type EvalResult e (SelectHaving ResolvedNames Range) = EvalRow e (RecordSet e) -> EvalT e 'TableContext (EvalMonad e) (EvalRow e (RecordSet e)) + eval _ (SelectHaving _ exprs) = foldl (>=>) pure $ map (mapM . filterBy) exprs + +instance Evaluation e => Evaluate e (SelectTimeseries ResolvedNames Range) where + type EvalResult e (SelectTimeseries ResolvedNames Range) = RecordSet e -> EvalT e 'TableContext (EvalMonad e) (RecordSet e) + eval _ (SelectTimeseries _ sliceName interval partition over) = error "timeseries not yet supported" sliceName interval partition over + +data Direction a = Ascending a | Descending a deriving Eq + +instance Ord a => Ord (Direction a) where + compare (Descending x) (Descending y) = compare y x + compare (Ascending x) (Ascending y) = compare x y + compare _ _ = error "comparing ascending to descending - this shouldn't happen" + +instance Evaluation e => Evaluate e (Limit a) where + type EvalResult e (Limit a) = RecordSet e -> RecordSet e + eval p (Limit _ limit) = limitItems p (read $ TL.unpack limit) + +instance Evaluation e => Evaluate e (Offset a) where + type EvalResult e (Offset a) = RecordSet e -> RecordSet e + eval p (Offset _ offset) = offsetItems p (read $ TL.unpack offset) + +instance Evaluation e => Evaluate e (Selection ResolvedNames Range) where + type EvalResult e (Selection ResolvedNames Range) = EvalT e 'ExprContext (EvalMonad e) [EvalValue e] + eval p (SelectExpr _ _ expr) = pure <$> eval p expr + eval p (SelectStar info _ (StarColumnNames cols)) = forM cols $ \ col -> + let expr :: Expr ResolvedNames Range + expr = ColumnExpr info col + in eval p expr + + +instance Evaluation e => Evaluate e (Expr ResolvedNames Range) where + type EvalResult e (Expr ResolvedNames Range) = EvalT e 'ExprContext (EvalMonad e) (EvalValue e) + eval p (BinOpExpr _ (Operator op) lhs rhs) = do + x <- eval p lhs + y <- eval p rhs + case binop p op of + Nothing -> throwError $ "unhandled operator: " ++ show op + Just f -> f x y + + eval p (CaseExpr _ cases else_) = handleCases p cases else_ + + eval p (UnOpExpr _ (Operator op) expr) = do + x <- eval p expr + case unop p op of + Nothing -> throwError $ "unhandled operator: " ++ show op + Just f -> f x + + eval p (LikeExpr _ op escape pattern expr) = handleLike p op escape pattern expr + eval p (ConstantExpr _ expr) = eval p expr + eval _ (ColumnExpr _ col) = do + row <- asks evalRow + case M.lookup (void col) row of + Just x -> pure x + Nothing -> throwError $ "failure looking up column: " ++ show (void col) ++ " in " ++ show (M.keys row) + + eval p (InListExpr _ list expr) = do + x <- eval p expr + xs <- mapM (eval p) list + inList x xs + + eval p (InSubqueryExpr _ query expr) = do + x <- eval p expr + RecordSet{..} <- tableToExpr $ eval p query + case length recordSetLabels of + 1 -> inSubquery x recordSetItems + 0 -> throwError "no columns returned from subquery for IN" + _ -> throwError "multiple columns returned from subquery for IN" + + eval p (BetweenExpr info expr start end) = eval p $ BinOpExpr info (Operator "AND") + (BinOpExpr info (Operator "<=") start expr) + (BinOpExpr info (Operator "<=") expr end) + + eval p (OverlapsExpr info (lstart, lend) (rstart, rend)) = eval p $ BinOpExpr info (Operator "AND") + (BinOpExpr info (Operator "<") lstart rend) + (BinOpExpr info (Operator "<") rstart lend) + + eval p (FunctionExpr _ fn isDistinct args parms filter' over) = handleFunction p fn isDistinct args parms filter' over + eval p (AtTimeZoneExpr _ expr tz) = join $ atTimeZone <$> eval p expr <*> eval p tz + eval p (SubqueryExpr _ query) = do + RecordSet{..} <- tableToExpr $ eval p query + handleSubquery recordSetItems + + eval p (ArrayExpr _ exprs) = error "array expression not yet supported" <$> mapM (eval p) exprs -- T636472 + eval p (ExistsExpr _ query) = do + RecordSet{..} <- tableToExpr (eval p query) + existsSubquery recordSetItems + + eval _ (FieldAccessExpr _ struct field) = handleStructField struct field + + eval _ (ArrayAccessExpr _ array idx) = error "array indexing not yet supported" array idx -- T636558 + eval _ (TypeCastExpr _ onFail expr type_) = handleTypeCast onFail expr type_ + eval _ (VariableSubstitutionExpr _) = throwError "no way to evaluate unsubstituted variable" + +instance Evaluation e => Evaluate e (Constant a) where + type EvalResult e (Constant a) = EvalT e 'ExprContext (EvalMonad e) (EvalValue e) + eval p constant = handleConstant p constant diff --git a/src/Database/Sql/Util/Eval/Concrete.hs b/src/Database/Sql/Util/Eval/Concrete.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Util/Eval/Concrete.hs @@ -0,0 +1,216 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Database.Sql.Util.Eval.Concrete where + +import Database.Sql.Util.Eval + +import Database.Sql.Type.Names +import Database.Sql.Type.Query + +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.Lazy as TL +import Data.List (nub, sort) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Set as S +import Control.Monad.Identity +import Control.Monad.Except +import Data.Proxy + + +data Concrete + +deriving instance Eq (RecordSet Concrete) +deriving instance Show (RecordSet Concrete) + +data SqlValue + = SqlInt Integer + | SqlStr ByteString + | SqlBool Bool + | SqlStruct (Map (StructFieldName ()) SqlValue) + | SqlNull + deriving (Eq, Ord, Show) + + +-- | truthy tells us whether our Haskell code should consider a SqlValue +-- "true", mostly for the purpose of filtering. It should not be used to +-- construct a SqlValue, as it does not handle NULL correctly for that +-- purpose. + +truthy :: SqlValue -> Bool +truthy (SqlBool bool) = bool +truthy (SqlInt int) = int /= 0 +truthy (SqlStr str) = not $ BL.null str +truthy (SqlStruct _) = True -- pigeon? +truthy SqlNull = False + + +instance Evaluation Concrete where + type EvalValue Concrete = SqlValue + type EvalRow Concrete = [] + type EvalMonad Concrete = Identity + addItems _ = (pure .) . (++) + removeItems _ exclude unfiltered = pure $ filter (not . (`S.member` S.fromList exclude)) unfiltered + unionItems _ xs ys = pure $ S.toList $ S.union (S.fromList xs) (S.fromList ys) + intersectItems _ xs ys = pure $ S.toList $ S.intersection (S.fromList xs) (S.fromList ys) + distinctItems _ = nub + offsetItems p offset RecordSet{..} = makeRecordSet p recordSetLabels $ drop offset recordSetItems + limitItems p limit RecordSet{..} = makeRecordSet p recordSetLabels $ take limit recordSetItems + + filterBy expr (RecordSet cs rs) = do + rs' <- filterM ((truthy <$>) . exprToTable (eval Proxy expr) . makeRowMap cs) rs + pure $ makeRecordSet Proxy cs rs' + + handleGroups cs gs = map (makeRecordSet Proxy cs) $ M.elems $ M.fromListWith (++) gs + + inList x xs = pure $ SqlBool $ elem x xs + inSubquery x xss = pure $ SqlBool $ elem x $ concat xss + existsSubquery = pure . SqlBool . not . null + + atTimeZone _ _ = throwError "AT TIME ZONE not yet handled in concrete evaluation" + handleConstant _ (StringConstant _ str) = pure $ SqlStr str + handleConstant _ (NumericConstant _ num) = pure $ SqlInt $ read $ TL.unpack num + handleConstant _ (NullConstant _) = pure SqlNull + handleConstant _ (BooleanConstant _ bool) = pure $ SqlBool bool + handleConstant _ (TypedConstant _ text dataType) = error "typed constant expression not yet supported" text dataType + handleConstant _ (ParameterConstant _) = throwError "no way to evaluate unsubstituted parameter" + + handleCases p ((when_, then_):cases) else_ = do + truthy <$> eval p when_ >>= \case + True -> eval p then_ + False -> handleCases p cases else_ + + handleCases _ [] Nothing = throwError "fell through case with no else" + handleCases p [] (Just expr) = eval p expr + + handleFunction _ _ _ _ _ _ _ = throwError "function exprs not yet supported" + + handleLike _ _ _ _ _ = throwError "concrete evaluation for LIKE expressions not yet supported" + + handleOrder p orders (RecordSet cs rs) = do + pairs <- forM rs $ \ r -> do + k <- (`exprToTable` makeRowMap cs r) $ forM orders $ \case + Order _ (PositionOrExprPosition _ pos _) (OrderAsc _) _ -> Ascending <$> return (r !! (pos - 1)) + Order _ (PositionOrExprPosition _ pos _) (OrderDesc _) _ -> Descending <$> return (r !! (pos - 1)) + Order _ (PositionOrExprExpr expr) (OrderAsc _) _ -> Ascending <$> eval p expr + Order _ (PositionOrExprExpr expr) (OrderDesc _) _ -> Descending <$> eval p expr + pure (k, r) + pure $ makeRecordSet p cs $ map snd $ sort pairs + + handleSubquery [[x]] = pure x + handleSubquery [] = throwError "no rows returned from subquery" + handleSubquery [_] = throwError "wrong number of columns from subquery" + handleSubquery _ = throwError "multiple rows returned from subquery" + + handleJoin p (JoinInner _) cond x y = eval p cond x y + handleJoin p (JoinLeft _) cond x y = do + case x of + RecordSet _ [] -> eval p cond x y + RecordSet lcols lrows -> do + set:sets <- forM lrows $ \ lrow -> do + let x' = makeRecordSet p lcols [lrow] + eval p cond x' y >>= \case + RecordSet cols [] -> pure $ makeRecordSet p cols [extendWithNulls cols lrow] + set -> pure set + appendRecordSets p (set:|sets) + + handleJoin p (JoinRight _) cond x y = do + case y of + RecordSet _ [] -> eval p cond x y + RecordSet rcols rrows -> do + set:sets <- forM rrows $ \ rrow -> do + let y' = makeRecordSet p rcols [rrow] + eval p cond x y' >>= \case + RecordSet cols [] -> pure $ makeRecordSet p cols [reverse $ extendWithNulls cols $ reverse rrow] + set -> pure set + appendRecordSets p (set:|sets) + + handleJoin p (JoinFull info) cond x y = do + RecordSet cs rs <- handleJoin p (JoinLeft info) cond x y + RecordSet _ rs' <- do -- get those from the RHS with no matches on LHS + case y of + RecordSet _ [] -> eval p cond x y + RecordSet rcols rrows -> do + set:sets <- forM rrows $ \ rrow -> do + let y' = makeRecordSet p rcols [rrow] + eval p cond x y' >>= \case + RecordSet cols [] -> pure $ makeRecordSet p cols [reverse $ extendWithNulls cols $ reverse rrow] + RecordSet cols _ -> pure $ makeRecordSet p cols [] + appendRecordSets p (set:|sets) + pure $ makeRecordSet p cs $ rs ++ rs' + + handleJoin _ (JoinSemi _) cond x y = error "semi joins not yet supported" cond x y + + handleStructField expr field = eval (Proxy :: Proxy Concrete) expr >>= \case + SqlStruct m + | Just val <- M.lookup (void field) m + -> pure val + | otherwise + -> throwError "missing field in SQL struct" + _ -> throwError "field access of non-struct value" + + handleTypeCast _ _ _ = throwError "concrete evaluation for type cast expressions not yet supported" + + binop _ op = M.lookup op $ M.fromList + [ ("+", opAdd) + , ("=", opEq) + , ("AND", opAnd) + ] + where + opAdd (SqlInt x) (SqlInt y) = pure $ SqlInt (x + y) + opAdd (SqlInt _) SqlNull = pure SqlNull + opAdd SqlNull (SqlInt _) = pure SqlNull + opAdd _ _ = throwError "unsupported arguments to + operator" + + opEq SqlNull _ = pure SqlNull + opEq _ SqlNull = pure SqlNull + opEq x y = pure $ SqlBool $ x == y -- TODO coerce + + opAnd SqlNull _ = pure SqlNull + opAnd _ SqlNull = pure SqlNull + opAnd x y = pure $ SqlBool $ truthy x && truthy y + + unop _ op = M.lookup op $ M.fromList + [ ("-", neg) + ] + where + neg (SqlInt int) = pure $ SqlInt (-int) + neg SqlNull = pure SqlNull + neg _ = throwError "unsupported argument to - operator" + + +extendWithNulls :: [a] -> [SqlValue] -> [SqlValue] +extendWithNulls (_:xs) (y:ys) = y:extendWithNulls xs ys +extendWithNulls xs [] = map (const SqlNull) xs +extendWithNulls [] _ = error "more values than columns - this should never happen" diff --git a/src/Database/Sql/Util/Joins.hs b/src/Database/Sql/Util/Joins.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Util/Joins.hs @@ -0,0 +1,377 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Database.Sql.Util.Joins (HasJoins(..), JoinsResult) where + +import Database.Sql.Type + +import qualified Data.Map as M +import Data.Map (Map) + +import qualified Data.Set as S +import Data.Set (Set) + +import Data.Semigroup + +import Data.Functor.Identity +import Data.Foldable +import Control.Monad (void, when) +import Control.Monad.Writer (Writer, execWriter, tell) + +data Result = Result + { resultBindings :: Map ColumnAliasId (Map (RColumnRef ()) FieldChain) + , resultColumns :: Set (Map (RColumnRef ()) FieldChain) + } + +instance Monoid Result where + mempty = Result mempty mempty + mappend (Result bindings columns) (Result bindings' columns') = Result (bindings <> bindings') (columns <> columns') + +-- Relationship observed between two columns +type Join = ((FullyQualifiedColumnName, [StructFieldName ()]), (FullyQualifiedColumnName, [StructFieldName ()])) +type Scoped a = Writer Result a +type JoinsResult = Set Join + +class HasJoins q where + getJoins :: q -> Set Join + +instance HasJoins (Statement d ResolvedNames a) where + getJoins stmt = + let Result{..} = execWriter $ getJoinsStatement stmt + unalias :: Map (RColumnRef ()) FieldChain -> Map (FQColumnName ()) FieldChain + unalias m = M.fromList $ M.toList m >>= \case + (RColumnRef fqcn, chain) -> [(fqcn, chain)] + (RColumnAlias (ColumnAlias _ _ aliasId), _) -> maybe [] (M.toList . unalias) $ M.lookup aliasId resultBindings + sets = S.map unalias resultColumns + + toPairs m + | M.null m = [] + | otherwise = do + let ((c@(QColumnName _ (Identity table) _), chain), m') = M.deleteFindMin m + pairs = do + (c'@(QColumnName _ (Identity table') _), chain') <- M.toList m' + fields <- expandChain chain + fields' <- expandChain chain' + if table /= table' + then [((fqcnToFQCN c, fields), (fqcnToFQCN c', fields'))] + else [] + pairs ++ toPairs m' + + in S.fromList $ toPairs =<< S.toList sets + where + expandChain (FieldChain m) + | M.null m = [[]] + | otherwise = do + (k, v) <- M.toList m + (k:) <$> expandChain v + + +getJoinsStatement :: Statement d ResolvedNames a -> Scoped () +getJoinsStatement (QueryStmt query) = void $ getJoinsQuery query +getJoinsStatement (InsertStmt insert) = getJoinsInsert insert +getJoinsStatement (UpdateStmt update) = getJoinsUpdate update +getJoinsStatement (DeleteStmt delete) = getJoinsDelete delete +getJoinsStatement (TruncateStmt _) = pure () +getJoinsStatement (CreateTableStmt create) = getJoinsCreateTable create +getJoinsStatement (AlterTableStmt _) = pure () +getJoinsStatement (DropTableStmt _) = pure () +getJoinsStatement (CreateViewStmt create) = void $ getJoinsQuery $ createViewQuery create +getJoinsStatement (DropViewStmt _) = pure () +getJoinsStatement (CreateSchemaStmt _) = pure () +getJoinsStatement (GrantStmt _) = pure () +getJoinsStatement (RevokeStmt _) = pure () +getJoinsStatement (BeginStmt _) = pure () +getJoinsStatement (CommitStmt _) = pure () +getJoinsStatement (RollbackStmt _) = pure () +getJoinsStatement (ExplainStmt _ _) = pure () +getJoinsStatement (EmptyStmt _) = pure () + + +queryColumns :: Query ResolvedNames a -> [RColumnRef a] +queryColumns (QueryExcept _ _ query _) = queryColumns query +queryColumns (QueryUnion _ _ _ query _) = queryColumns query +queryColumns (QueryIntersect _ _ query _) = queryColumns query +queryColumns (QueryWith _ _ query) = queryColumns query +queryColumns (QueryOrder _ _ query) = queryColumns query +queryColumns (QueryLimit _ _ query) = queryColumns query +queryColumns (QueryOffset _ _ query) = queryColumns query +queryColumns (QuerySelect _ Select{selectCols = SelectColumns _ selections}) = selections >>= \case + SelectExpr _ aliases _ -> map RColumnAlias aliases + SelectStar _ _ (StarColumnNames cols) -> cols + + +getJoinsCreateTable :: CreateTable d ResolvedNames a -> Scoped () +getJoinsCreateTable CreateTable{..} = getJoinsTableDefinition createTableDefinition + +-- TODO - "join" for columns producing columns? Assuming no... +-- note that defaults cannot reference other tables in Vertica, possibly in other dialects +getJoinsTableDefinition :: TableDefinition d ResolvedNames a -> Scoped () +getJoinsTableDefinition (TableColumns _ _) = pure () +getJoinsTableDefinition (TableLike _ _) = pure () +getJoinsTableDefinition (TableAs _ _ query) = void $ getJoinsQuery query +getJoinsTableDefinition (TableNoColumnInfo _) = pure () + + +getJoinsInsert :: Insert ResolvedNames a -> Scoped () +getJoinsInsert Insert{..} = case insertValues of + InsertDefaultValues _ -> pure () + InsertExprValues _ values -> mapM_ (mapM_ getJoinsDefaultExpr) values + InsertSelectValues query -> void $ getJoinsQuery query + InsertDataFromFile _ _ -> pure () + +getJoinsDefaultExpr :: DefaultExpr ResolvedNames a -> Scoped () +getJoinsDefaultExpr (DefaultValue _) = pure () +getJoinsDefaultExpr (ExprValue expr) = void $ getJoinsExpr expr + +getJoinsUpdate :: Update ResolvedNames a -> Scoped () +getJoinsUpdate Update{..} = do + mapM_ (getJoinsDefaultExpr . snd) updateSetExprs + mapM_ getJoinsTablish updateFrom + mapM_ getJoinsExpr updateWhere + +getJoinsDelete :: Delete ResolvedNames a -> Scoped () +getJoinsDelete (Delete _ _ (Just expr)) = void $ getJoinsExpr expr +getJoinsDelete (Delete _ _ Nothing) = pure () + +zipColumns :: Query ResolvedNames a -> Query ResolvedNames a -> Scoped () +zipColumns lhs rhs = do + let lcolumns = queryColumns lhs + rcolumns = queryColumns rhs + forM_ (zip lcolumns rcolumns) $ \ (lcol, rcol) -> emit $ M.fromSet (const $ FieldChain M.empty) $ S.fromList [void lcol, void rcol] + +getJoinsQuery :: Query ResolvedNames a -> Scoped () +getJoinsQuery (QuerySelect _ select) = getJoinsSelect select +getJoinsQuery (QueryExcept _ _ lhs rhs) = do + getJoinsQuery lhs + getJoinsQuery rhs + zipColumns lhs rhs + +getJoinsQuery (QueryUnion _ _ _ lhs rhs) = do + getJoinsQuery lhs + getJoinsQuery rhs + zipColumns lhs rhs + +getJoinsQuery (QueryIntersect _ _ lhs rhs) = do + getJoinsQuery lhs + getJoinsQuery rhs + zipColumns lhs rhs + +getJoinsQuery (QueryWith _ ctes query) = do + mapM_ getJoinsCTE ctes + getJoinsQuery query + +getJoinsQuery (QueryOrder _ orders query) = do + mapM_ getJoinsOrder orders + getJoinsQuery query + +getJoinsQuery (QueryLimit _ _ query) = getJoinsQuery query +getJoinsQuery (QueryOffset _ _ query) = getJoinsQuery query + + +getJoinsSelect :: Select ResolvedNames a -> Scoped () +getJoinsSelect (Select{..}) = do + getJoinsSelectCols selectCols + maybe (pure ()) getJoinsSelectFrom selectFrom + maybe (pure ()) getJoinsSelectWhere selectWhere + maybe (pure ()) getJoinsSelectTimeseries selectTimeseries + maybe (pure ()) getJoinsSelectGroup selectGroup + maybe (pure ()) getJoinsSelectHaving selectHaving + maybe (pure ()) getJoinsSelectNamedWindow selectNamedWindow + +getJoinsSelectFrom :: SelectFrom ResolvedNames a -> Scoped () +getJoinsSelectFrom (SelectFrom _ tablishes) = mapM_ getJoinsTablish tablishes + +getJoinsSelectCols :: SelectColumns ResolvedNames a -> Scoped () +getJoinsSelectCols (SelectColumns _ selections) = mapM_ getJoinsSelection selections + +getJoinsSelectWhere :: SelectWhere ResolvedNames a -> Scoped () +getJoinsSelectWhere (SelectWhere _ expr) = void $ getJoinsExpr expr + +getJoinsSelectTimeseries :: SelectTimeseries ResolvedNames a -> Scoped () +getJoinsSelectTimeseries (SelectTimeseries _ _ _ partition expr) = do + maybe (pure ()) getJoinsPartition partition + void $ getJoinsExpr expr + +getJoinsPositionOrExpr :: PositionOrExpr ResolvedNames a -> Scoped () +getJoinsPositionOrExpr (PositionOrExprPosition _ _ _) = pure () +getJoinsPositionOrExpr (PositionOrExprExpr expr) = void $ getJoinsExpr expr + +getJoinsGroupingElement :: GroupingElement ResolvedNames a -> Scoped () +getJoinsGroupingElement (GroupingElementExpr _ posOrExpr) = getJoinsPositionOrExpr posOrExpr +getJoinsGroupingElement (GroupingElementSet _ exprs) = mapM_ getJoinsExpr exprs + +getJoinsSelectGroup :: SelectGroup ResolvedNames a -> Scoped () +getJoinsSelectGroup (SelectGroup _ groupingElements) = + mapM_ getJoinsGroupingElement groupingElements + +getJoinsSelectHaving :: SelectHaving ResolvedNames a -> Scoped () +getJoinsSelectHaving (SelectHaving _ exprs) = mapM_ getJoinsExpr exprs + +getJoinsSelectNamedWindow :: SelectNamedWindow ResolvedNames a -> Scoped () +getJoinsSelectNamedWindow (SelectNamedWindow _ windows) = mapM_ joins windows + where + joins (NamedWindowExpr _ _ windowExpr) = getJoinsWindowExpr windowExpr + joins (NamedPartialWindowExpr _ _ partialWindowExpr) = getJoinsPartialWindowExpr partialWindowExpr + +emit :: Map (RColumnRef ()) FieldChain -> Scoped () +emit cols = tell $ mempty { resultColumns = S.singleton cols } + +bind :: ColumnAliasId -> Map (RColumnRef ()) FieldChain -> Scoped () +bind alias cols = tell $ mempty { resultBindings = M.singleton alias cols } + +getJoinsExpr :: Expr ResolvedNames a -> Scoped (Map (RColumnRef ()) FieldChain) +getJoinsExpr (BinOpExpr _ op lhs rhs) = do + lcols <- getJoinsExpr lhs + rcols <- getJoinsExpr rhs + + let allcols = M.unionWith (<>) lcols rcols + + when (op `elem` ["=", "!=", "<>", "<=>", "==", "<", ">", "<=", ">="]) $ do + emit allcols + + return allcols + +getJoinsExpr (CaseExpr _ cases else_) = do + cols <- mapM (\ (when_, then_) -> getJoinsExpr when_ *> getJoinsExpr then_) cases + col <- maybe (pure M.empty) getJoinsExpr else_ + + return $ M.unionsWith (<>) $ col : cols + +getJoinsExpr (LikeExpr _ _ escape pattern expr) = do + void $ maybe (pure mempty) (getJoinsExpr . escapeExpr) escape + + lcols <- getJoinsExpr $ patternExpr pattern + rcols <- getJoinsExpr expr + + let allcols = M.unionWith (<>) lcols rcols + + emit allcols + + return allcols + +getJoinsExpr (UnOpExpr _ _ expr) = getJoinsExpr expr +getJoinsExpr (ConstantExpr _ _) = return M.empty +getJoinsExpr (ColumnExpr _ column) = return $ M.singleton (void column) $ FieldChain M.empty +getJoinsExpr (InListExpr _ exprs expr) = do + cols <- M.unionsWith (<>) <$> mapM getJoinsExpr (expr:exprs) + emit cols + return cols + +getJoinsExpr (InSubqueryExpr _ query expr) = do + getJoinsQuery query + let [column] = queryColumns query + columns <- getJoinsExpr expr + let columns' = M.insert (void column) (FieldChain M.empty) columns + emit columns' + return columns' + +getJoinsExpr (BetweenExpr _ expr start end) = M.unionsWith (<>) <$> mapM getJoinsExpr [expr, start, end] +getJoinsExpr (OverlapsExpr _ (r1start, r1end) (r2start, r2end)) = M.unionsWith (<>) <$> mapM getJoinsExpr [r1start, r1end, r2start, r2end] +getJoinsExpr (FunctionExpr _ _ _ args params mFilter mOver) = do + cols <- M.unionsWith (<>) <$> mapM getJoinsExpr (args ++ map snd params) + maybe (pure mempty) getJoinsFilter mFilter + maybe (pure mempty) getJoinsOverSubExpr mOver + return cols + +getJoinsExpr (AtTimeZoneExpr _ ts tz) = M.unionWith (<>) <$> getJoinsExpr ts <*> getJoinsExpr tz +getJoinsExpr (SubqueryExpr _ query) = do + getJoinsQuery query + let [column] = queryColumns query + pure $ M.singleton (void column) $ FieldChain M.empty + +getJoinsExpr (ExistsExpr _ query) = do + _ <- getJoinsQuery query + return M.empty + +getJoinsExpr (ArrayExpr _ values) = M.unionsWith (<>) <$> mapM getJoinsExpr values +getJoinsExpr (FieldAccessExpr _ expr field) = go expr $ FieldChain $ M.singleton (void field) $ FieldChain M.empty + where + go (ColumnExpr _ ref@(RColumnRef _)) chain = return $ M.singleton (void ref) chain + go (FieldAccessExpr _ expr' field') chain = go expr' $ FieldChain $ M.singleton (void field') chain + go expr' _ = getJoinsExpr expr' + + +getJoinsExpr (ArrayAccessExpr _ expr index) = M.unionsWith (<>) <$> mapM getJoinsExpr [expr, index] +getJoinsExpr (TypeCastExpr _ _ expr _) = getJoinsExpr expr +getJoinsExpr (VariableSubstitutionExpr _) = return M.empty + +getJoinsFilter :: Filter ResolvedNames a -> Scoped () +getJoinsFilter (Filter _ expr) = void $ getJoinsExpr expr + +getJoinsOverSubExpr :: OverSubExpr ResolvedNames a -> Scoped () +getJoinsOverSubExpr (OverWindowExpr _ windowExpr) = getJoinsWindowExpr windowExpr +getJoinsOverSubExpr (OverWindowName _ _) = pure () +getJoinsOverSubExpr (OverPartialWindowExpr _ partial) = getJoinsPartialWindowExpr partial + +getJoinsWindowExpr :: WindowExpr ResolvedNames a -> Scoped () +getJoinsWindowExpr (WindowExpr _ p os _) = do + maybe (pure ()) getJoinsPartition p + mapM_ getJoinsOrder os + +getJoinsPartialWindowExpr :: PartialWindowExpr ResolvedNames a -> Scoped () +getJoinsPartialWindowExpr (PartialWindowExpr _ _ p os _) = do + maybe (pure ()) getJoinsPartition p + mapM_ getJoinsOrder os + +getJoinsPartition :: Partition ResolvedNames a -> Scoped () +getJoinsPartition (PartitionBy _ es) = mapM_ getJoinsExpr es +getJoinsPartition (PartitionBest _) = return () +getJoinsPartition (PartitionNodes _) = return () + +getJoinsOrder :: Order ResolvedNames a -> Scoped () +getJoinsOrder (Order _ posOrExpr _ _) = void $ getJoinsPositionOrExpr posOrExpr + +getJoinsTablish :: Tablish ResolvedNames a -> Scoped () +getJoinsTablish (TablishTable _ _ _) = pure () +getJoinsTablish (TablishLateralView _ LateralView{..} lhs) = do + maybe (pure ()) getJoinsTablish lhs + mapM_ getJoinsExpr lateralViewExprs + +getJoinsTablish (TablishSubQuery _ _ query) = getJoinsQuery query +getJoinsTablish (TablishJoin _ _ (JoinNatural _ (RNaturalColumns columns)) lhs rhs) = do + getJoinsTablish lhs + getJoinsTablish rhs + forM_ columns $ \ (RUsingColumn lcol rcol) -> do + emit $ M.fromSet (const $ FieldChain M.empty) $ S.fromList [void lcol, void rcol] + +getJoinsTablish (TablishJoin _ _ (JoinOn expr) lhs rhs) = do + getJoinsTablish lhs + getJoinsTablish rhs + void $ getJoinsExpr expr + +getJoinsTablish (TablishJoin _ _ (JoinUsing _ columns) lhs rhs) = do + getJoinsTablish lhs + getJoinsTablish rhs + forM_ columns $ \ (RUsingColumn lcol rcol) -> do + emit $ M.fromSet (const $ FieldChain M.empty) $ S.fromList [void lcol, void rcol] + + +getJoinsCTE :: CTE ResolvedNames a -> Scoped () +getJoinsCTE (CTE _ _ _ query) = getJoinsQuery query + + +getJoinsSelection :: Selection ResolvedNames a -> Scoped () +getJoinsSelection (SelectStar _ _ _) = pure () +getJoinsSelection (SelectExpr _ aliases expr) = do + cols <- getJoinsExpr expr + forM_ aliases $ \ (ColumnAlias _ _ aliasId) -> bind aliasId cols diff --git a/src/Database/Sql/Util/Lineage/ColumnPlus.hs b/src/Database/Sql/Util/Lineage/ColumnPlus.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Util/Lineage/ColumnPlus.hs @@ -0,0 +1,372 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Database.Sql.Util.Lineage.ColumnPlus where + +import Database.Sql.Type +import Database.Sql.Position +import Database.Sql.Info + +import Database.Sql.Util.Eval + +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Maybe (mapMaybe, maybeToList) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import Data.Proxy +import Data.Semigroup +import Control.Arrow +import Control.Applicative +import Control.Monad.Identity +import Control.Monad.Except +import Control.Monad.Writer (Writer, runWriter, execWriter, writer, tell) +import Data.Foldable + + +-- | ColumnLineagePlus is a set of descendants, each with an associated set of ancestors. +-- Descendents may be a column (representing values in that column) +-- or a table (representing row-count). +-- +-- Ancestors are the same, but that ancestor columns may be further +-- specialized by field path. +-- +-- Tracking impacts on row-count is necessary because row-count can +-- have impacts on data without any columns being involved. For a clear +-- example, consider `CREATE TABLE foo AS SELECT COUNT(1) FROM BAR;` +-- +-- It also gives us something coherent to speak about with respect to +-- `EXISTS` - the value depends on the row count of the subquery. +-- +-- N.b. While it looks like we're talking about "tables", this is *not* +-- the same thing as table-level lineage. Changes to values in existing +-- rows does not impact row count. Following an UPDATE, if we ask "has +-- this table changed, such that we need to rerun things downstream?", +-- the answer is clearly yes. If we ask "has the row-count of this +-- table changed, such that we need to rerun things that depend only on +-- row-count?" the answer is clearly not. + +type ColumnLineagePlus = Map (Either FQTN FQCN) ColumnPlusSet + +class HasColumnLineage q where + getColumnLineage :: q -> (RecordSet ColumnLineage, ColumnLineagePlus) + +instance HasColumnLineage (Statement d ResolvedNames Range) where + getColumnLineage stmt = columnLineage stmt + + +emptyLineage :: [FQColumnName ()] -> ColumnLineagePlus +emptyLineage = M.fromList . map (, emptyColumnPlusSet) . map (Right . fqcnToFQCN) + +data ColumnLineage + +data ColumnPlusSet = ColumnPlusSet + { columnPlusColumns :: Map FQCN (Map FieldChain (Set Range)) + , columnPlusTables :: Map FQTN (Set Range) + } deriving (Eq, Show) + +instance Semigroup ColumnPlusSet where + ColumnPlusSet m s <> ColumnPlusSet n t = ColumnPlusSet (M.unionWith (M.unionWith S.union) m n) (M.unionWith S.union s t) + +instance Monoid ColumnPlusSet where + mempty = ColumnPlusSet mempty mempty + mappend = (<>) + +emptyColumnPlusSet :: ColumnPlusSet +emptyColumnPlusSet = ColumnPlusSet M.empty M.empty + +singleColumnSet :: Range -> FullyQualifiedColumnName -> ColumnPlusSet +singleColumnSet info c = ColumnPlusSet (M.singleton c $ M.singleton (FieldChain M.empty) $ S.singleton info) M.empty + +singleTableSet :: Range -> FullyQualifiedTableName -> ColumnPlusSet +singleTableSet info t = ColumnPlusSet M.empty (M.singleton t $ S.singleton info) + +mergeLineages :: Writer ColumnPlusSet [ColumnPlusSet] -> Writer ColumnPlusSet [ColumnPlusSet] -> EvalT ColumnLineage 'TableContext Identity (Writer ColumnPlusSet [ColumnPlusSet]) +mergeLineages = (pure .) . liftA2 (zipWith (<>)) + +instance Evaluation ColumnLineage where + type EvalValue ColumnLineage = ColumnPlusSet + type EvalRow ColumnLineage = Writer ColumnPlusSet + type EvalMonad ColumnLineage = Identity + addItems _ = mergeLineages + removeItems _ = mergeLineages + unionItems _ = mergeLineages + intersectItems _ = mergeLineages + distinctItems _ = id + offsetItems _ _ = id + limitItems _ _ = id + + filterBy expr (RecordSet cs rs) = do + let p = Proxy :: Proxy ColumnLineage + let (r, rowCount) = runWriter rs + x <- exprToTable (eval p expr) $ makeRowMap cs r + pure $ makeRecordSet (Proxy :: Proxy ColumnLineage) cs $ writer (map (x <>) r, x <> rowCount) + + inList x xs = pure $ foldl' (<>) x xs + inSubquery x xs = + let (ys, y) = runWriter xs + in pure $ foldl' (<>) x (y:ys) + existsSubquery rs = pure $ execWriter rs + + atTimeZone ts tz = pure $ ts <> tz + + handleConstant _ _ = pure emptyColumnPlusSet + + handleCases p cases else_ = do + cases' :: [ColumnPlusSet] <- mapM (\ (when_, then_) -> (<>) <$> eval p when_ <*> eval p then_) cases + else_' <- maybe (pure emptyColumnPlusSet) (eval p) else_ + pure $ foldl' (<>) else_' cases' + + -- TODO: incorporate over + handleFunction p _ _ args params filter' _ = mconcat <$> mapM (eval p) + ( args + ++ map snd params + ++ map filterExpr (maybeToList filter') + ) + + handleGroups cs gs = + pure $ RecordSet cs $ do + (g, rs) <- gs + r <- rs + mapM_ tell g + pure $ map (\ v -> sconcat (v:|g)) r + + handleLike p (Operator _) escape pattern expr = do + let addEscape = maybe id ((:) . escapeExpr) escape + exprs = addEscape [patternExpr pattern, expr] + mconcat <$> mapM (eval p) exprs + + handleOrder _ _ = pure + + handleSubquery xs = case runWriter xs of + ([x], y) -> pure (x<>y) + (_, _) -> throwError "wrong number of columns from subquery" + + handleJoin p joinType cond x y = clip joinType <$> eval p cond x y + where + clip (JoinSemi _) = \ set -> + let n = length $ recordSetLabels x + in RecordSet + { recordSetLabels = take n $ recordSetLabels set + , recordSetItems = fmap (take n) $ recordSetItems set + } + clip _ = id + + handleStructField expr field = go expr (FieldChain $ M.singleton (void field) $ FieldChain M.empty, getInfo expr) + where + go (ColumnExpr _ (RColumnRef col)) (chain, info) = pure ColumnPlusSet + { columnPlusColumns = M.singleton (fqcnToFQCN col) $ M.singleton chain $ S.singleton info + , columnPlusTables = mempty + } + + go (FieldAccessExpr _ expr' field') chain = go expr' $ first (FieldChain . M.singleton (void field')) chain + go expr' _ = eval (Proxy :: Proxy ColumnLineage) expr' + + handleTypeCast _ expr _ = eval (Proxy :: Proxy ColumnLineage) expr + + binop _ _ = Just $ (pure .) . (<>) + + unop _ _ = Just $ pure . id + + +ancestorsForTableName :: RTableName Range -> Maybe (RecordSet ColumnLineage) +ancestorsForTableName (RTableName fqtn SchemaMember{..}) = + let recordSetLabels = map RColumnRef columns + info = getInfo fqtn + recordSetItems = writer (map (singleColumnSet info . fqcnToFQCN) columns, singleTableSet info $ fqtnToFQTN $ void fqtn) + columns = map (qualifyColumnName fqtn) columnsList + in Just RecordSet{..} + +truncateTableLineage :: FQTableName a -> [FQColumnName ()] -> ColumnLineagePlus +truncateTableLineage tableName columns = M.insert (Left $ fqtnToFQTN tableName) emptyColumnPlusSet $ emptyLineage columns + +evalDefaultExpr :: DefaultExpr ResolvedNames Range -> EvalResult ColumnLineage (Expr ResolvedNames Range) +evalDefaultExpr (DefaultValue _) = pure emptyColumnPlusSet +evalDefaultExpr (ExprValue expr) = eval (Proxy :: Proxy ColumnLineage) expr + +returnNothing :: ColumnLineagePlus -> (RecordSet ColumnLineage, ColumnLineagePlus) +returnNothing = (emptyRecordSet Proxy,) + +columnLineage :: Statement d ResolvedNames Range -> (RecordSet ColumnLineage, ColumnLineagePlus) +columnLineage (QueryStmt query) = + let p = Proxy :: Proxy ColumnLineage + in case runEval (eval p query) ancestorsForTableName of + Left err -> error $ "failed to evaluate column lineage for query: " ++ err + Right r -> (r, mempty) + +columnLineage (InsertStmt Insert{insertTable = RTableName tableName SchemaMember{..}, ..}) = + returnNothing $ + let columns :: [Either FQTN FQCN] + columns = case insertColumns of + Just (c:|cs) -> map (columnNameToKey . extractColumnRef) $ c : cs + Nothing -> map (columnNameToKey . qualifyColumnName tableName) columnsList + in mergeExisting $ case insertValues of + InsertExprValues _ exprs -> case runEval (mapM (mapM evalDefaultExpr) exprs) ancestorsForTableName of + Left err -> error $ "failed to evaluate column lineage for insert exprs: " ++ err + Right rows -> M.fromList $ zip columns $ foldl1 (zipWith (<>)) $ map toList $ toList rows + InsertSelectValues query -> case runEval (eval p query) ancestorsForTableName of + Left err -> error $ "failed to evaluate column lineage for insert query: " ++ err + Right RecordSet{..} -> + let (columnsLineage, tableLineage) = runWriter recordSetItems + in M.insert (Left $ fqtnToFQTN tableName) tableLineage $ M.fromList $ zip columns columnsLineage + InsertDefaultValues _ -> M.empty + InsertDataFromFile _ _ -> M.empty + where + p = Proxy :: Proxy ColumnLineage + mergeExisting :: ColumnLineagePlus -> ColumnLineagePlus + mergeExisting = M.unionWith (<>) existing + existing :: ColumnLineagePlus + existing = importExistingTable existingColumns + existingColumns = M.mapKeysMonotonic Right $ M.fromSet importExistingColumns $ S.fromList $ map (fqcnToFQCN . qualifyColumnName tableName) columnsList + extractColumnRef :: RColumnRef Range -> FQColumnName Range + extractColumnRef (RColumnRef fqcn) = fqcn + extractColumnRef (RColumnAlias _) = error "this shouldn't happen" + columnNameToKey :: FQColumnName a -> Either FQTN FQCN + columnNameToKey = Right . fqcnToFQCN + (importExistingColumns, importExistingTable) = case insertBehavior of -- only INSERT OVERWRITE discards the entire contents of the table + InsertOverwrite _ -> (const emptyColumnPlusSet, id) + _ -> + ( singleColumnSet insertInfo + , M.insert (Left $ fqtnToFQTN tableName) (singleTableSet (getInfo tableName) $ fqtnToFQTN tableName) + ) + +columnLineage (UpdateStmt Update{..}) = + returnNothing $ + let lineagesFromSetExprs :: ColumnLineagePlus = case runEval (mapM evalDefaultExpr exprs) ancestorsForTableName of + Left err -> error $ "failed to evaluate column lineage for update exprs: " ++ err + Right lins -> M.fromList $ zip columns lins + + ancestorsFromWhere :: ColumnPlusSet = case updateWhere of + Just expr -> case runEval (filterBy expr table) ancestorsForTableName of + Left err -> error $ "failed to evaluate column lineage for update expr: " ++ err + Right lins -> execWriter $ recordSetItems lins + Nothing -> mempty + + in mergeExisting $ M.map (<> ancestorsFromWhere) lineagesFromSetExprs + where + table :: RecordSet ColumnLineage + Just table = ancestorsForTableName updateTable + + existing :: ColumnLineagePlus + existing = M.mapKeysMonotonic Right $ M.fromSet (singleColumnSet updateInfo) $ S.fromList $ map (fqcnToFQCN) fqcns + + mergeExisting :: ColumnLineagePlus -> ColumnLineagePlus + mergeExisting = M.unionWith (<>) existing + + columns = map (Right . fqcnToFQCN) fqcns + fqcns = map (\(RColumnRef fqcn) -> fqcn) colRefs + (colRefs, exprs) = unzip $ toList updateSetExprs + +columnLineage (DeleteStmt (Delete _ (RTableName _ SchemaMember{viewQuery = Just _}) _)) = error "delete statement targeting view" +columnLineage (DeleteStmt (Delete _ (RTableName tableName SchemaMember{viewQuery = Nothing, ..}) maybeExpr)) = + returnNothing $ + let columns = map (qualifyColumnName tableName) columnsList + in case maybeExpr of + Nothing -> truncateTableLineage tableName columns + Just expr -> + let lineages = map (singleColumnSet (getInfo tableName) . fqcnToFQCN) columns + table :: RecordSet ColumnLineage + table = RecordSet (map RColumnRef columns) (writer (lineages, singleTableSet (getInfo tableName) $ fqtnToFQTN tableName)) + in case runEval (filterBy expr table) ancestorsForTableName of + Left err -> error $ "failed to evaluate column lineage for delete query: " ++ err + Right RecordSet{..} -> + let (columnsLineage, tableLineage) = runWriter recordSetItems + in M.insert (Left $ fqtnToFQTN tableName) (singleTableSet (getInfo tableName) (fqtnToFQTN tableName) <> tableLineage) $ M.fromList $ zip (map (Right . fqcnToFQCN) columns) columnsLineage + +columnLineage (TruncateStmt (Truncate _ (RTableName _ SchemaMember{viewQuery = Just _}))) = error "truncate statement targeting view" +columnLineage (TruncateStmt (Truncate _ (RTableName tableName SchemaMember{viewQuery = Nothing, ..}))) = + returnNothing $ + let columns = map (qualifyColumnName tableName) columnsList + in truncateTableLineage tableName columns + +columnLineage (CreateTableStmt CreateTable{createTableName = RCreateTableName _ Exists}) = returnNothing M.empty +columnLineage (CreateTableStmt CreateTable{createTableName = RCreateTableName tableName DoesNotExist, ..}) = + returnNothing $ + case createTableDefinition of + TableColumns _ (c:|cs) -> + M.insert (Left $ fqtnToFQTN tableName) emptyColumnPlusSet + $ emptyLineage $ (`mapMaybe` (c:cs)) $ \case + ColumnOrConstraintConstraint _ -> Nothing + ColumnOrConstraintColumn ColumnDefinition{..} -> Just $ qualifyColumnName tableName columnDefinitionName + TableLike _ (RTableName _ SchemaMember{..}) -> + M.insert (Left $ fqtnToFQTN tableName) emptyColumnPlusSet + $ emptyLineage $ map (qualifyColumnName tableName) columnsList + TableAs _ maybeColumns query -> case runEval (eval (Proxy :: Proxy ColumnLineage) query) ancestorsForTableName of + Left err -> error $ "failed to evaluate column lineage for create table statement: " ++ err + Right RecordSet{..} -> + let columns = maybe queryColumns proc maybeColumns + proc = map (qualifyColumnName tableName) . toList + queryColumns = map (qualifyColumnName tableName . resolvedColumnName) recordSetLabels + resolvedColumnName (RColumnRef fqtn) = fqtn{columnNameTable = None} + resolvedColumnName (RColumnAlias (ColumnAlias _ name _)) = QColumnName () None name + (columnsLineage, tableLineage) = runWriter recordSetItems + in M.insert (Left $ fqtnToFQTN tableName) tableLineage $ M.fromList $ zip (map (Right . fqcnToFQCN) columns) columnsLineage + TableNoColumnInfo _ -> M.empty + +columnLineage (DropTableStmt DropTable{dropTableNames = tables}) = + returnNothing $ + M.unions $ map + (\case + RDropExistingTableName tableName SchemaMember{..} -> + let columns = map (qualifyColumnName tableName) columnsList + in truncateTableLineage tableName columns + RDropMissingTableName _ -> M.empty + ) $ toList tables + +columnLineage (AlterTableStmt (AlterTableRenameTable _ (RTableName from SchemaMember{..}) (RTableName to _))) = + returnNothing $ + let as = map (qualifyColumnName from) columnsList + ds = map (qualifyColumnName to) columnsList + in M.insert (Left $ fqtnToFQTN to) (singleTableSet (getInfo from) $ fqtnToFQTN from) + $ M.insert (Left $ fqtnToFQTN from) emptyColumnPlusSet + $ M.union (emptyLineage as) $ M.fromList $ zip (map (Right . fqcnToFQCN) ds) $ map (singleColumnSet (getInfo from) . fqcnToFQCN) as + +columnLineage (AlterTableStmt (AlterTableRenameColumn _ (RTableName table _) from to)) = + returnNothing $ + let a = fqcnToFQCN $ qualifyColumnName table from + d = fqcnToFQCN $ qualifyColumnName table to + in M.fromList [(Right d, singleColumnSet (getInfo table) a), (Right a, emptyColumnPlusSet)] + +columnLineage (AlterTableStmt (AlterTableAddColumns _ (RTableName table _) (c:|cs))) = + returnNothing $ emptyLineage $ map (qualifyColumnName table) (c:cs) + +columnLineage (CreateViewStmt _) = returnNothing M.empty +columnLineage (DropViewStmt _) = returnNothing M.empty +-- TODO T590907 + +columnLineage (CreateSchemaStmt _) = returnNothing M.empty +columnLineage (GrantStmt _) = returnNothing M.empty +columnLineage (RevokeStmt _) = returnNothing M.empty +columnLineage (BeginStmt _) = returnNothing M.empty +columnLineage (CommitStmt _) = returnNothing M.empty +columnLineage (RollbackStmt _) = returnNothing M.empty +columnLineage (ExplainStmt _ _) = returnNothing M.empty +columnLineage (EmptyStmt _) = returnNothing M.empty diff --git a/src/Database/Sql/Util/Lineage/Table.hs b/src/Database/Sql/Util/Lineage/Table.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Util/Lineage/Table.hs @@ -0,0 +1,159 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +module Database.Sql.Util.Lineage.Table where + +import Database.Sql.Type +import Database.Sql.Util.Tables + +import qualified Data.Set as S +import Data.Set (Set) + +import qualified Data.Map as M +import Data.Map (Map) + +import qualified Data.Foldable as F + +import Data.Functor.Identity + + +-- | TableLineage is a set of descendants, each with an associated set of ancestors. +-- Ancestors, for each descendant table, should contain a superset of +-- all proximate tables that could have had an impact on the contents +-- of the descendant following execution of the statement. + +type TableLineage = Map FQTN (Set FQTN) + +class HasTableLineage q where + getTableLineage :: q -> TableLineage + +instance HasTableLineage (Statement d ResolvedNames a) where + getTableLineage stmt = tableLineage stmt + + +mkFQTN :: FQTableName a -> FullyQualifiedTableName +mkFQTN (QTableName _ (Identity (QSchemaName _ (Identity (DatabaseName _ database)) schema _)) name) = FullyQualifiedTableName database schema name + +-- a table with no rows (e.g. CREATE TABLE LIKE, TRUNCATE TABLE) has no ancestors. +emptyLineage :: FullyQualifiedTableName -> TableLineage +emptyLineage fqtn = M.singleton fqtn S.empty + +-- Squash chained renames: +-- If `from` is a `to` in any lineage so far, then merge with that lineage. +-- Otherwise it's a new lineage. +squashTableLineage :: TableLineage -> TableLineage -> TableLineage +squashTableLineage old new = + let new' = M.map (foldMap (\ s -> maybe (S.singleton s) id $ M.lookup s old)) new + in M.union new' old + +-- gives the lineage information implied by a statement, at table resolution +tableLineage :: Statement d ResolvedNames a -> TableLineage +tableLineage (QueryStmt _) = M.empty +tableLineage (InsertStmt Insert{insertTable = RTableName tableName _, ..}) = case insertValues of + -- the contents of a table after an Insert depend on the contents of the + -- table before the Insert, so the insertTable will always be its own + -- ancestor. + InsertExprValues _ _ -> filterByInsertBehavior soloAncestor + InsertDefaultValues _ -> filterByInsertBehavior soloAncestor + InsertDataFromFile _ _ -> filterByInsertBehavior soloAncestor + -- the data in the table changed, + -- but we can't know anything about its provenance :-/ + InsertSelectValues query -> + let sources = S.insert fqtn $ getTables query + ancestry = M.singleton fqtn sources + in filterByInsertBehavior ancestry + where + fqtn = mkFQTN tableName + soloAncestor = M.singleton fqtn $ S.singleton fqtn + + filterByInsertBehavior :: TableLineage -> TableLineage + filterByInsertBehavior ancestry = case insertBehavior of + InsertOverwrite _ -> M.adjust (S.delete fqtn) fqtn ancestry + InsertAppend _ -> ancestry + InsertOverwritePartition _ _ -> ancestry + InsertAppendPartition _ _ -> ancestry + +tableLineage (UpdateStmt Update{..}) = + let RTableName table _ = updateTable + fqtn = mkFQTN table + sources = S.insert fqtn $ S.unions [ getTables updateFrom + , getTables updateSetExprs + , getTables updateWhere + ] + in M.singleton fqtn sources + +tableLineage (DeleteStmt (Delete _ (RTableName table _) maybeExpr)) = case maybeExpr of + -- if there's no WHERE clause, this is equivalent to a TRUNCATE TABLE + Nothing -> emptyLineage fqtn + -- otherwise, the contents after a delete depend on the contents before the + -- delete, so `table` will be its own ancestor. + Just expr -> + let sources = S.insert fqtn $ getTables expr + in M.singleton fqtn sources + where fqtn = mkFQTN table + +tableLineage (TruncateStmt (Truncate _ (RTableName table _))) = + M.singleton (mkFQTN table) S.empty + +tableLineage (CreateTableStmt CreateTable{createTableName = RCreateTableName tableName _, ..}) = case createTableDefinition of + TableColumns _ _ -> emptyLineage fqtn + TableLike _ _ -> emptyLineage fqtn + TableAs _ _ query -> M.singleton fqtn $ getTables query + TableNoColumnInfo _ -> emptyLineage fqtn + where + fqtn = mkFQTN tableName + +tableLineage (DropTableStmt DropTable{dropTableNames = tables}) = + F.foldl' (\acc v -> + case v of + RDropExistingTableName tableName _ -> M.insert (mkFQTN tableName) S.empty acc + RDropMissingTableName _ -> acc + ) M.empty tables + +tableLineage (AlterTableStmt (AlterTableRenameTable _ (RTableName from _) (RTableName to _))) = + let a = mkFQTN from + d = mkFQTN to + in M.fromList [(d, S.singleton a), (a, S.empty)] +tableLineage (AlterTableStmt (AlterTableRenameColumn _ _ _ _)) = M.empty +tableLineage (AlterTableStmt (AlterTableAddColumns _ _ _)) = M.empty + +tableLineage (CreateViewStmt _) = M.empty +tableLineage (DropViewStmt _) = M.empty +-- TODO T590907 +-- +-- Lineage of views is tricky -- the data referenced by a view could change at +-- any time, asynchronously, under the hood. Probably, correct behavior would +-- be to emit descendant=createViewName, ancestors=(getTables on +-- createViewQuery) while also indicating that it's a view, so that in lineage +-- rollup we know not to treat the view as having static lineage. +-- +-- It's subtly wrong (and probably more confusing overall) to emit lineage of +-- views without having a downstream method of accommodating their dynamic +-- lineage model, so let's just not emit anything -- at least then the results +-- should be obviously wrong (which is much better than subtly wrong!) :-) + +tableLineage (CreateSchemaStmt _) = M.empty +tableLineage (GrantStmt _) = M.empty +tableLineage (RevokeStmt _) = M.empty +tableLineage (BeginStmt _) = M.empty +tableLineage (CommitStmt _) = M.empty +tableLineage (RollbackStmt _) = M.empty +tableLineage (ExplainStmt _ _) = M.empty +tableLineage (EmptyStmt _) = M.empty diff --git a/src/Database/Sql/Util/Schema.hs b/src/Database/Sql/Util/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Util/Schema.hs @@ -0,0 +1,361 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +module Database.Sql.Util.Schema where + +import qualified Data.HashMap.Strict as HMS + +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty (..)) + +import Data.Maybe (mapMaybe, maybeToList) + +import Database.Sql.Type.Names +import Database.Sql.Type.TableProps +import Database.Sql.Type.Scope + +import qualified Database.Sql.Util.Scope as Scope +import qualified Database.Sql.Type as AST + +import qualified Data.Foldable as F + +import Control.Monad.Reader +import Data.Functor.Identity + + +data SchemaChange + = AddColumn (FQColumnName ()) + | DropColumn (FQColumnName ()) + | CreateTable (FQTableName ()) SchemaMember + | DropTable (FQTableName ()) + | CreateView (FQTableName ()) SchemaMember + | DropView (FQTableName ()) + | CreateSchema (FQSchemaName ()) SchemaMap + | DropSchema (FQSchemaName ()) + | CreateDatabase (DatabaseName ()) DatabaseMap + | UsePath [UQSchemaName ()] + + +data SchemaChangeError + = DatabaseMissing (DatabaseName ()) + | SchemaMissing (FQSchemaName ()) + | TableMissing (FQTableName ()) + | ColumnMissing (FQColumnName ()) + | DatabaseCollision (DatabaseName ()) + | SchemaCollision (FQSchemaName ()) + | TableCollision (FQTableName ()) + | ColumnCollision (FQColumnName ()) + | UnsupportedColumnChange (FQTableName ()) + deriving (Eq, Show) + + +applySchemaChange :: SchemaChange -> Catalog -> (Catalog, [SchemaChangeError]) +applySchemaChange (AddColumn fqcn@(QColumnName _ (Identity fqtn@(QTableName _ (Identity fqsn@(QSchemaName _ (Identity db) _ _)) _)) _)) Catalog{..} = + overCatalogMap $ \ catalog -> do + let voidDb = void db + uqsn = fqsn { schemaNameDatabase = None } + uqtn = fqtn { tableNameSchema = None } + uqcn = fqcn { columnNameTable = None } + case HMS.lookup voidDb catalog of + Nothing -> + let schema = HMS.singleton uqtn (persistentTable [uqcn]) + database = HMS.singleton uqsn schema + in (HMS.insert voidDb database catalog, [DatabaseMissing voidDb]) + Just database -> + case HMS.lookup uqsn database of + Nothing -> + let schema = HMS.singleton uqtn (persistentTable [uqcn]) + in (HMS.adjust (HMS.insert uqsn schema) voidDb catalog, [SchemaMissing fqsn]) + Just schema -> + case HMS.lookup uqtn schema of + Nothing -> + let schema' = HMS.insert uqtn (persistentTable [uqcn]) schema + in (HMS.adjust (HMS.insert uqsn schema') voidDb catalog, [TableMissing fqtn]) + Just SchemaMember{..} + | tableType /= Table -> (catalog, [UnsupportedColumnChange fqtn]) + | L.elem uqcn columnsList -> (catalog, [ColumnCollision fqcn]) + | otherwise -> + let appendColumn sm = sm { columnsList = columnsList ++ [uqcn] } + in (HMS.adjust (HMS.adjust (HMS.adjust appendColumn uqtn) uqsn) voidDb catalog, []) + +applySchemaChange (DropColumn fqcn@(QColumnName _ (Identity fqtn@(QTableName _ (Identity fqsn@(QSchemaName _ (Identity db) _ _)) _)) _)) Catalog{..} = + overCatalogMap $ \ catalog -> do + let voidDb = void db + uqsn = fqsn { schemaNameDatabase = None } + uqtn = fqtn { tableNameSchema = None } + uqcn = fqcn { columnNameTable = None } + case HMS.lookup voidDb catalog of + Nothing -> + let schema = HMS.singleton uqtn (persistentTable []) + database = HMS.singleton uqsn schema + in (HMS.insert voidDb database catalog, [DatabaseMissing voidDb]) + Just database -> + case HMS.lookup uqsn database of + Nothing -> + let schema = HMS.singleton uqtn (persistentTable []) + in (HMS.adjust (HMS.insert uqsn schema) voidDb catalog, [SchemaMissing fqsn]) + Just schema -> + case HMS.lookup uqtn schema of + Nothing -> + let schema' = HMS.insert uqtn (persistentTable []) schema + in (HMS.adjust (HMS.insert uqsn schema') voidDb catalog, [TableMissing fqtn]) + Just SchemaMember{..} + | tableType /= Table -> (catalog, [UnsupportedColumnChange fqtn]) + | L.elem uqcn columnsList -> + let removeColumn sm = sm { columnsList = L.delete uqcn columnsList } + in (HMS.adjust (HMS.adjust (HMS.adjust removeColumn uqtn) uqsn) voidDb catalog, []) + | otherwise -> (catalog, [ColumnMissing fqcn]) + +applySchemaChange (CreateTable fqtn@(QTableName _ (Identity fqsn@(QSchemaName _ (Identity db) _ _)) _) table) Catalog{..} = + overCatalogMap $ \ catalog -> do + let voidDb = void db + uqsn = fqsn { schemaNameDatabase = None } + uqtn = fqtn { tableNameSchema = None } + case HMS.lookup voidDb catalog of + Nothing -> + let schema = HMS.singleton uqtn table + database = HMS.singleton uqsn schema + in (HMS.insert voidDb database catalog, [DatabaseMissing voidDb]) + Just database -> + case HMS.lookup uqsn database of + Nothing -> + let schema = HMS.singleton uqtn table + in (HMS.adjust (HMS.insert uqsn schema) voidDb catalog, [SchemaMissing fqsn]) + Just schema -> + ( HMS.adjust (HMS.adjust (HMS.insert uqtn table) uqsn) voidDb catalog + , [TableCollision fqtn | HMS.member uqtn schema] + ) + +applySchemaChange (DropTable fqtn@(QTableName _ (Identity fqsn@(QSchemaName _ (Identity db) _ _)) _)) Catalog{..} = + overCatalogMap $ \ catalog -> do + let voidDb = void db + uqsn = fqsn { schemaNameDatabase = None } + uqtn = fqtn { tableNameSchema = None } + case HMS.lookup voidDb catalog of + Nothing -> + let database = HMS.singleton uqsn HMS.empty + in (HMS.insert voidDb database catalog, [DatabaseMissing voidDb]) + Just database -> + case HMS.lookup uqsn database of + Nothing -> (HMS.adjust (HMS.insert uqsn HMS.empty) voidDb catalog, [SchemaMissing fqsn]) + Just schema -> + ( HMS.adjust (HMS.adjust (HMS.delete uqtn) uqsn) voidDb catalog + , [TableMissing fqtn | not $ HMS.member uqtn schema] + ) + +applySchemaChange (CreateView fqvn@(QTableName _ (Identity fqsn@(QSchemaName _ (Identity db) _ _)) _) view) Catalog{..} = + overCatalogMap $ \ catalog -> do + let voidDb = void db + uqsn = fqsn { schemaNameDatabase = None } + uqvn = fqvn { tableNameSchema = None } + case HMS.lookup voidDb catalog of + Nothing -> + let schema = HMS.singleton uqvn view + database = HMS.singleton uqsn schema + in (HMS.insert voidDb database catalog, [DatabaseMissing voidDb]) + Just database -> + case HMS.lookup uqsn database of + Nothing -> + let schema = HMS.singleton uqvn view + in (HMS.adjust (HMS.insert uqsn schema) voidDb catalog, [SchemaMissing fqsn]) + Just schema -> + ( HMS.adjust (HMS.adjust (HMS.insert uqvn view) uqsn) voidDb catalog + , [TableCollision fqvn | HMS.member uqvn schema] + ) + +applySchemaChange (DropView fqvn@(QTableName _ (Identity fqsn@(QSchemaName _ (Identity db) _ _)) _)) Catalog{..} = + overCatalogMap $ \ catalog -> do + let voidDb = void db + uqsn = fqsn { schemaNameDatabase = None } + uqvn = fqvn { tableNameSchema = None } + case HMS.lookup voidDb catalog of + Nothing -> + let database = HMS.singleton uqsn HMS.empty + in (HMS.insert voidDb database catalog, [DatabaseMissing voidDb]) + Just database -> + case HMS.lookup uqsn database of + Nothing -> (HMS.adjust (HMS.insert uqsn HMS.empty) voidDb catalog, [SchemaMissing fqsn]) + Just schema -> + ( HMS.adjust (HMS.adjust (HMS.delete uqvn) uqsn) voidDb catalog + , [TableMissing fqvn | not $ HMS.member uqvn schema] + ) + +applySchemaChange (CreateSchema fqsn@(QSchemaName _ (Identity db) _ _) schema) Catalog{..} = overCatalogMap $ \ catalog -> + let voidDb = void db + uqsn = fqsn { schemaNameDatabase = None } + in case HMS.lookup voidDb catalog of + Nothing -> + let database = HMS.singleton uqsn schema + in (HMS.insert voidDb database catalog, [DatabaseMissing voidDb]) + Just database -> + ( HMS.adjust (HMS.insert uqsn schema) voidDb catalog + , [SchemaCollision fqsn | HMS.member uqsn database] + ) + +applySchemaChange (DropSchema fqsn@(QSchemaName _ (Identity db) _ _)) Catalog{..} = overCatalogMap $ \ catalog -> + let voidDb = void db + uqsn = fqsn { schemaNameDatabase = None } + in case HMS.lookup voidDb catalog of + Nothing -> + let database = HMS.singleton uqsn HMS.empty + in (HMS.insert voidDb database catalog, [DatabaseMissing voidDb]) + Just database -> + ( HMS.adjust (HMS.delete uqsn) voidDb catalog + , [SchemaMissing fqsn | not $ HMS.member uqsn database] + ) + +applySchemaChange (CreateDatabase db database) Catalog{..} = overCatalogMap $ \ catalog -> + ( HMS.insert (void db) database catalog + , [DatabaseCollision $ void db] + ) + +applySchemaChange (UsePath path) Catalog{..} = (catalogWithPath path, []) + + +class HasSchemaChange q where + getSchemaChange :: q -> [SchemaChange] + + +instance HasSchemaChange (AST.Statement d AST.ResolvedNames a) where + getSchemaChange (AST.QueryStmt _) = [] + getSchemaChange (AST.InsertStmt _) = [] + getSchemaChange (AST.UpdateStmt _) = [] + getSchemaChange (AST.CreateTableStmt (AST.CreateTable{createTableName = AST.RCreateTableName _ AST.Exists, createTableIfNotExists = Just _})) = [] + getSchemaChange (AST.CreateTableStmt (AST.CreateTable{createTableName = AST.RCreateTableName tableName _, ..})) = + let tableType = Table + persistence = (void createTablePersistence) + columnsList = getColumnsForTableDefinition createTableDefinition + viewQuery = Nothing + in [CreateTable (void tableName) SchemaMember{..}] + + where + getColumnsForTableDefinition :: AST.TableDefinition d AST.ResolvedNames a -> [UQColumnName ()] + getColumnsForTableDefinition (AST.TableColumns _ (c:|cs)) = + let toColumnName (AST.ColumnOrConstraintColumn (AST.ColumnDefinition{..})) = Just $ void columnDefinitionName + toColumnName (AST.ColumnOrConstraintConstraint _) = Nothing + in mapMaybe toColumnName (c:cs) + + getColumnsForTableDefinition (AST.TableLike _ (AST.RTableName _ SchemaMember{..})) = + case tableType of + Table -> columnsList + View -> fail "this shouldn't happen" + + getColumnsForTableDefinition (AST.TableAs _ (Just (c:|cs)) _) = map void (c:cs) + getColumnsForTableDefinition (AST.TableAs _ Nothing query) = map toUQCN $ Scope.queryColumnNames query + + getColumnsForTableDefinition (AST.TableNoColumnInfo _) = [] + + getSchemaChange (AST.AlterTableStmt stmt) = getSchemaChange stmt + + + getSchemaChange (AST.DeleteStmt _) = [] + getSchemaChange (AST.TruncateStmt _) = [] + getSchemaChange (AST.DropTableStmt AST.DropTable{dropTableNames = tables}) = + F.foldMap (\case + AST.RDropExistingTableName fqtn _ -> [DropTable $ void fqtn] + AST.RDropMissingTableName _ -> [] + ) tables + getSchemaChange (AST.CreateViewStmt (AST.CreateView{createViewName = AST.RCreateTableName _ AST.Exists, createViewIfNotExists = Just _})) = [] + getSchemaChange (AST.CreateViewStmt (AST.CreateView{createViewName = AST.RCreateTableName viewName _, ..})) = + let tableType = View + persistence = (void createViewPersistence) + columnsList = case createViewColumns of + Just (c:|cs) -> map void $ c:cs + Nothing -> map toUQCN $ Scope.queryColumnNames createViewQuery + viewQuery = Just (void $ createViewQuery) + in [CreateView (void viewName) SchemaMember{..}] + getSchemaChange (AST.DropViewStmt AST.DropView{dropViewName = AST.RDropExistingTableName fqvn _}) = [DropView $ void fqvn] + getSchemaChange (AST.DropViewStmt AST.DropView{dropViewName = AST.RDropMissingTableName _}) = [] + getSchemaChange (AST.CreateSchemaStmt (AST.CreateSchema{createSchemaName = AST.RCreateSchemaName _ AST.Exists, createSchemaIfNotExists = Just _})) = [] + getSchemaChange (AST.CreateSchemaStmt (AST.CreateSchema{createSchemaName = AST.RCreateSchemaName schemaName _})) = [CreateSchema (void schemaName) HMS.empty] + getSchemaChange (AST.GrantStmt _) = [] + getSchemaChange (AST.RevokeStmt _) = [] + getSchemaChange (AST.BeginStmt _) = [] + getSchemaChange (AST.CommitStmt _) = [] + getSchemaChange (AST.RollbackStmt _) = [] + getSchemaChange (AST.ExplainStmt _ _) = [] + getSchemaChange (AST.EmptyStmt _) = [] + + +instance HasSchemaChange (AST.AlterTable AST.ResolvedNames a) where + getSchemaChange (AST.AlterTableRenameTable _ (AST.RTableName from _) (AST.RTableName to table)) = + [ DropTable (void from) + , CreateTable (void to) table + ] + getSchemaChange (AST.AlterTableRenameColumn _ (AST.RTableName table _) from to) = + let sameCol :: AST.UQColumnName a -> AST.UQColumnName a -> Bool + sameCol (AST.QColumnName _ _ fromName) (AST.QColumnName _ _ toName) = fromName == toName + in if sameCol from to + then [] + else [ DropColumn $ void $ from { columnNameTable = Identity table } + , AddColumn $ void $ to { columnNameTable = Identity table } + ] + getSchemaChange (AST.AlterTableAddColumns _ (AST.RTableName table _) (c:|cs)) = + let toAddColumn uqcn = AddColumn $ void $ uqcn { columnNameTable = Identity table } + in map toAddColumn (c:cs) + +toUQCN :: AST.RColumnRef a -> UQColumnName () +toUQCN (AST.RColumnRef (QColumnName _ _ column)) = QColumnName () None column +toUQCN (AST.RColumnAlias (ColumnAlias _ column _)) = QColumnName () None column + +instance HasSchemaChange (AST.ResolutionError a) where + getSchemaChange (AST.MissingDatabase db) = [CreateDatabase (void db) HMS.empty] + + getSchemaChange (AST.MissingSchema oqsn) = maybeToList $ do + case schemaNameType oqsn of + NormalSchema -> pure () + SessionSchema -> error "missing session schema?" + db <- AST.schemaNameDatabase oqsn + pure $ CreateSchema (void oqsn { schemaNameDatabase = pure db } ) HMS.empty + + getSchemaChange (AST.MissingTable oqtn) = maybeToList $ do + oqsn <- AST.tableNameSchema oqtn + db <- AST.schemaNameDatabase oqsn + pure $ CreateTable (void oqtn { tableNameSchema = pure oqsn { schemaNameDatabase = pure db } } ) (persistentTable []) + + getSchemaChange (AST.AmbiguousTable _) = [] + + getSchemaChange (AST.MissingColumn oqcn) = maybeToList $ do + oqtn <- AST.columnNameTable oqcn + oqsn <- AST.tableNameSchema oqtn + db <- AST.schemaNameDatabase oqsn + pure $ AddColumn $ void oqcn { columnNameTable = pure oqtn { tableNameSchema = pure oqsn { schemaNameDatabase = pure db } } } + + getSchemaChange (AST.AmbiguousColumn _) = [] + getSchemaChange (AST.UnintroducedTable _) = [] + getSchemaChange (AST.UnexpectedTable table) = [DropTable (void table)] + getSchemaChange (AST.UnexpectedSchema table) = [DropSchema (void table)] + getSchemaChange (AST.BadPositionalReference _ _) = [] + +instance HasSchemaChange (ResolutionSuccess a) where + getSchemaChange (ColumnRefDefaulted _ (RColumnRef name)) = [AddColumn $ void name] + getSchemaChange (TableNameDefaulted _ (RTableName name table)) = [CreateTable (void name) table] + getSchemaChange (TableRefDefaulted _ (RTableRef name table)) = [CreateTable (void name) table] + + -- I don't think we can infer anything about the schema from aliases + getSchemaChange (ColumnRefDefaulted _ (RColumnAlias _)) = [] + getSchemaChange (TableRefDefaulted _ (RTableAlias _)) = [] + + -- resolving means we have it right, no changes + getSchemaChange (TableNameResolved _ _) = [] + getSchemaChange (CreateTableNameResolved _ _) = [] + getSchemaChange (CreateSchemaNameResolved _ _) = [] + getSchemaChange (TableRefResolved _ _) = [] + getSchemaChange (ColumnRefResolved _ _) = [] diff --git a/src/Database/Sql/Util/Scope.hs b/src/Database/Sql/Util/Scope.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Util/Scope.hs @@ -0,0 +1,834 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Database.Sql.Util.Scope + ( runResolverWarn, runResolverWError, runResolverNoWarn + , WithColumns (..) + , queryColumnNames + , resolveStatement, resolveQuery, resolveQueryWithColumns, resolveSelectAndOrders, resolveCTE, resolveInsert + , resolveInsertValues, resolveDefaultExpr, resolveDelete, resolveTruncate + , resolveCreateTable, resolveTableDefinition, resolveColumnOrConstraint + , resolveColumnDefinition, resolveAlterTable, resolveDropTable + , resolveSelectColumns, resolvedTableHasName, resolvedTableHasSchema + , resolveSelection, resolveExpr, resolveTableName, resolveDropTableName + , resolveCreateSchemaName, resolveSchemaName + , resolveTableRef, resolveColumnName, resolvePartition, resolveSelectFrom + , resolveTablish, resolveJoinCondition, resolveSelectWhere, resolveSelectTimeseries + , resolveSelectGroup, resolveSelectHaving, resolveOrder + , selectionNames, mkTableSchemaMember + ) where + +import Prelude hiding ((&&), (||), not) +import Data.Predicate.Class +import Data.Maybe (mapMaybe) +import Data.Maybe.More (overJust) +import Data.Either (lefts, rights) +import Database.Sql.Type + +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Text.Lazy as TL +import Data.Text.Lazy (Text) + +import Control.Monad.State +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.Except +import Control.Monad.Identity + +import Control.Arrow (first, (&&&)) + +import Data.Proxy (Proxy (..)) + + +makeResolverInfo :: Dialect d => Proxy d -> Catalog -> ResolverInfo a +makeResolverInfo dialect catalog = ResolverInfo + { bindings = emptyBindings + , onCTECollision = + if shouldCTEsShadowTables dialect + then \ f x -> f x + else \ _ x -> x + , selectScope = getSelectScope dialect + , lcolumnsAreVisibleInLateralViews = areLcolumnsVisibleInLateralViews dialect + , .. + } + +makeColumnAlias :: a -> Text -> Resolver ColumnAlias a +makeColumnAlias r alias = ColumnAlias r alias . ColumnAliasId <$> getNextCounter + where + getNextCounter = modify (subtract 1) >> get + +runResolverWarn :: Dialect d => Resolver r a -> Proxy d -> Catalog -> (Either (ResolutionError a) (r a), [Either (ResolutionError a) (ResolutionSuccess a)]) +runResolverWarn resolver dialect catalog = runWriter $ runExceptT $ runReaderT (evalStateT resolver 0) $ makeResolverInfo dialect catalog + + +runResolverWError :: Dialect d => Resolver r a -> Proxy d -> Catalog -> Either [ResolutionError a] ((r a), [ResolutionSuccess a]) +runResolverWError resolver dialect catalog = + let (result, warningsSuccesses) = runResolverWarn resolver dialect catalog + warnings = lefts warningsSuccesses + successes = rights warningsSuccesses + in case (result, warnings) of + (Right x, []) -> Right (x, successes) + (Right _, ws) -> Left ws + (Left e, ws) -> Left (e:ws) + + +runResolverNoWarn :: Dialect d => Resolver r a -> Proxy d -> Catalog -> Either (ResolutionError a) (r a) +runResolverNoWarn resolver dialect catalog = fst $ runResolverWarn resolver dialect catalog + + +resolveStatement :: Dialect d => Statement d RawNames a -> Resolver (Statement d ResolvedNames) a +resolveStatement (QueryStmt stmt) = QueryStmt <$> resolveQuery stmt +resolveStatement (InsertStmt stmt) = InsertStmt <$> resolveInsert stmt +resolveStatement (UpdateStmt stmt) = UpdateStmt <$> resolveUpdate stmt +resolveStatement (DeleteStmt stmt) = DeleteStmt <$> resolveDelete stmt +resolveStatement (TruncateStmt stmt) = TruncateStmt <$> resolveTruncate stmt +resolveStatement (CreateTableStmt stmt) = CreateTableStmt <$> resolveCreateTable stmt +resolveStatement (AlterTableStmt stmt) = AlterTableStmt <$> resolveAlterTable stmt +resolveStatement (DropTableStmt stmt) = DropTableStmt <$> resolveDropTable stmt +resolveStatement (CreateViewStmt stmt) = CreateViewStmt <$> resolveCreateView stmt +resolveStatement (DropViewStmt stmt) = DropViewStmt <$> resolveDropView stmt +resolveStatement (CreateSchemaStmt stmt) = CreateSchemaStmt <$> resolveCreateSchema stmt +resolveStatement (GrantStmt stmt) = pure $ GrantStmt stmt +resolveStatement (RevokeStmt stmt) = pure $ RevokeStmt stmt +resolveStatement (BeginStmt info) = pure $ BeginStmt info +resolveStatement (CommitStmt info) = pure $ CommitStmt info +resolveStatement (RollbackStmt info) = pure $ RollbackStmt info +resolveStatement (ExplainStmt info stmt) = ExplainStmt info <$> resolveStatement stmt +resolveStatement (EmptyStmt info) = pure $ EmptyStmt info + +resolveQuery :: Query RawNames a -> Resolver (Query ResolvedNames) a +resolveQuery = (withColumnsValue <$>) . resolveQueryWithColumns + +resolveQueryWithColumns :: Query RawNames a -> Resolver (WithColumns (Query ResolvedNames)) a +resolveQueryWithColumns (QuerySelect info select) = do + WithColumnsAndOrders select' columns _ <- resolveSelectAndOrders select [] + pure $ WithColumns (QuerySelect info select') columns +resolveQueryWithColumns (QueryExcept info Unused lhs rhs) = do + WithColumns lhs' columns <- resolveQueryWithColumns lhs + rhs' <- resolveQuery rhs + cs <- forM (queryColumnNames lhs') $ \case + RColumnRef QColumnName{..} -> makeColumnAlias columnNameInfo columnNameName + RColumnAlias (ColumnAlias aliasInfo name _) -> makeColumnAlias aliasInfo name + pure $ WithColumns (QueryExcept info (ColumnAliasList cs) lhs' rhs') columns + +resolveQueryWithColumns (QueryUnion info distinct Unused lhs rhs) = do + WithColumns lhs' columns <- resolveQueryWithColumns lhs + rhs' <- resolveQuery rhs + cs <- forM (queryColumnNames lhs') $ \case + RColumnRef QColumnName{..} -> makeColumnAlias columnNameInfo columnNameName + RColumnAlias (ColumnAlias aliasInfo name _) -> makeColumnAlias aliasInfo name + pure $ WithColumns (QueryUnion info distinct (ColumnAliasList cs) lhs' rhs') columns + +resolveQueryWithColumns (QueryIntersect info Unused lhs rhs) = do + WithColumns lhs' columns <- resolveQueryWithColumns lhs + rhs' <- resolveQuery rhs + cs <- forM (queryColumnNames lhs') $ \case + RColumnRef QColumnName{..} -> makeColumnAlias columnNameInfo columnNameName + RColumnAlias (ColumnAlias aliasInfo name _) -> makeColumnAlias aliasInfo name + pure $ WithColumns (QueryIntersect info (ColumnAliasList cs) lhs' rhs') columns + +resolveQueryWithColumns (QueryWith info [] query) = overWithColumns (QueryWith info []) <$> resolveQueryWithColumns query +resolveQueryWithColumns (QueryWith info (cte:ctes) query) = do + cte' <- resolveCTE cte + Catalog{..} <- asks catalog + + let TableAlias _ alias _ = cteAlias cte' + + updateBindings <- fmap ($ local (mapBindings $ bindCTE cte')) $ + case catalogHasTable $ QTableName () None alias of + Exists -> asks onCTECollision + DoesNotExist -> pure id + + WithColumns (QueryWith _ ctes' query') columns <- updateBindings $ resolveQueryWithColumns $ QueryWith info ctes query + pure $ WithColumns (QueryWith info (cte':ctes') query') columns + +resolveQueryWithColumns (QueryOrder info orders query) = do + WithColumns query' columns <- resolveQueryWithColumns query + + ResolvedOrders orders' <- resolveOrders query orders + + pure $ WithColumns (QueryOrder info orders' query') columns + +resolveQueryWithColumns (QueryLimit info limit query) = overWithColumns (QueryLimit info limit) <$> resolveQueryWithColumns query +resolveQueryWithColumns (QueryOffset info offset query) = overWithColumns (QueryOffset info offset) <$> resolveQueryWithColumns query + + +newtype ResolvedOrders a = ResolvedOrders [Order ResolvedNames a] + +resolveOrders :: Query RawNames a -> [Order RawNames a] -> Resolver ResolvedOrders a +resolveOrders query orders = case query of + QuerySelect _ s -> do + -- dispatch to dialect specific binding rules :) + WithColumnsAndOrders _ _ os <- resolveSelectAndOrders s orders + pure $ ResolvedOrders os + q@(QueryExcept _ _ _ _) -> do + q'@(QueryExcept _ (ColumnAliasList cs) _ _) <- resolveQuery q + let exprs = map (\ c@(ColumnAlias info _ _) -> ColumnExpr info $ RColumnAlias c) cs + bindAliasedColumns (queryColumnNames q') $ ResolvedOrders <$> mapM (resolveOrder exprs) orders + q@(QueryUnion _ _ _ _ _) -> do + q'@(QueryUnion _ _ (ColumnAliasList cs) _ _) <- resolveQuery q + let exprs = map (\ c@(ColumnAlias info _ _) -> ColumnExpr info $ RColumnAlias c) cs + bindAliasedColumns (queryColumnNames q') $ ResolvedOrders <$> mapM (resolveOrder exprs) orders + q@(QueryIntersect _ _ _ _) -> do + q'@(QueryIntersect _ (ColumnAliasList cs) _ _) <- resolveQuery q + let exprs = map (\ c@(ColumnAlias info _ _) -> ColumnExpr info $ RColumnAlias c) cs + bindAliasedColumns (queryColumnNames q') $ ResolvedOrders <$> mapM (resolveOrder exprs) orders + QueryWith _ _ _ -> error "unexpected AST: QueryOrder enclosing QueryWith" + QueryOrder _ _ q -> do + -- this case (nested orders) is possible in presto, but not vertica or hive + resolveOrders q orders + QueryLimit _ _ q -> resolveOrders q orders + QueryOffset _ _ q -> resolveOrders q orders + + +bindCTE :: CTE ResolvedNames a -> Bindings a -> Bindings a +bindCTE CTE{..} = + let columns = + case cteColumns of + [] -> queryColumnNames cteQuery + cs -> map RColumnAlias cs + cte = (cteAlias, columns) + in \ Bindings{..} -> Bindings{boundCTEs = cte:boundCTEs, ..} + + +selectionNames :: Selection ResolvedNames a -> [RColumnRef a] +selectionNames (SelectExpr _ [alias] (ColumnExpr _ ref)) = + let refName = case ref of + RColumnRef (QColumnName _ _ name) -> name + RColumnAlias (ColumnAlias _ name _) -> name + ColumnAlias _ aliasName _ = alias + in if (refName == aliasName) then [ref] else [RColumnAlias alias] +selectionNames (SelectExpr _ aliases _) = map RColumnAlias aliases +selectionNames (SelectStar _ _ (StarColumnNames referents)) = referents + + +selectionExprs :: Selection ResolvedNames a -> [Expr ResolvedNames a] +selectionExprs (SelectExpr info aliases _) = map (ColumnExpr info . RColumnAlias) aliases +selectionExprs (SelectStar info _ (StarColumnNames referents)) = map (ColumnExpr info) referents + + +queryColumnNames :: Query ResolvedNames a -> [RColumnRef a] +queryColumnNames (QuerySelect _ Select{selectCols = SelectColumns _ cols}) = cols >>= selectionNames +queryColumnNames (QueryExcept _ (ColumnAliasList cs) _ _) = map RColumnAlias cs +queryColumnNames (QueryUnion _ _ (ColumnAliasList cs) _ _) = map RColumnAlias cs +queryColumnNames (QueryIntersect _ (ColumnAliasList cs) _ _) = map RColumnAlias cs +queryColumnNames (QueryWith _ _ query) = queryColumnNames query +queryColumnNames (QueryOrder _ _ query) = queryColumnNames query +queryColumnNames (QueryLimit _ _ query) = queryColumnNames query +queryColumnNames (QueryOffset _ _ query) = queryColumnNames query + +resolveSelectAndOrders :: Select RawNames a -> [Order RawNames a] -> Resolver (WithColumnsAndOrders (Select ResolvedNames)) a +resolveSelectAndOrders Select{..} orders = do + (selectFrom', columns) <- overJust resolveSelectFrom selectFrom >>= \case + Nothing -> pure (Nothing, []) + Just (WithColumns selectFrom' columns) -> pure (Just selectFrom', columns) + + selectTimeseries' <- overJust (bindColumns columns . resolveSelectTimeseries) selectTimeseries + + maybeBindTimeSlice selectTimeseries' $ do + selectCols' <- bindColumns columns $ resolveSelectColumns columns selectCols + + let selectedAliases = selectionNames =<< selectColumnsList selectCols' + selectedExprs = selectionExprs =<< selectColumnsList selectCols' + + SelectScope{..} <- (\ f -> f columns selectedAliases) <$> asks selectScope + + selectHaving' <- bindForHaving $ overJust resolveSelectHaving selectHaving + selectWhere' <- bindForWhere $ overJust resolveSelectWhere selectWhere + selectGroup' <- bindForGroup $ overJust (resolveSelectGroup selectedExprs) selectGroup + selectNamedWindow' <- bindForNamedWindow $ overJust resolveSelectNamedWindow selectNamedWindow + orders' <- bindForOrder $ mapM (resolveOrder selectedExprs) orders + let select = Select { selectCols = selectCols' + , selectFrom = selectFrom' + , selectWhere = selectWhere' + , selectTimeseries = selectTimeseries' + , selectGroup = selectGroup' + , selectHaving = selectHaving' + , selectNamedWindow = selectNamedWindow' + , .. + } + pure $ WithColumnsAndOrders select columns orders' + where + maybeBindTimeSlice Nothing = id + maybeBindTimeSlice (Just timeseries) = bindColumns [(Nothing, [RColumnAlias $ selectTimeseriesSliceName timeseries])] + + +resolveCTE :: CTE RawNames a -> Resolver (CTE ResolvedNames) a +resolveCTE CTE{..} = do + cteQuery' <- resolveQuery cteQuery + pure $ CTE + { cteQuery = cteQuery' + , .. + } + +resolveInsert :: Insert RawNames a -> Resolver (Insert ResolvedNames) a +resolveInsert Insert{..} = do + insertTable'@(RTableName fqtn _) <- resolveTableName insertTable + let insertColumns' = fmap (fmap (\uqcn -> RColumnRef $ uqcn { columnNameTable = Identity fqtn })) insertColumns + insertValues' <- resolveInsertValues insertValues + pure $ Insert + { insertTable = insertTable' + , insertColumns = insertColumns' + , insertValues = insertValues' + , .. + } + +resolveInsertValues :: InsertValues RawNames a -> Resolver (InsertValues ResolvedNames) a +resolveInsertValues (InsertExprValues info exprs) = InsertExprValues info <$> mapM (mapM resolveDefaultExpr) exprs +resolveInsertValues (InsertSelectValues query) = InsertSelectValues <$> resolveQuery query +resolveInsertValues (InsertDefaultValues info) = pure $ InsertDefaultValues info +resolveInsertValues (InsertDataFromFile info path) = pure $ InsertDataFromFile info path + +resolveDefaultExpr :: DefaultExpr RawNames a -> Resolver (DefaultExpr ResolvedNames) a +resolveDefaultExpr (DefaultValue info) = pure $ DefaultValue info +resolveDefaultExpr (ExprValue expr) = ExprValue <$> resolveExpr expr + +resolveUpdate :: Update RawNames a -> Resolver (Update ResolvedNames) a +resolveUpdate Update{..} = do + updateTable'@(RTableName fqtn schemaMember) <- resolveTableName updateTable + + let uqcns = columnsList schemaMember + tgtColRefs = map (\uqcn -> RColumnRef $ uqcn { columnNameInfo = tableNameInfo fqtn + , columnNameTable = Identity fqtn + }) uqcns + tgtColSet = case updateAlias of + Just alias -> (Just $ RTableAlias alias, tgtColRefs) + Nothing -> (Just $ RTableRef fqtn schemaMember, tgtColRefs) + + (updateFrom', srcColSet) <- case updateFrom of + Just tablish -> resolveTablish tablish >>= (\ (WithColumns t cs) -> return (Just t, cs)) + Nothing -> return (Nothing, []) + + updateSetExprs' <- bindColumns srcColSet $ + mapM (\(uqcn, expr) -> (RColumnRef uqcn { columnNameTable = Identity fqtn},) <$> resolveDefaultExpr expr) updateSetExprs + + updateWhere' <- bindColumns (tgtColSet:srcColSet) $ mapM resolveExpr updateWhere + + pure $ Update + { updateTable = updateTable' + , updateSetExprs = updateSetExprs' + , updateFrom = updateFrom' + , updateWhere = updateWhere' + , .. + } + +resolveDelete :: forall a . Delete RawNames a -> Resolver (Delete ResolvedNames) a +resolveDelete (Delete info tableName expr) = do + tableName'@(RTableName fqtn table@SchemaMember{..}) <- resolveTableName tableName + when (tableType /= Table) $ fail $ "delete only works on tables; can't delete on a " ++ show tableType + let QTableName tableInfo _ _ = tableName + bindColumns [(Just $ RTableRef fqtn table, map (\ (QColumnName () None column) -> RColumnRef $ QColumnName tableInfo (pure fqtn) column) columnsList)] $ do + expr' <- overJust resolveExpr expr + pure $ Delete info tableName' expr' + + +resolveTruncate :: Truncate RawNames a -> Resolver (Truncate ResolvedNames) a +resolveTruncate (Truncate info name) = do + name' <- resolveTableName name + pure $ Truncate info name' + + +resolveCreateTable :: forall d a . (Dialect d) => CreateTable d RawNames a -> Resolver (CreateTable d ResolvedNames) a +resolveCreateTable CreateTable{..} = do + createTableName'@(RCreateTableName fqtn _) <- resolveCreateTableName createTableName createTableIfNotExists + + WithColumns createTableDefinition' columns <- resolveTableDefinition fqtn createTableDefinition + bindColumns columns $ do + createTableExtra' <- overJust (resolveCreateTableExtra (Proxy :: Proxy d)) createTableExtra + pure $ CreateTable + { createTableName = createTableName' + , createTableDefinition = createTableDefinition' + , createTableExtra = createTableExtra' + , .. + } + + + +mkTableSchemaMember :: [UQColumnName ()] -> SchemaMember +mkTableSchemaMember columnsList = SchemaMember{..} + where + tableType = Table + persistence = Persistent + viewQuery = Nothing + +resolveTableDefinition :: FQTableName a -> TableDefinition d RawNames a -> Resolver (WithColumns (TableDefinition d ResolvedNames)) a +resolveTableDefinition fqtn (TableColumns info cs) = do + cs' <- mapM resolveColumnOrConstraint cs + let columns = mapMaybe columnOrConstraintToColumn $ NonEmpty.toList cs' + table = mkTableSchemaMember $ map (\ c -> c{columnNameInfo = (), columnNameTable = None}) columns + pure $ WithColumns (TableColumns info cs') [(Just $ RTableRef fqtn table, map RColumnRef columns)] + where + columnOrConstraintToColumn (ColumnOrConstraintConstraint _) = Nothing + columnOrConstraintToColumn (ColumnOrConstraintColumn ColumnDefinition{columnDefinitionName = QColumnName columnInfo None name}) = + Just $ QColumnName columnInfo (pure fqtn) name + + +resolveTableDefinition _ (TableLike info name) = do + name' <- resolveTableName name + pure $ WithColumns (TableLike info name') [] + +resolveTableDefinition fqtn (TableAs info cols query) = do + query' <- resolveQuery query + let columns = queryColumnNames query' + table = mkTableSchemaMember $ map toUQCN columns + toUQCN (RColumnRef fqcn) = fqcn{columnNameInfo = (), columnNameTable = None} + toUQCN (RColumnAlias (ColumnAlias _ cn _)) = QColumnName{..} + where + columnNameInfo = () + columnNameName = cn + columnNameTable = None + pure $ WithColumns (TableAs info cols query') [(Just $ RTableRef fqtn table, columns)] + +resolveTableDefinition _ (TableNoColumnInfo info) = do + pure $ WithColumns (TableNoColumnInfo info) [] + + +resolveColumnOrConstraint :: ColumnOrConstraint d RawNames a -> Resolver (ColumnOrConstraint d ResolvedNames) a +resolveColumnOrConstraint (ColumnOrConstraintColumn column) = ColumnOrConstraintColumn <$> resolveColumnDefinition column +resolveColumnOrConstraint (ColumnOrConstraintConstraint constraint) = pure $ ColumnOrConstraintConstraint constraint + + +resolveColumnDefinition :: ColumnDefinition d RawNames a -> Resolver (ColumnDefinition d ResolvedNames) a +resolveColumnDefinition ColumnDefinition{..} = do + columnDefinitionDefault' <- overJust resolveExpr columnDefinitionDefault + pure $ ColumnDefinition + { columnDefinitionDefault = columnDefinitionDefault' + , .. + } + + +resolveAlterTable :: AlterTable RawNames a -> Resolver (AlterTable ResolvedNames) a +resolveAlterTable (AlterTableRenameTable info old new) = do + old'@(RTableName (QTableName _ (Identity oldSchema@(QSchemaName _ (Identity oldDb@(DatabaseName _ _)) _ oldSchemaType)) _) table) <- resolveTableName old + + let new'@(RTableName (QTableName _ (Identity (QSchemaName _ _ _ newSchemaType)) _) _) = case new of + QTableName tInfo (Just (QSchemaName sInfo (Just db) s sType)) t -> + RTableName (QTableName tInfo (pure (QSchemaName sInfo (pure db) s sType)) t) table + + QTableName tInfo (Just (QSchemaName sInfo Nothing s sType)) t -> + RTableName (QTableName tInfo (pure (QSchemaName sInfo (pure oldDb) s sType)) t) table + + QTableName tInfo Nothing t -> + RTableName (QTableName tInfo (pure oldSchema) t) table + + case (oldSchemaType, newSchemaType) of + (NormalSchema, NormalSchema) -> pure () + (SessionSchema, SessionSchema) -> pure () + (NormalSchema, SessionSchema) -> error "can't rename a table into the session schema" + (SessionSchema, NormalSchema) -> error "can't rename a table out of the session schema" + + pure $ AlterTableRenameTable info old' new' + +resolveAlterTable (AlterTableRenameColumn info table old new) = do + table' <- resolveTableName table + pure $ AlterTableRenameColumn info table' old new +resolveAlterTable (AlterTableAddColumns info table columns) = do + table' <- resolveTableName table + pure $ AlterTableAddColumns info table' columns + + +resolveDropTable :: DropTable RawNames a -> Resolver (DropTable ResolvedNames) a +resolveDropTable DropTable{..} = do + dropTableNames' <- mapM resolveDropTableName dropTableNames + pure $ DropTable + { dropTableNames = dropTableNames' + , .. + } + + +resolveCreateView :: CreateView RawNames a -> Resolver (CreateView ResolvedNames) a +resolveCreateView CreateView{..} = do + createViewName' <- resolveCreateTableName createViewName createViewIfNotExists + createViewQuery' <- resolveQuery createViewQuery + pure $ CreateView + { createViewName = createViewName' + , createViewQuery = createViewQuery' + , .. + } + + +resolveDropView :: DropView RawNames a -> Resolver (DropView ResolvedNames) a +resolveDropView DropView{..} = do + dropViewName' <- resolveDropTableName dropViewName + pure $ DropView + { dropViewName = dropViewName' + , .. + } + + +resolveCreateSchema :: CreateSchema RawNames a -> Resolver (CreateSchema ResolvedNames) a +resolveCreateSchema CreateSchema{..} = do + createSchemaName' <- resolveCreateSchemaName createSchemaName createSchemaIfNotExists + pure $ CreateSchema + { createSchemaName = createSchemaName' + , .. + } + + +resolveSelectColumns :: ColumnSet a -> SelectColumns RawNames a -> Resolver (SelectColumns ResolvedNames) a +resolveSelectColumns columns (SelectColumns info selections) = SelectColumns info <$> mapM (resolveSelection columns) selections + + +qualifiedOnly :: [(Maybe a, b)] -> [(a, b)] +qualifiedOnly = mapMaybe (\(mTable, cs) -> case mTable of + (Just t) -> Just (t, cs) + Nothing -> Nothing) + +resolveSelection :: ColumnSet a -> Selection RawNames a -> Resolver (Selection ResolvedNames) a +resolveSelection columns (SelectStar info Nothing Unused) = do + pure $ SelectStar info Nothing $ StarColumnNames $ map (const info <$>) $ snd =<< columns + +resolveSelection columns (SelectStar info (Just oqtn@(QTableName _ (Just schema) _)) Unused) = do + let qualifiedColumns = qualifiedOnly columns + case filter ((resolvedTableHasSchema schema && resolvedTableHasName oqtn) . fst) qualifiedColumns of + [] -> throwError $ UnintroducedTable oqtn + [(t, cs)] -> pure $ SelectStar info (Just t) $ StarColumnNames $ map (const info <$>) cs + _ -> throwError $ AmbiguousTable oqtn + +resolveSelection columns (SelectStar info (Just oqtn@(QTableName tableInfo Nothing table)) Unused) = do + let qualifiedColumns = qualifiedOnly columns + case filter (resolvedTableHasName oqtn . fst) qualifiedColumns of + [] -> throwError $ UnintroducedTable $ QTableName tableInfo Nothing table + [(t, cs)] -> pure $ SelectStar info (Just t) $ StarColumnNames $ map (const info <$>) cs + _ -> throwError $ AmbiguousTable $ QTableName tableInfo Nothing table + +resolveSelection _ (SelectExpr info alias expr) = SelectExpr info alias <$> resolveExpr expr + + +resolveExpr :: Expr RawNames a -> Resolver (Expr ResolvedNames) a +resolveExpr (BinOpExpr info op lhs rhs) = BinOpExpr info op <$> resolveExpr lhs <*> resolveExpr rhs + +resolveExpr (CaseExpr info whens else_) = CaseExpr info <$> mapM resolveWhen whens <*> overJust resolveExpr else_ + where + resolveWhen (when_, then_) = (,) <$> resolveExpr when_ <*> resolveExpr then_ + +resolveExpr (UnOpExpr info op expr) = UnOpExpr info op <$> resolveExpr expr +resolveExpr (LikeExpr info op escape pattern expr) = do + escape' <- overJust (fmap Escape . resolveExpr . escapeExpr) escape + pattern' <- Pattern <$> resolveExpr (patternExpr pattern) + expr' <- resolveExpr expr + pure $ LikeExpr info op escape' pattern' expr' + +resolveExpr (ConstantExpr info constant) = pure $ ConstantExpr info constant +resolveExpr (ColumnExpr info column) = ColumnExpr info <$> resolveColumnName column +resolveExpr (InListExpr info list expr) = InListExpr info <$> mapM resolveExpr list <*> resolveExpr expr +resolveExpr (InSubqueryExpr info query expr) = do + query' <- resolveQuery query + expr' <- resolveExpr expr + pure $ InSubqueryExpr info query' expr' + +resolveExpr (BetweenExpr info expr start end) = + BetweenExpr info <$> resolveExpr expr <*> resolveExpr start <*> resolveExpr end + +resolveExpr (OverlapsExpr info range1 range2) = OverlapsExpr info <$> resolveRange range1 <*> resolveRange range2 + where + resolveRange (from, to) = (,) <$> resolveExpr from <*> resolveExpr to + +resolveExpr (FunctionExpr info name distinct args params filter' over) = + FunctionExpr info name distinct <$> mapM resolveExpr args <*> mapM resolveParam params <*> overJust resolveFilter filter' <*> overJust resolveOverSubExpr over + where + resolveParam (param, expr) = (param,) <$> resolveExpr expr + -- T482568: expand named windows on resolve + resolveOverSubExpr (OverWindowExpr i window) = + OverWindowExpr i <$> resolveWindowExpr window + resolveOverSubExpr (OverWindowName i windowName) = + pure $ OverWindowName i windowName + resolveOverSubExpr (OverPartialWindowExpr i partWindow) = + OverPartialWindowExpr i <$> resolvePartialWindowExpr partWindow + resolveFilter (Filter i expr) = + Filter i <$> resolveExpr expr + +resolveExpr (AtTimeZoneExpr info expr tz) = AtTimeZoneExpr info <$> resolveExpr expr <*> resolveExpr tz +resolveExpr (SubqueryExpr info query) = SubqueryExpr info <$> resolveQuery query +resolveExpr (ArrayExpr info array) = ArrayExpr info <$> mapM resolveExpr array +resolveExpr (ExistsExpr info query) = ExistsExpr info <$> resolveQuery query +resolveExpr (FieldAccessExpr info expr field) = FieldAccessExpr info <$> resolveExpr expr <*> pure field +resolveExpr (ArrayAccessExpr info expr idx) = ArrayAccessExpr info <$> resolveExpr expr <*> resolveExpr idx +resolveExpr (TypeCastExpr info onFail expr type_) = TypeCastExpr info onFail <$> resolveExpr expr <*> pure type_ +resolveExpr (VariableSubstitutionExpr info) = pure $ VariableSubstitutionExpr info + +resolveOrder :: [Expr ResolvedNames a] + -> Order RawNames a + -> Resolver (Order ResolvedNames) a +resolveOrder exprs (Order i posOrExpr direction nullPos) = + Order i <$> resolvePositionOrExpr exprs posOrExpr <*> pure direction <*> pure nullPos + +resolveWindowExpr :: WindowExpr RawNames a + -> Resolver (WindowExpr ResolvedNames) a +resolveWindowExpr WindowExpr{..} = + do + windowExprPartition' <- overJust resolvePartition windowExprPartition + windowExprOrder' <- mapM (resolveOrder []) windowExprOrder + pure $ WindowExpr + { windowExprPartition = windowExprPartition' + , windowExprOrder = windowExprOrder' + , .. + } + +resolvePartialWindowExpr :: PartialWindowExpr RawNames a + -> Resolver (PartialWindowExpr ResolvedNames) a +resolvePartialWindowExpr PartialWindowExpr{..} = + do + partWindowExprOrder' <- mapM (resolveOrder []) partWindowExprOrder + partWindowExprPartition' <- mapM resolvePartition partWindowExprPartition + pure $ PartialWindowExpr + { partWindowExprOrder = partWindowExprOrder' + , partWindowExprPartition = partWindowExprPartition' + , .. + } + +resolveNamedWindowExpr :: NamedWindowExpr RawNames a + -> Resolver (NamedWindowExpr ResolvedNames) a +resolveNamedWindowExpr (NamedWindowExpr info name window) = + NamedWindowExpr info name <$> resolveWindowExpr window +resolveNamedWindowExpr (NamedPartialWindowExpr info name partWindow) = + NamedPartialWindowExpr info name <$> resolvePartialWindowExpr partWindow + +resolveTableName :: OQTableName a -> Resolver RTableName a +resolveTableName table = do + Catalog{..} <- asks catalog + lift $ lift $ catalogResolveTableName table + +resolveCreateTableName :: CreateTableName RawNames a -> Maybe a -> Resolver (CreateTableName ResolvedNames) a +resolveCreateTableName tableName ifNotExists = do + Catalog{..} <- asks catalog + tableName'@(RCreateTableName fqtn existence) <- lift $ lift $ catalogResolveCreateTableName tableName + + when ((existence, void ifNotExists) == (Exists, Nothing)) $ tell [ Left $ UnexpectedTable fqtn ] + + pure $ tableName' + +resolveDropTableName :: DropTableName RawNames a -> Resolver (DropTableName ResolvedNames) a +resolveDropTableName tableName = do + (getName <$> resolveTableName tableName) + `catchError` handleMissing + where + getName (RTableName name table) = RDropExistingTableName name table + handleMissing (MissingTable name) = pure $ RDropMissingTableName name + handleMissing e = throwError e + + +resolveCreateSchemaName :: CreateSchemaName RawNames a -> Maybe a -> Resolver (CreateSchemaName ResolvedNames) a +resolveCreateSchemaName schemaName ifNotExists = do + Catalog{..} <- asks catalog + schemaName'@(RCreateSchemaName fqsn existence) <- lift $ lift $ catalogResolveCreateSchemaName schemaName + when ((existence, void ifNotExists) == (Exists, Nothing)) $ tell [ Left $ UnexpectedSchema fqsn ] + pure schemaName' + +resolveSchemaName :: SchemaName RawNames a -> Resolver (SchemaName ResolvedNames) a +resolveSchemaName schemaName = do + Catalog{..} <- asks catalog + lift $ lift $ catalogResolveSchemaName schemaName + + +resolveTableRef :: OQTableName a -> Resolver (WithColumns RTableRef) a +resolveTableRef tableName = do + ResolverInfo{catalog = Catalog{..}, bindings = Bindings{..}, ..} <- ask + lift $ lift $ catalogResolveTableRef boundCTEs tableName + + +resolveColumnName :: forall a . OQColumnName a -> Resolver (RColumnRef) a +resolveColumnName columnName = do + (Catalog{..}, Bindings{..}) <- asks (catalog &&& bindings) + lift $ lift $ catalogResolveColumnName boundColumns columnName + + +resolvePartition :: Partition RawNames a -> Resolver (Partition ResolvedNames) a +resolvePartition (PartitionBy info exprs) = PartitionBy info <$> mapM resolveExpr exprs +resolvePartition (PartitionBest info) = pure $ PartitionBest info +resolvePartition (PartitionNodes info) = pure $ PartitionNodes info + + +resolveSelectFrom :: SelectFrom RawNames a -> Resolver (WithColumns (SelectFrom ResolvedNames)) a +resolveSelectFrom (SelectFrom info tablishes) = do + tablishesWithColumns <- mapM resolveTablish tablishes + let (tablishes', css) = unzip $ map (\ (WithColumns t cs) -> (t, cs)) tablishesWithColumns + pure $ WithColumns (SelectFrom info tablishes') $ concat css + + +resolveTablish :: forall a . Tablish RawNames a -> Resolver (WithColumns (Tablish ResolvedNames)) a +resolveTablish (TablishTable info aliases name) = do + WithColumns name' columns <- resolveTableRef name + + let columns' = case aliases of + TablishAliasesNone -> columns + TablishAliasesT t -> map (first $ const $ Just $ RTableAlias t) columns + TablishAliasesTC t cs -> [(Just $ RTableAlias t, map RColumnAlias cs)] + + pure $ WithColumns (TablishTable info aliases name') columns' + + +resolveTablish (TablishSubQuery info aliases query) = do + query' <- resolveQuery query + let columns = queryColumnNames query' + (tAlias, cAliases) = case aliases of + TablishAliasesNone -> (Nothing, columns) + TablishAliasesT t -> (Just $ RTableAlias t, columns) + TablishAliasesTC t cs -> (Just $ RTableAlias t, map RColumnAlias cs) + + pure $ WithColumns (TablishSubQuery info aliases query') [(tAlias, cAliases)] + +resolveTablish (TablishJoin info joinType cond lhs rhs) = do + WithColumns lhs' lcolumns <- resolveTablish lhs + + -- special case for Presto + lcolumnsAreVisible <- asks lcolumnsAreVisibleInLateralViews + let bindForRhs = case (lcolumnsAreVisible, rhs) of + (True, TablishLateralView _ _ _) -> bindColumns lcolumns + _ -> id + + WithColumns rhs' rcolumns <- bindForRhs $ resolveTablish rhs + let colsForRestOfQuery = case joinType of + -- for LEFT SEMI JOIN (Hive), the rhs is only in scope in the expr, nowhere else in the query + JoinSemi _ -> lcolumns + _ -> lcolumns ++ rcolumns + bindColumns (lcolumns ++ rcolumns) $ do + cond' <- resolveJoinCondition cond lcolumns rcolumns + pure $ WithColumns (TablishJoin info joinType cond' lhs' rhs') $ colsForRestOfQuery + +resolveTablish (TablishLateralView info LateralView{..} lhs) = do + (lhs', lcolumns) <- case lhs of + Nothing -> return (Nothing, []) + Just tablish -> do + WithColumns lhs' lcolumns <- resolveTablish tablish + return (Just lhs', lcolumns) + + bindColumns lcolumns $ do + lateralViewExprs' <- mapM resolveExpr lateralViewExprs + let view = LateralView + { lateralViewExprs = lateralViewExprs' + , .. + } + + defaultCols <- map RColumnAlias . concat <$> mapM defaultAliases lateralViewExprs' + let rcolumns = case lateralViewAliases of + TablishAliasesNone -> [(Nothing, defaultCols)] + TablishAliasesT t -> [(Just $ RTableAlias t, defaultCols)] + TablishAliasesTC t cs -> [(Just $ RTableAlias t, map RColumnAlias cs)] + + pure $ WithColumns (TablishLateralView info view lhs') $ lcolumns ++ rcolumns + where + defaultAliases (FunctionExpr r (QFunctionName _ _ rawName) _ args _ _ _) = do + let argsLessOne = (length args) - 1 + + alias = makeColumnAlias r + + prependAlias :: Text -> Int -> Resolver ColumnAlias a + prependAlias prefix int = alias $ prefix `TL.append` (TL.pack $ show int) + + name = TL.toLower rawName + + functionSpecificLookups + | name == "explode" = map alias [ "col", "key", "val" ] + | name == "inline" = map alias [ "col1", "col2" ] + | name == "json_tuple" = map (prependAlias "c") $ take argsLessOne [0..] + | name == "parse_url_tuple" = map (prependAlias "c") $ take argsLessOne [0..] + | name == "posexplode" = map alias [ "pos", "val" ] + | name == "stack" = + let n = case head args of + (ConstantExpr _ (NumericConstant _ nText)) -> read $ TL.unpack nText + _ -> argsLessOne -- this should never happen, but if it does, this is a reasonable guess + k = argsLessOne + len = (k `div` n) + (if k `mod` n == 0 then 0 else 1) + in map (prependAlias "col") $ take len [0..] + | otherwise = [] + + sequence functionSpecificLookups + + defaultAliases _ = fail "lateral view must have a FunctionExpr" + + +resolveJoinCondition :: JoinCondition RawNames a -> ColumnSet a -> ColumnSet a -> Resolver (JoinCondition ResolvedNames) a +resolveJoinCondition (JoinNatural info _) lhs rhs = do + let name (RColumnRef (QColumnName _ _ column)) = column + name (RColumnAlias (ColumnAlias _ alias _)) = alias + columns = RNaturalColumns $ do + l <- snd =<< lhs + r <- snd =<< rhs + if name l == name r + then [RUsingColumn l r] + else [] + pure $ JoinNatural info columns + +resolveJoinCondition (JoinOn expr) _ _ = JoinOn <$> resolveExpr expr +resolveJoinCondition (JoinUsing info cols) lhs rhs = JoinUsing info <$> mapM resolveColumn cols + where + resolveColumn (QColumnName columnInfo _ column) = do + let resolveIn columns = + case filter hasName $ snd =<< columns of + [] -> throwError $ MissingColumn $ QColumnName columnInfo Nothing column + [c] -> pure c + _ -> throwError $ AmbiguousColumn $ QColumnName columnInfo Nothing column + hasName (RColumnRef (QColumnName _ _ column')) = column' == column + hasName (RColumnAlias (ColumnAlias _ column' _)) = column' == column + l <- resolveIn lhs + r <- resolveIn rhs + pure $ RUsingColumn l r + + +resolveSelectWhere :: SelectWhere RawNames a -> Resolver (SelectWhere ResolvedNames) a +resolveSelectWhere (SelectWhere info expr) = SelectWhere info <$> resolveExpr expr + +resolveSelectTimeseries :: SelectTimeseries RawNames a -> Resolver (SelectTimeseries ResolvedNames) a +resolveSelectTimeseries SelectTimeseries{..} = do + selectTimeseriesPartition' <- overJust resolvePartition selectTimeseriesPartition + selectTimeseriesOrder' <- resolveExpr selectTimeseriesOrder + pure $ SelectTimeseries + { selectTimeseriesPartition = selectTimeseriesPartition' + , selectTimeseriesOrder = selectTimeseriesOrder' + , .. + } + +resolvePositionOrExpr :: [Expr ResolvedNames a] -> PositionOrExpr RawNames a -> Resolver (PositionOrExpr ResolvedNames) a +resolvePositionOrExpr _ (PositionOrExprExpr expr) = PositionOrExprExpr <$> resolveExpr expr +resolvePositionOrExpr exprs (PositionOrExprPosition info pos Unused) + | pos < 1 = throwError $ BadPositionalReference info pos + | otherwise = + case drop (pos - 1) exprs of + expr:_ -> pure $ PositionOrExprPosition info pos expr + [] -> throwError $ BadPositionalReference info pos + +resolveGroupingElement :: [Expr ResolvedNames a] -> GroupingElement RawNames a -> Resolver (GroupingElement ResolvedNames) a +resolveGroupingElement exprs (GroupingElementExpr info posOrExpr) = + GroupingElementExpr info <$> resolvePositionOrExpr exprs posOrExpr +resolveGroupingElement _ (GroupingElementSet info exprs) = + GroupingElementSet info <$> mapM resolveExpr exprs + +resolveSelectGroup :: [Expr ResolvedNames a] -> SelectGroup RawNames a -> Resolver (SelectGroup ResolvedNames) a +resolveSelectGroup exprs SelectGroup{..} = do + selectGroupGroupingElements' <- mapM (resolveGroupingElement exprs) selectGroupGroupingElements + pure $ SelectGroup + { selectGroupGroupingElements = selectGroupGroupingElements' + , .. + } + +resolveSelectHaving :: SelectHaving RawNames a -> Resolver (SelectHaving ResolvedNames) a +resolveSelectHaving (SelectHaving info exprs) = SelectHaving info <$> mapM resolveExpr exprs + +resolveSelectNamedWindow :: SelectNamedWindow RawNames a + -> Resolver (SelectNamedWindow ResolvedNames) a +resolveSelectNamedWindow (SelectNamedWindow info windows) = + SelectNamedWindow info <$> mapM resolveNamedWindowExpr windows diff --git a/src/Database/Sql/Util/Tables.hs b/src/Database/Sql/Util/Tables.hs new file mode 100644 --- /dev/null +++ b/src/Database/Sql/Util/Tables.hs @@ -0,0 +1,438 @@ +-- Copyright (c) 2017 Uber Technologies, Inc. +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in +-- all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +-- THE SOFTWARE. + +{-# LANGUAGE FlexibleContexts #-} +module Database.Sql.Util.Tables where + +import Data.Foldable + +import Data.Set (Set) +import qualified Data.Set as S + +import Data.Map (Map) +import qualified Data.Map as M + +import Data.Ord +import Data.Monoid +import Data.Maybe (catMaybes) + +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL + +import Control.Monad.Identity +import Control.Monad.Writer +import Control.Monad.Reader +import Control.Monad.State + +import Database.Sql.Type +import Database.Sql.Position + + +-- This describes the usage of a particular table, whether it was read from or +-- written to. Note that if a table is used in both modes, it will show up +-- twice as each mode. +data UsageMode = ReadData | ReadMeta | WriteData | WriteMeta | Unknown + deriving (Show, Eq, Ord) + +data TableUse = TableUse UsageMode FullyQualifiedTableName + deriving (Show, Eq, Ord) + + +getTables :: HasTables q => q -> Set FullyQualifiedTableName +getTables = S.map tableFromUsage . getUsages + where + tableFromUsage (TableUse _ t) = t + +getUsages :: HasTables q => q -> Set TableUse +getUsages = execWriter . flip runReaderT Unknown . goTables + +class HasTables q where + goTables :: q -> ReaderT UsageMode (Writer (Set TableUse)) () + +-- Note that vertica and hive statements have their own table usage instances +-- in their type file. Changes made here should also reflect there. +instance HasTables (Statement d ResolvedNames a) where + goTables (QueryStmt q) = goTables q + goTables (InsertStmt i) = goTables i + goTables (UpdateStmt u) = goTables u + goTables (DeleteStmt d) = goTables d + goTables (TruncateStmt t) = goTables t + goTables (CreateTableStmt c) = goTables c + goTables (AlterTableStmt a) = goTables a + goTables (DropTableStmt d) = goTables d + goTables (CreateViewStmt c) = goTables c + goTables (DropViewStmt d) = goTables d + goTables (CreateSchemaStmt _) = return () + goTables (GrantStmt _) = return () + goTables (RevokeStmt _) = return () + goTables (BeginStmt _) = return () + goTables (CommitStmt _) = return () + goTables (RollbackStmt _) = return () + goTables (ExplainStmt _ s) = goTables s + goTables (EmptyStmt _) = return () + +instance HasTables (Query ResolvedNames a) where + goTables (QuerySelect _ select) = goTables select + goTables (QueryExcept _ _ lhs rhs) = mapM_ goTables [lhs, rhs] + goTables (QueryUnion _ _ _ lhs rhs) = mapM_ goTables [lhs, rhs] + goTables (QueryIntersect _ _ lhs rhs) = mapM_ goTables [lhs, rhs] + goTables (QueryWith _ ctes query) = mapM_ goTables $ query : map cteQuery ctes + goTables (QueryOrder _ orders query) = mapM_ goTables orders >> goTables query + goTables (QueryLimit _ _ query) = goTables query + goTables (QueryOffset _ _ query) = goTables query + +instance HasTables (Select ResolvedNames a) where + goTables (Select {..}) = sequence_ + [ goTables selectCols + , maybe (return ()) goTables selectFrom + , maybe (return ()) goTables selectWhere + , maybe (return ()) goTables selectTimeseries + , maybe (return ()) goTables selectGroup + , maybe (return ()) goTables selectHaving + , maybe (return ()) goTables selectNamedWindow + ] + + +emitTable :: (MonadWriter (Set TableUse) m, + MonadReader UsageMode m) + => FQTableName a -> m () +emitTable t = do + r <- ask + tell . S.singleton $ TableUse r $ fqtnToFQTN t + +instance (HasTables a, HasTables b) => HasTables (a, b) where + goTables (a, b) = goTables a >> goTables b + +instance HasTables (RColumnRef a) where + goTables (RColumnRef fqcn) = emitTable . runIdentity $ columnNameTable fqcn + goTables (RColumnAlias _) = return () -- the table that introduced it will get iterated over anyway. (shrug) + +instance HasTables (FQTableName a) where + goTables fqtn = emitTable fqtn + +instance HasTables (RTableName a) where + goTables (RTableName table _) = emitTable table + +instance HasTables (SelectColumns ResolvedNames a) where + goTables (SelectColumns _ columns) = mapM_ goTables columns + +instance HasTables (SelectFrom ResolvedNames a) where + goTables (SelectFrom _ tablishes) = local (\_ -> ReadData) $ mapM_ goTables tablishes + +instance HasTables (SelectWhere ResolvedNames a) where + goTables (SelectWhere _ condition) = goTables condition + +instance HasTables (SelectTimeseries ResolvedNames a) where + goTables (SelectTimeseries _ _ _ partition expr) = do + goTables partition + goTables expr + +instance HasTables (PositionOrExpr ResolvedNames a) where + goTables (PositionOrExprPosition _ _ _) = return () + goTables (PositionOrExprExpr expr) = goTables expr + +instance HasTables (GroupingElement ResolvedNames a) where + goTables (GroupingElementExpr _ posOrExpr) = goTables posOrExpr + goTables (GroupingElementSet _ exprs) = mapM_ goTables exprs + +instance HasTables (SelectGroup ResolvedNames a) where + goTables (SelectGroup _ groupingElements) = mapM_ goTables groupingElements + +instance HasTables (SelectHaving ResolvedNames a) where + goTables (SelectHaving _ havings) = mapM_ goTables havings + +instance HasTables (SelectNamedWindow ResolvedNames a) where + goTables (SelectNamedWindow _ windows) = mapM_ goTables windows + +instance HasTables (NamedWindowExpr ResolvedNames a) where + goTables (NamedWindowExpr _ _ windowExpr) = goTables windowExpr + goTables (NamedPartialWindowExpr _ _ partial) = goTables partial + +instance HasTables (WindowExpr ResolvedNames a) where + goTables (WindowExpr _ mPartition orders _) = do + goTables mPartition + mapM_ goTables orders + +instance HasTables (PartialWindowExpr ResolvedNames a) where + goTables (PartialWindowExpr _ _ mPartition orders _) = do + goTables mPartition + mapM_ goTables orders + +instance HasTables (Selection ResolvedNames a) where + goTables (SelectStar _ _ _) = return () + goTables (SelectExpr _ _ expr) = goTables expr + +instance HasTables (Insert ResolvedNames a) where + goTables Insert{..} = do + local (\_ -> WriteData) $ goTables insertTable + goTables insertValues + +instance HasTables (InsertValues ResolvedNames a) where + goTables (InsertExprValues _ e) = goTables e + goTables (InsertSelectValues q) = goTables q + goTables (InsertDefaultValues _) = return () + goTables (InsertDataFromFile _ _) = return () + +instance HasTables (DefaultExpr ResolvedNames a) where + goTables (DefaultValue _) = return () + goTables (ExprValue e) = goTables e + +instance HasTables a => HasTables (NonEmpty a) where + goTables ne = mapM_ goTables ne + +instance HasTables a => HasTables (Maybe a) where + goTables Nothing = return () + goTables (Just a) = goTables a + +instance HasTables (Update ResolvedNames a) where + goTables Update{..} = do + local (\_ -> WriteData) $ goTables updateTable + local (\_ -> ReadData) $ goTables updateSetExprs + local (\_ -> ReadData) $ goTables updateFrom + goTables updateWhere + +instance HasTables (Delete ResolvedNames a) where + goTables (Delete _ table expr) = do + local (\_ -> WriteData) $ goTables table + goTables expr + +instance HasTables (CreateTable d ResolvedNames a) where + goTables CreateTable{createTableName = RCreateTableName table _, ..} = do + -- TODO handle createTableExtra, and the dialect instances + local (\_ -> WriteData) $ emitTable table + goTables createTableDefinition + +instance HasTables (TableDefinition d ResolvedNames a) where + goTables (TableColumns _ s) = goTables s + goTables (TableLike _ table) = goTables table + goTables (TableAs _ _ query) = goTables query + goTables (TableNoColumnInfo _) = return () + +instance HasTables (ColumnOrConstraint d ResolvedNames a) where + goTables (ColumnOrConstraintColumn c) = goTables c + goTables (ColumnOrConstraintConstraint _) = return () + +instance HasTables (ColumnDefinition d ResolvedNames a) where + goTables ColumnDefinition{..} = goTables columnDefinitionDefault + +instance HasTables (Truncate ResolvedNames a) where + goTables (Truncate _ tn) = local (\_ -> WriteData) $ goTables tn + +instance HasTables (AlterTable ResolvedNames a) where + goTables (AlterTableRenameTable _ tl tr) = do + -- Since renaming table both reads and writes (drops) the source, + -- we report twice. + local (\_ -> ReadData) $ goTables tl + local (\_ -> WriteData) $ goTables tl + local (\_ -> WriteData) $ goTables tr + goTables (AlterTableRenameColumn _ t _ _) = + local (\_ -> WriteMeta) $ goTables t + goTables (AlterTableAddColumns _ t _) = + local (\_ -> WriteData) $ goTables t + +instance HasTables (DropTable ResolvedNames a) where + goTables DropTable{dropTableNames = tables} = + mapM_ + (\case + RDropExistingTableName table _ -> local (\_ -> WriteData) $ emitTable table + RDropMissingTableName _ -> pure () + ) + tables + +instance HasTables (CreateView ResolvedNames a) where + goTables CreateView{createViewName = RCreateTableName view _, ..} = do + local (\_ -> WriteMeta) $ emitTable view + goTables createViewQuery + +instance HasTables (DropView ResolvedNames a) where + goTables DropView{dropViewName = RDropExistingTableName view _} = local (\_ -> WriteMeta) $ emitTable view + goTables DropView{dropViewName = RDropMissingTableName _} = pure () + +instance HasTables (Tablish ResolvedNames a) where + goTables (TablishTable _ _ (RTableRef fqtn _)) = emitTable fqtn + goTables (TablishTable _ _ (RTableAlias _)) = return () + goTables (TablishSubQuery _ _ query) = goTables query + goTables (TablishLateralView _ LateralView{..} lhs) = goTables lhs >> mapM_ goTables lateralViewExprs + goTables (TablishJoin _ _ cond outer inner) = do + case cond of + JoinOn expr -> goTables expr + JoinNatural _ _ -> return () + JoinUsing _ _ -> return () + + goTables outer + goTables inner + +instance HasTables (Expr ResolvedNames a) where + goTables (BinOpExpr _ _ lhs rhs) = mapM_ goTables [lhs, rhs] + goTables (CaseExpr _ whens else_) = + let whens' = foldl' (\ xs (x, y) -> x:y:xs) [] whens + in mapM_ goTables (maybe id (:) else_ whens') + + goTables (UnOpExpr _ _ operand) = goTables operand + goTables (LikeExpr _ _ escape pattern expr) = mapM_ goTables $ catMaybes + [ fmap escapeExpr escape + , Just (patternExpr pattern) + , Just expr + ] + + goTables (ConstantExpr _ _) = return () + goTables (ColumnExpr _ _) = return () + goTables (InListExpr _ exprs expr) = mapM_ goTables $ expr : exprs + goTables (InSubqueryExpr _ query expr) = do + goTables expr + goTables query + + goTables (BetweenExpr _ expr start end) = + mapM_ goTables [expr, start, end] + + goTables (OverlapsExpr _ (s1, e1) (s2, e2)) = + mapM_ goTables [s1, e1, s2, e2] + + goTables (FunctionExpr _ _ _ args params mFilter mOver) = do + mapM_ goTables $ args ++ map snd params + maybe (return ()) goTables mFilter + maybe (return ()) goTables mOver + + goTables (AtTimeZoneExpr _ expr tz) = mapM_ goTables [expr, tz] + goTables (SubqueryExpr _ query) = goTables query + goTables (ArrayExpr _ values) = mapM_ goTables values + goTables (ExistsExpr _ query) = goTables query + goTables (FieldAccessExpr _ expr _) = goTables expr + goTables (ArrayAccessExpr _ expr subscript) = do + goTables expr + goTables subscript + goTables (TypeCastExpr _ _ expr _) = goTables expr + goTables (VariableSubstitutionExpr _) = return () + +instance HasTables (Filter ResolvedNames a) where + goTables (Filter _ expr) = goTables expr + +instance HasTables (OverSubExpr ResolvedNames a) where + goTables (OverWindowExpr _ windowExpr) = goTables windowExpr + goTables (OverWindowName _ _) = return () + goTables (OverPartialWindowExpr _ partial) = goTables partial + +instance HasTables (Partition ResolvedNames a) where + goTables (PartitionBy _ exprs) = mapM_ goTables exprs + goTables (PartitionBest _) = return () + goTables (PartitionNodes _) = return () + +instance HasTables (Order ResolvedNames a) where + goTables (Order _ posOrExpr _ _) = goTables posOrExpr + + +data Open = Open { openRange :: Range + , openNumber :: RangeNumber + } deriving (Eq, Show) + +data Close = Close { closeRange :: Range + , closeNumber :: RangeNumber + } deriving (Eq, Show) + +class Positioned a where + position :: a -> Position + +instance Ord Open where + compare = comparing (start . openRange) + <> flip (comparing $ end . openRange) + +instance Positioned Open where + position = start . openRange + +instance Ord Close where + compare = comparing (end . closeRange) + <> flip (comparing $ start . closeRange) + +instance Positioned Close where + position = end . closeRange + + +newtype RangeNumber = RangeNumber Integer deriving (Eq, Ord, Show) +newtype NodeNumber = NodeNumber Integer deriving (Eq, Ord, Show) + +getRanges :: Query RawNames Range + -> ( Query RawNames NodeNumber + , Set Open, Set Close + , Map NodeNumber RangeNumber ) +getRanges query = + let (query', (_, m)) = runState (mapM numberNodes query) (0, M.empty) + (ranges, (_, mapping)) = + runState (mapM numberRanges m) (0, M.empty) + + (opens, closes) = + let makeOpenAndClose r rnum = + ( S.singleton (Open r rnum) + , S.singleton (Close r rnum) + ) + in M.foldMapWithKey makeOpenAndClose ranges + + in (query', opens, closes, mapping) + + where + numberNodes r = state $ \ (i, m) -> + let m' = M.insertWith S.union r (S.singleton $ NodeNumber i) m + in (NodeNumber i, (i+1, m')) + + numberRanges s = state $ \ (i, m) -> + let m' = M.union (M.fromSet (const $ RangeNumber i) s) m + in (RangeNumber i, (i+1, m')) + + +spliceMarkers :: Monoid a => (Open -> a) + -> (Close -> a) + -> (Text -> a) + -> Set Open + -> Set Close + -> Text + -> a + +spliceMarkers renderOpen renderClose renderText = go 0 + where + go offset opens closes text = + case (S.minView opens, S.minView closes) of + (Just (o, opens'), Just (c, closes')) + | offset == positionOffset (position c) -> + renderClose c <> go offset opens closes' text + + | offset == positionOffset (position o) -> + renderOpen o <> go offset opens' closes text + + | otherwise -> + let offset' = min (positionOffset $ position c) + (positionOffset $ position o) + (chunk, rest) = TL.splitAt (offset' - offset) text + in renderText chunk <> go offset' opens closes rest + + (Just _, Nothing) -> error $ unwords + [ "remaining opens when all closes are exhausted" + , "- this should not be possible" + ] + + (Nothing, Just (c, closes')) + | offset == positionOffset (position c) -> + renderClose c <> go offset opens closes' text + + | otherwise -> + let offset' = positionOffset $ position c + (chunk, rest) = TL.splitAt (offset' - offset) text + in renderText chunk <> go offset' opens closes rest + + (Nothing, Nothing) -> renderText text