├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── sql-viewer.cabal ├── src ├── Catalog.hs ├── Dialects.hs ├── InputsStore.hs ├── Main.hs ├── QueryParserView.hs ├── ResolvedStore.hs └── Tabs.hs ├── stack.yaml └── static ├── index.html └── style.css /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for sql-viewer 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, David Thomas 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of David Thomas nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | UI for [uber/queryparser](https://github.com/uber/queryparser), written in Haskell using using [react-flux](http://hackage.haskell.org/package/react-flux), compiled to javascript with [GHCjs](https://github.com/ghcjs/ghcjs). 2 | 3 | Play with it here: https://dlthomas.github.io/sql-viewer/built 4 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /sql-viewer.cabal: -------------------------------------------------------------------------------- 1 | -- Initial sql-viewer.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: sql-viewer 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: David Thomas 11 | maintainer: david.thomas@leapyear.io 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | extra-source-files: ChangeLog.md 16 | cabal-version: >=1.10 17 | 18 | executable sql-viewer 19 | main-is: Main.hs 20 | other-modules: Catalog 21 | , Dialects 22 | , QueryParserView 23 | , InputsStore 24 | , ResolvedStore 25 | , Tabs 26 | -- other-extensions: 27 | cpp-options: -DGHCJS_BROWSER 28 | build-depends: base >=4.9 && <4.10 29 | , ghcjs-base 30 | , queryparser 31 | , queryparser-hive 32 | , queryparser-presto 33 | , queryparser-vertica 34 | , aeson 35 | , bytestring 36 | , containers 37 | , deepseq 38 | , mtl 39 | , react-flux 40 | , text 41 | , unordered-containers 42 | default-extensions: TypeApplications 43 | hs-source-dirs: src 44 | default-language: Haskell2010 45 | -------------------------------------------------------------------------------- /src/Catalog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | module Catalog where 7 | 8 | import Data.Aeson as JSON 9 | import Data.Foldable (toList) 10 | import qualified Data.HashMap.Strict as HMS 11 | import Data.Text as T (Text, unlines) 12 | import Data.Text.Lazy as TL (fromStrict, pack, toStrict) 13 | import Data.Text.Lazy.Encoding (encodeUtf8) 14 | import Data.Typeable (typeRep) 15 | 16 | import Dialects 17 | 18 | import Database.Sql.Type 19 | 20 | parseCatalog :: SomeDialect -> Text -> Text -> Either String Catalog 21 | parseCatalog (SomeDialect dialect) schema path = do 22 | let database = DatabaseName () $ TL.pack $ show $ typeRep dialect 23 | decode :: FromJSON a => Text -> Either String a 24 | decode = JSON.eitherDecode' . encodeUtf8 . fromStrict 25 | schema' <- decode schema 26 | path' <- map (`mkNormalSchema` ()) <$> decode path 27 | pure $ makeCatalog (HMS.singleton database schema') path' database 28 | 29 | defaultCatalog :: Text 30 | defaultCatalog = T.unlines 31 | [ "{\"public\":" 32 | , " {\"tbl\": [\"a\", \"b\"]}}" 33 | ] 34 | 35 | instance FromJSON DatabaseMap where 36 | parseJSON = withObject "database-map" $ 37 | (HMS.fromList <$>) . mapM (\ (k, v) -> (mkNormalSchema (fromStrict k) (),) <$> parseJSON v) . HMS.toList 38 | 39 | instance FromJSON SchemaMap where 40 | parseJSON = withObject "schema-map" $ 41 | (HMS.fromList <$>) . mapM (\ (k, v) -> (QTableName () None $ fromStrict k,) <$> parseJSON v) . HMS.toList 42 | 43 | instance FromJSON SchemaMember where 44 | parseJSON = withArray "table" $ \ array -> do 45 | columns <- toList <$> mapM parseColumn array 46 | pure $ SchemaMember Table Persistent columns Nothing 47 | where 48 | parseColumn = withText "column" $ pure . QColumnName () None . fromStrict 49 | -------------------------------------------------------------------------------- /src/Dialects.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeFamilyDependencies #-} 5 | 6 | module Dialects (KnownDialect(..), SomeDialect(..), Hive, Presto, Vertica) where 7 | 8 | import Control.Arrow 9 | import Control.DeepSeq 10 | import Data.Data 11 | import Data.Text.Lazy (Text) 12 | import Database.Sql.Position (Range) 13 | import Database.Sql.Type 14 | import Database.Sql.Util.Scope 15 | import Database.Sql.Util.Columns 16 | import Database.Sql.Util.Lineage.ColumnPlus 17 | import Database.Sql.Util.Lineage.Table 18 | 19 | import Database.Sql.Hive.Parser as Hive 20 | import Database.Sql.Hive.Type 21 | import Database.Sql.Presto.Parser as Presto 22 | import Database.Sql.Presto.Type 23 | import Database.Sql.Vertica.Parser as VSQL 24 | import Database.Sql.Vertica.Type 25 | 26 | class 27 | ( Data (RawAST d), Data (ResolvedAST d) 28 | , HasColumns (ResolvedAST d) 29 | , HasColumnLineage (ResolvedAST d) 30 | , HasTableLineage (ResolvedAST d) 31 | ) => KnownDialect d where 32 | type RawAST d = raw | raw -> d 33 | type ResolvedAST d = resolved | resolved -> d 34 | parse :: Text -> Either String (RawAST d) 35 | resolve :: Catalog -> RawAST d -> Either String (ResolvedAST d) 36 | 37 | instance KnownDialect Hive where 38 | type RawAST Hive = HiveStatement RawNames Range 39 | type ResolvedAST Hive = HiveStatement ResolvedNames Range 40 | parse = left show . Hive.parseAll 41 | resolve catalog stmt = left show $ runResolverNoWarn (resolveHiveStatement stmt) (Proxy :: Proxy Hive) catalog 42 | 43 | instance KnownDialect Presto where 44 | type RawAST Presto = PrestoStatement RawNames Range 45 | type ResolvedAST Presto = PrestoStatement ResolvedNames Range 46 | parse = left show . Presto.parseAll 47 | resolve catalog stmt = left show $ runResolverNoWarn (resolvePrestoStatement stmt) (Proxy :: Proxy Presto) catalog 48 | 49 | instance KnownDialect Vertica where 50 | type RawAST Vertica = VerticaStatement RawNames Range 51 | type ResolvedAST Vertica = VerticaStatement ResolvedNames Range 52 | parse = left show . VSQL.parseAll 53 | resolve catalog stmt = left show $ runResolverNoWarn (resolveVerticaStatement stmt) (Proxy :: Proxy Vertica) catalog 54 | 55 | data SomeDialect = forall d. (Typeable d, KnownDialect d) => SomeDialect (Proxy d) 56 | 57 | instance Eq SomeDialect where 58 | SomeDialect x == SomeDialect y = typeRep x == typeRep y 59 | 60 | instance NFData SomeDialect where 61 | rnf (SomeDialect d) = d `seq` () 62 | -------------------------------------------------------------------------------- /src/InputsStore.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | module InputsStore where 9 | 10 | import Control.Concurrent.MVar 11 | import Control.DeepSeq 12 | import Data.IORef 13 | import Data.Text 14 | import Data.Typeable 15 | import GHC.Generics 16 | import React.Flux 17 | 18 | import Catalog 19 | import Dialects 20 | import ResolvedStore (dialectRef, queryRef, pathRef, schemaRef, triggerVar) 21 | 22 | data Inputs = Inputs 23 | { dialect :: !SomeDialect 24 | , query :: !Text 25 | , schema :: !Text 26 | , path :: !Text 27 | } 28 | 29 | data InputsAction 30 | = SetDialect !SomeDialect 31 | | SetQuery !Text 32 | | SetSchema !Text 33 | | SetPath !Text 34 | deriving (Typeable, Generic, NFData) 35 | 36 | instance StoreData Inputs where 37 | type StoreAction Inputs = InputsAction 38 | transform (SetDialect dialect) inputs = do 39 | writeIORef dialectRef dialect 40 | tryPutMVar triggerVar () 41 | pure inputs{dialect} 42 | transform (SetQuery query) inputs = do 43 | writeIORef queryRef query 44 | tryPutMVar triggerVar () 45 | pure inputs{query} 46 | transform (SetSchema schema) inputs = do 47 | writeIORef schemaRef schema 48 | tryPutMVar triggerVar () 49 | pure inputs{schema} 50 | transform (SetPath path) inputs = do 51 | writeIORef pathRef path 52 | tryPutMVar triggerVar () 53 | pure inputs{path} 54 | 55 | inputsStore :: ReactStore Inputs 56 | inputsStore = mkStore Inputs 57 | { dialect = SomeDialect (Proxy @Hive) 58 | , query = "SELECT 1;" 59 | , schema = defaultCatalog 60 | , path = "[\"public\"]" 61 | } 62 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent (forkIO) 4 | import React.Flux 5 | 6 | import ResolvedStore 7 | import QueryParserView 8 | 9 | main :: IO () 10 | main = do 11 | forkIO resolverThread 12 | reactRender "main" queryParserView () 13 | -------------------------------------------------------------------------------- /src/QueryParserView.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | module QueryParserView where 10 | 11 | import Control.Monad (void, when) 12 | import Control.Monad.Writer (runWriter) 13 | import qualified Data.ByteString as BS 14 | import qualified Data.ByteString.Lazy as BL 15 | import Data.Data 16 | import Data.Foldable (forM_) 17 | import Data.Functor.Identity (Identity(..)) 18 | import Data.JSString as JS (pack) 19 | import Data.List (intersperse) 20 | import qualified Data.Map as M 21 | import Data.Text as T (Text, unpack) 22 | import qualified Data.Text.Lazy as TL (Text, unpack) 23 | import Data.Text.Lazy as TL (fromStrict, intercalate, toStrict) 24 | import React.Flux 25 | import React.Flux.DOM 26 | 27 | import Catalog 28 | import Dialects 29 | import InputsStore 30 | import ResolvedStore 31 | import Tabs 32 | 33 | import Database.Sql.Position (Range) 34 | import Database.Sql.Type 35 | import Database.Sql.Util.Columns 36 | import Database.Sql.Util.Eval (RecordSet(..)) 37 | import Database.Sql.Util.Lineage.ColumnPlus 38 | import Database.Sql.Util.Lineage.Table 39 | 40 | queryView :: ReactView () 41 | queryView = defineControllerView "query" inputsStore $ \ Inputs{query} () -> do 42 | textarea_ 43 | [ "value" &= query 44 | , onChange $ \ evt -> 45 | [SomeStoreAction inputsStore $ SetQuery $ target evt "value"] 46 | ] mempty 47 | 48 | schemaView :: ReactView () 49 | schemaView = defineControllerView "schema" inputsStore $ \ Inputs{schema, path} () -> do 50 | textarea_ 51 | [ "value" &= schema 52 | , onChange $ \ evt -> 53 | [SomeStoreAction inputsStore $ SetSchema $ target evt "value"] 54 | ] mempty 55 | br_ [] 56 | input_ 57 | [ "value" &= path 58 | , onChange $ \ evt -> 59 | [SomeStoreAction inputsStore $ SetPath $ target evt "value"] 60 | ] 61 | 62 | data Example = Example 63 | { name :: !Text 64 | , dialect :: !SomeDialect 65 | , query :: !Text 66 | , schema :: !Text 67 | , path :: !Text 68 | } 69 | 70 | renderExample :: Int -> Example -> ReactElementM handler () 71 | renderExample idx Example{..} = option_ [ "value" &= show idx ] $ elemText name 72 | 73 | examplesView :: ReactView () 74 | examplesView = defineStatefulView "examples" 0 $ \ idx () -> do 75 | select_ 76 | [ onChange $ \ evt _ -> 77 | case read $ T.unpack $ target evt "value" of 78 | new | new == idx -> ([], Nothing) 79 | | Just Example{..} <- lookup new examples 80 | -> ( map (SomeStoreAction inputsStore) 81 | [ SetDialect dialect 82 | , SetQuery query 83 | , SetSchema schema 84 | , SetPath path 85 | ] 86 | , Just new 87 | ) 88 | | otherwise -> ([], Just new) 89 | ] $ do 90 | option_ "examples" 91 | mapM_ (uncurry renderExample) examples 92 | where 93 | examples = zip [1..] 94 | [ Example 95 | { name = "CTAS" 96 | , dialect = SomeDialect (Proxy @Hive) 97 | , query = "CREATE TABLE bar AS SELECT * FROM foo WHERE a = 7;" 98 | , schema = defaultCatalog 99 | , path = "[\"public\"]" 100 | } 101 | ] 102 | 103 | rawView :: ReactView () 104 | rawView = defineControllerView "raw" inputsStore $ \ Inputs{dialect = SomeDialect (_ :: Proxy dialect), query} () -> 105 | either elemShow renderAST $ parse @dialect $ fromStrict query 106 | 107 | resolvedView :: ReactView () 108 | resolvedView = defineControllerView "resolved" resolvedStore $ \ (Resolved stmt) () -> either elemString renderAST stmt 109 | 110 | columnsView :: ReactView () 111 | columnsView = defineControllerView "columns" resolvedStore $ \ (Resolved stmt) () -> 112 | case stmt of 113 | Left err -> elemString err 114 | Right stmt -> 115 | case getColumns stmt of 116 | columns 117 | | null columns -> "no column usage to report" 118 | | otherwise -> 119 | table_ $ do 120 | tr_ $ do 121 | th_ "Column" 122 | th_ "Clauses" 123 | forM_ columns $ \ (fqcn, clause) -> 124 | tr_ $ do 125 | td_ $ renderFQCN fqcn 126 | td_ $ elemText $ toStrict clause 127 | 128 | renderFQCN :: FQCN -> ReactElementM handler () 129 | renderFQCN FullyQualifiedColumnName{..} = elemText $ toStrict $ intercalate "." [fqcnSchemaName, fqcnTableName, fqcnColumnName] 130 | 131 | renderFQTN :: FQTN -> ReactElementM handler () 132 | renderFQTN FullyQualifiedTableName{..} = elemText $ toStrict $ intercalate "." [fqtnSchemaName, fqtnTableName] 133 | 134 | renderFQTNRowCount :: FQTN -> ReactElementM handler () 135 | renderFQTNRowCount fqtn = renderFQTN fqtn >> " row count" 136 | 137 | renderColumnPlusSet :: ColumnPlusSet -> ReactElementM handler () 138 | renderColumnPlusSet ColumnPlusSet{..} = 139 | sequence_ $ intersperse (elemText ",\n") $ 140 | map renderFQTNRowCount (M.keys columnPlusTables) 141 | ++ map renderFQCN (M.keys columnPlusColumns) 142 | 143 | columnLineageView :: ReactView () 144 | columnLineageView = defineControllerView "column-lineage" resolvedStore $ \ (Resolved resolved) () -> 145 | case resolved of 146 | Left err -> elemString err 147 | Right stmt -> table_ $ do 148 | tr_ $ do 149 | th_ "Targets" 150 | th_ "Sources" 151 | case getColumnLineage stmt of 152 | (RecordSet{..}, effects) -> do 153 | let (columnSources, countSources) = runWriter recordSetItems 154 | when (mempty /= countSources) $ do 155 | tr_ $ do 156 | td_ "result row count" 157 | td_ $ renderColumnPlusSet countSources 158 | forM_ (zip recordSetLabels columnSources) $ \ (column, sources) -> do 159 | tr_ $ do 160 | td_ $ 161 | let name = 162 | case column of 163 | RColumnRef (QColumnName _ _ name) -> name 164 | RColumnAlias (ColumnAlias _ name _) -> name 165 | in elemString ("result column " ++ TL.unpack name) 166 | td_ $ renderColumnPlusSet sources 167 | 168 | forM_ (M.toList effects) $ \ (target, sources) -> do 169 | tr_ $ do 170 | td_ $ either renderFQTNRowCount renderFQCN target 171 | td_ $ renderColumnPlusSet sources 172 | 173 | tableLineageView :: ReactView () 174 | tableLineageView = defineControllerView "table-lineage" resolvedStore $ \ (Resolved resolved) () -> 175 | case resolved of 176 | Left err -> elemString err 177 | Right stmt -> 178 | case M.toList $ getTableLineage stmt of 179 | [] -> elemText "no table-level lineage to report" 180 | lineage -> do 181 | table_ $ do 182 | tr_ $ do 183 | th_ "Targets" 184 | th_ "Sources" 185 | forM_ lineage $ \ (target, sources) -> do 186 | td_ $ renderFQTN target 187 | td_ $ mapM_ renderFQTN sources 188 | 189 | renderAST :: forall d handler. Data d => d -> ReactElementM handler () 190 | renderAST x 191 | | Just Refl <- eqT @d @T.Text 192 | = elemShow x 193 | | Just Refl <- eqT @d @TL.Text 194 | = elemShow x 195 | | Just Refl <- eqT @d @BS.ByteString 196 | = elemShow x 197 | | Just Refl <- eqT @d @BL.ByteString 198 | = elemShow x 199 | | Just Refl <- eqT @d @String 200 | = elemShow x 201 | | Just Refl <- eqT @d @(UQColumnName ()) 202 | , QColumnName _ None columnName <- x 203 | = elemText $ toStrict columnName 204 | | Just Refl <- eqT @d @(UQColumnName Range) 205 | , QColumnName _ None columnName <- x 206 | = elemText $ toStrict columnName 207 | | Just Refl <- eqT @d @(FQColumnName Range) 208 | , QColumnName _ (Identity (QTableName _ (Identity (QSchemaName _ _ schemaName _)) tableName)) columnName <- x 209 | = elemText $ toStrict $ intercalate "." [schemaName, tableName, columnName] 210 | | Just Refl <- eqT @d @(FQTableName Range) 211 | , QTableName _ (Identity (QSchemaName _ _ schemaName _)) tableName <- x 212 | = elemText $ toStrict $ intercalate "." [schemaName, tableName] 213 | | Just Refl <- eqT @d @(ColumnAlias Range) 214 | , ColumnAlias _ name (ColumnAliasId aliasId) <- x 215 | = "ColumnAlias " >> elemString (show name) >> " (" >> elemString (show aliasId) >> ")" 216 | | Just Refl <- eqT @d @(TableAlias Range) 217 | , TableAlias _ name (TableAliasId aliasId) <- x 218 | = "TableAlias " >> elemString (show name) >> " (" >> elemString (show aliasId) >> ")" 219 | | dataIsList x 220 | = renderList x 221 | | otherwise 222 | = dl_ $ do 223 | dt_ $ elemShow (toConstr x) 224 | void $ gmapM (\ y -> skip (dd_ . renderAST) y >> pure y) x 225 | 226 | dataIsNothing :: forall d. Data d => d -> Bool 227 | dataIsNothing x = 228 | typeRepTyCon (typeRep (Proxy @d)) == typeRepTyCon (typeRep (Proxy @(Maybe ()))) 229 | && toConstr x == toConstr (Nothing :: Maybe ()) 230 | 231 | dataIsList :: forall d. Data d => d -> Bool 232 | dataIsList x = typeRepTyCon (typeRep (Proxy @d)) == typeRepTyCon (typeRep (Proxy @([()]))) 233 | 234 | renderList :: forall d handler. Data d => d -> ReactElementM handler () 235 | renderList x 236 | | toConstr x == toConstr ([] :: [()]) 237 | = elemText "[]" 238 | | otherwise 239 | = ol_ $ renderListItems x 240 | 241 | data SomeData = forall d. Data d => SomeData d 242 | 243 | renderListItems :: forall d handler. Data d => d -> ReactElementM handler () 244 | renderListItems x 245 | | toConstr x == toConstr ([] :: [()]) 246 | = pure () 247 | | [SomeData h, SomeData t] <- gmapQ SomeData x 248 | = do 249 | li_ $ renderAST h 250 | renderListItems t 251 | 252 | skip :: forall a m. (Monad m, Data a) => (forall d. Data d => d -> m ()) -> a -> m () 253 | skip f x 254 | | Just Refl <- eqT @a @Range 255 | = pure () 256 | | dataIsNothing x 257 | = pure () 258 | | otherwise 259 | = f x 260 | 261 | dialect_ :: forall d. (KnownDialect d, Typeable d) => ReactElementM ViewEventHandler () 262 | dialect_ = viewWithSKey dialectView dialectName () mempty 263 | where 264 | dialectName = JS.pack $ show $ typeRep (Proxy @d) 265 | dialectView = defineControllerView dialectName inputsStore $ \ Inputs{dialect} () -> do 266 | div_ [ classNames [("control", True)] ] $ do 267 | input_ 268 | [ "name" $= "dialect" 269 | , "checked" &= (dialect == SomeDialect (Proxy @d)) 270 | , "value" &= dialectName 271 | , "id" &= dialectName 272 | , "type" $= "radio" 273 | , onChange $ \ _ -> [SomeStoreAction inputsStore $ SetDialect $ SomeDialect (Proxy @d)] 274 | ] 275 | label_ [ "for" &= dialectName ] $ elemJSString dialectName 276 | 277 | queryParserView :: ReactView () 278 | queryParserView = defineView "query parser" $ \ () -> do 279 | div_ [classNames [("frame", True)]] $ do 280 | div_ [classNames [("controls", True)]] $ do 281 | dialect_ @Hive 282 | dialect_ @Presto 283 | dialect_ @Vertica 284 | div_ [ classNames [("control", True)] ] $ viewWithSKey examplesView "examples" () mempty 285 | 286 | tabs_ 287 | [ ( "Query" 288 | , viewWithSKey queryView "query" () mempty 289 | ) 290 | , ( "Schema" 291 | , viewWithSKey schemaView "schema" () mempty 292 | ) 293 | ] 294 | div_ [classNames [("frame", True)]] $ tabs_ 295 | [ ( "AST" 296 | , tabs_ 297 | [ ( "Raw" 298 | , viewWithSKey rawView "raw-query" () mempty 299 | ) 300 | , ( "Resolved" 301 | , viewWithSKey resolvedView "resolved-query" () mempty 302 | ) 303 | ] 304 | ) 305 | , ( "Columns" 306 | , viewWithSKey columnsView "columns" () mempty 307 | ) 308 | , ( "Lineage" 309 | , tabs_ 310 | [ ( "Table" 311 | , viewWithSKey tableLineageView "table-lineage" () mempty 312 | ) 313 | , ( "Column (Plus Fields and Row Count)" 314 | , viewWithSKey columnLineageView "column-lineage" () mempty 315 | ) 316 | ] 317 | ) 318 | , ( "Evaluation" 319 | , elemText "stub" 320 | ) 321 | ] 322 | -------------------------------------------------------------------------------- /src/ResolvedStore.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE ExistentialQuantification #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | 12 | module ResolvedStore where 13 | 14 | import Control.Arrow (left) 15 | import Control.Concurrent.MVar 16 | import Control.DeepSeq 17 | import Control.Monad 18 | import Data.IORef 19 | import Data.Text 20 | import Data.Text.Lazy (fromStrict) 21 | import Data.Typeable 22 | import GHC.Generics 23 | import React.Flux 24 | import System.IO.Unsafe 25 | 26 | import Catalog 27 | import Dialects 28 | 29 | import Database.Sql.Hive.Parser (parseAll) 30 | import Database.Sql.Hive.Type 31 | import Database.Sql.Position 32 | import Database.Sql.Type.Scope 33 | import Database.Sql.Util.Scope 34 | 35 | 36 | data Resolved = forall d. KnownDialect d => Resolved { resolved :: Either String (ResolvedAST d) } 37 | 38 | data ResolvedAction = forall d. KnownDialect d => SetResolved (Either String (ResolvedAST d)) 39 | deriving (Typeable) 40 | 41 | instance StoreData Resolved where 42 | type StoreAction Resolved = ResolvedAction 43 | transform (SetResolved resolved) _ = pure Resolved{resolved} 44 | 45 | resolvedStore :: ReactStore Resolved 46 | resolvedStore = mkStore Resolved { resolved = Left "initializing" :: Either String (ResolvedAST Hive) } 47 | 48 | dialectRef :: IORef SomeDialect 49 | dialectRef = unsafePerformIO $ newIORef $ SomeDialect (Proxy @Hive) 50 | 51 | queryRef :: IORef Text 52 | queryRef = unsafePerformIO $ newIORef "SELECT 1;" 53 | 54 | schemaRef :: IORef Text 55 | schemaRef = unsafePerformIO $ newIORef defaultCatalog 56 | 57 | pathRef :: IORef Text 58 | pathRef = unsafePerformIO $ newIORef "[\"public\"]" 59 | 60 | triggerVar :: MVar () 61 | triggerVar = unsafePerformIO newEmptyMVar 62 | 63 | resolverThread :: IO () 64 | resolverThread = forever $ do 65 | dialect@(SomeDialect (_ :: Proxy dialect)) <- readIORef dialectRef 66 | query <- readIORef queryRef 67 | schema <- readIORef schemaRef 68 | path <- readIORef pathRef 69 | let resolved = do 70 | raw <- left show $ parse @dialect (fromStrict query) 71 | catalog <- parseCatalog dialect schema path 72 | resolve catalog raw 73 | alterStore resolvedStore $ SetResolved resolved 74 | takeMVar triggerVar 75 | -------------------------------------------------------------------------------- /src/Tabs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Tabs (tabs_) where 4 | 5 | import Control.Monad 6 | import Data.List 7 | import Data.Text (Text) 8 | import React.Flux 9 | 10 | tabs_ :: [(Text, ReactElementM ViewEventHandler ())] -> ReactElementM handler () 11 | tabs_ ts = viewWithSKey (tabsView ts) "tabs" () mempty 12 | 13 | tabsView :: [(Text, ReactElementM ViewEventHandler ())] -> ReactView () 14 | tabsView [] = defineView "tabs" $ \ () -> div_ [classNames [("tab-frame", True)]] $ elemText "empty tab list" 15 | tabsView tabs@((t, _):_) = defineStatefulView "tabs" t $ \ t () -> div_ [classNames [("tab-frame", True)]] $ do 16 | div_ [classNames [("tab-list", True)]] $ do 17 | forM_ tabs $ \case 18 | (t', _) 19 | | t == t' -> div_ [classNames [("selected", True), ("tab", True)]] $ elemText t 20 | | otherwise -> div_ [classNames [("tab", True)], onClick $ \ _ _ _ -> ([], Just t')] $ elemText t' 21 | 22 | case lookup t tabs of 23 | Nothing -> pure () 24 | Just widget -> div_ [classNames [("tab-body", True)]] $ liftViewToStateHandler widget 25 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-7.19 19 | compiler: ghcjs-0.2.1.9007019_ghc-8.0.1 20 | compiler-check: match-exact 21 | 22 | setup-info: 23 | ghcjs: 24 | source: 25 | ghcjs-0.2.1.9007019_ghc-8.0.1: 26 | url: http://ghcjs.tolysz.org/ghc-8.0-2017-02-05-lts-7.19-9007019.tar.gz 27 | sha1: d2cfc25f9cda32a25a87d9af68891b2186ee52f9 28 | 29 | # User packages to be built. 30 | # Various formats can be used as shown in the example below. 31 | # 32 | # packages: 33 | # - some-directory 34 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 35 | # - location: 36 | # git: https://github.com/commercialhaskell/stack.git 37 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 38 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 39 | # extra-dep: true 40 | # subdirs: 41 | # - auto-update 42 | # - wai 43 | # 44 | # A package marked 'extra-dep: true' will only be built if demanded by a 45 | # non-dependency (i.e. a user package), and its test suites and benchmarks 46 | # will not be run. This is useful for tweaking upstream packages. 47 | packages: 48 | - . 49 | - location: 50 | git: git@github.com:uber/queryparser.git 51 | commit: 1b8eb4320c38ef5fba63cd62543a10fe1fe5d1f1 52 | subdirs: 53 | - . 54 | - misc/predicate-class 55 | - dialects/hive 56 | - dialects/presto 57 | - dialects/vertica 58 | extra-dep: true 59 | 60 | # Dependency packages to be pulled from upstream that are not in the resolver 61 | # (e.g., acme-missiles-0.3) 62 | extra-deps: 63 | - react-flux-1.2.3 64 | - fixed-list-0.1.6 65 | # Override default flag values for local packages and extra-deps 66 | # flags: {} 67 | 68 | # Extra package databases containing global packages 69 | # extra-package-dbs: [] 70 | 71 | # Control whether we use the GHC we find on the path 72 | # system-ghc: true 73 | # 74 | # Require a specific version of stack, using version ranges 75 | # require-stack-version: -any # Default 76 | # require-stack-version: ">=1.6" 77 | # 78 | # Override the architecture used by stack, especially useful on Windows 79 | # arch: i386 80 | # arch: x86_64 81 | # 82 | # Extra directories used by stack for building 83 | # extra-include-dirs: [/path/to/dir] 84 | # extra-lib-dirs: [/path/to/dir] 85 | # 86 | # Allow a newer minor version of GHC than the snapshot specifies 87 | # compiler-check: newer-minor 88 | -------------------------------------------------------------------------------- /static/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 |
13 | 14 | 15 | 16 | -------------------------------------------------------------------------------- /static/style.css: -------------------------------------------------------------------------------- 1 | .selected { background-color: lightgray } 2 | .tab { 3 | display: inline; 4 | padding: 0.1em 0.8em 0.1em 0.8em; 5 | margin-bottom: 1em; 6 | border-right: solid black; 7 | } 8 | .frame { display: inline; float: left; padding: 0.4em } 9 | .tab-list { padding: 0.1em 0 0.4em 0em } 10 | .tab-body { margin: 0.4em} 11 | .tab-frame { border-left: solid; border-top: solid; padding-bottom: 0.6em } 12 | table { border-collapse: collapse; width: 100% } 13 | tr:nth-child(even) { background-color: aliceblue } 14 | td, th { border-left: solid lightgrey; margin: 1em; padding: 0.2em } 15 | th { border-bottom: solid lightgrey } 16 | td:first-child, th:first-child { border-left: none } 17 | textarea { min-height: 20em; min-width: 50em } 18 | dd { margin-left: 1.3em; margin-bottom: 0.8em } 19 | dl { border-left: solid ghostwhite } 20 | ol { padding-left: 1.3em; border-left: solid ghostwhite } 21 | li { margin-bottom: 0.5em } 22 | .controls { margin-bottom: 0.4em } 23 | .control { display: inline; margin-right: 0.4em } 24 | select { vertical-align: top } 25 | --------------------------------------------------------------------------------