packages feed

queryparser (empty) → 0.1.0.0

raw patch · 26 files changed

+9874/−0 lines, 26 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, bytestring, containers, criterion, fixed-list, hashable, mtl, parsec, predicate-class, pretty, queryparser, semigroups, text, unordered-containers, yaml

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -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
+ bench/Bench.hs view
@@ -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;"+            ]+        ]+    ]
+ queryparser.cabal view
@@ -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
+ src/Data/Functor/Identity/Orphans.hs view
@@ -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
+ src/Data/Maybe/More.hs view
@@ -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++
+ src/Database/Sql/Helpers.hs view
@@ -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{..}
+ src/Database/Sql/Info.hs view
@@ -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
+ src/Database/Sql/Position.hs view
@@ -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
+ src/Database/Sql/Pretty.hs view
@@ -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
+ src/Database/Sql/Type.hs view
@@ -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+        ]
+ src/Database/Sql/Type/Names.hs view
@@ -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+        ]
+ src/Database/Sql/Type/Query.hs view
@@ -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
+ src/Database/Sql/Type/Schema.hs view
@@ -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 "<unknown>"++unknownSchema :: a -> FQSchemaName a+unknownSchema info = QSchemaName info (pure $ unknownDatabase info) "<unknown>" NormalSchema++unknownTable :: a -> FQTableName a+unknownTable info = QTableName info (pure $ unknownSchema info) "<unknown>"++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
+ src/Database/Sql/Type/Scope.hs view
@@ -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+        ]
+ src/Database/Sql/Type/TableProps.hs view
@@ -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 = []
+ src/Database/Sql/Type/Unused.hs view
@@ -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
+ src/Database/Sql/Util/Columns.hs view
@@ -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
+ src/Database/Sql/Util/Eval.hs view
@@ -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
+ src/Database/Sql/Util/Eval/Concrete.hs view
@@ -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"
+ src/Database/Sql/Util/Joins.hs view
@@ -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
+ src/Database/Sql/Util/Lineage/ColumnPlus.hs view
@@ -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
+ src/Database/Sql/Util/Lineage/Table.hs view
@@ -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
+ src/Database/Sql/Util/Schema.hs view
@@ -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 _ _) = []
+ src/Database/Sql/Util/Scope.hs view
@@ -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
+ src/Database/Sql/Util/Tables.hs view
@@ -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