sqlitegui.hs

gistfile1.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}

module Main (main) where

import Database.SQLite.QueryExecutor
import qualified Database.SQLite.Simple as SQLite
import qualified Data.Text as T
import Data.Text (Text)
import Control.Lens
import Monomer
import qualified Monomer.Hagrid as H
import Monomer.Hagrid (textColumn, hagrid)
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)

data AppModel = AppModel
  { _dbPath :: Text
  , _connected :: Bool
  , _queryInput :: Text
  , _resultColumns :: [Text]
  , _resultRows :: [[Text]]
  , _statusMessage :: Text
  , _conn :: Maybe SQLite.Connection
  }

instance Eq AppModel where
  a == b = _dbPath a == _dbPath b
        && _connected a == _connected b
        && _queryInput a == _queryInput b
        && _resultColumns a == _resultColumns b
        && _resultRows a == _resultRows b
        && _statusMessage a == _statusMessage b

data AppEvent
  = AppInit
  | OpenDatabaseClick
  | CloseDatabaseClick
  | ExecuteQueryClick
  | DatabaseOpened (Either QueryError SQLite.Connection)
  | DatabaseClosed
  | QueryExecuted (Either QueryError QueryResult)

makeLenses ''AppModel

main :: IO ()
main = do
  startApp model handleEvent buildUI config
  where
    config =
      [ appWindowTitle "SQLite Browser"
      , appTheme darkTheme
      , appFontDef "Regular" "/System/Library/Fonts/SFNS.ttf"
      , appFontDef "Bold" "/System/Library/Fonts/Supplemental/Arial Bold.ttf"
      , appInitEvent AppInit
      ]
    model = AppModel
      { _dbPath = ""
      , _connected = False
      , _queryInput = "SELECT * FROM sqlite_master WHERE type='table';"
      , _resultColumns = []
      , _resultRows = []
      , _statusMessage = "Not connected"
      , _conn = Nothing
      }

handleEvent
  :: WidgetEnv AppModel AppEvent
  -> WidgetNode AppModel AppEvent
  -> AppModel
  -> AppEvent
  -> [AppEventResponse AppModel AppEvent]
handleEvent wenv node model evt = case evt of
  AppInit ->
    []

  OpenDatabaseClick ->
    [ Task $ do
        result <- openDatabase (T.unpack (model ^. dbPath))
        return $ DatabaseOpened result
    ]

  DatabaseOpened (Left err) ->
    [ Model $ model
        & statusMessage .~ ("Error: " <> T.pack (show err))
        & connected .~ False
    ]

  DatabaseOpened (Right connection) ->
    [ Model $ model
        & conn .~ Just connection
        & connected .~ True
        & statusMessage .~ ("Connected to: " <> model ^. dbPath)
    ]

  CloseDatabaseClick ->
    case model ^. conn of
      Nothing ->
        [ Model $ model & statusMessage .~ "No database open" ]
      Just connection ->
        [ Task $ do
            closeDatabase connection
            return DatabaseClosed
        ]

  DatabaseClosed ->
    [ Model $ model
        & conn .~ Nothing
        & connected .~ False
        & dbPath .~ ""
        & statusMessage .~ "Database closed"
    ]

  ExecuteQueryClick ->
    case model ^. conn of
      Nothing ->
        [ Model $ model & statusMessage .~ "No database open" ]
      Just connection ->
        [ Task $ do
            result <- executeQuery connection (model ^. queryInput)
            return $ QueryExecuted result
        ]

  QueryExecuted (Left err) ->
    [ Model $ model
        & statusMessage .~ ("Query error: " <> T.pack (show err))
    ]

  QueryExecuted (Right queryResult) ->
    let rowCount = length (rows queryResult)
    in [ Model $ model
          & resultColumns .~ columns queryResult
          & resultRows .~ rows queryResult
          & statusMessage .~ ("Query executed successfully. " <> T.pack (show rowCount) <> " rows returned")
       ]

buildUI
  :: WidgetEnv AppModel AppEvent
  -> AppModel
  -> WidgetNode AppModel AppEvent
buildUI wenv model = widgetTree where
  widgetTree = vstack
    [ hstack
        [ label "SQLite Browser" `styleBasic` [textSize 24]
        , filler
        , label (model ^. statusMessage) `styleBasic` [textSize 12]
        ] `styleBasic` [padding 10]

    , vstack
        [ hstack
            [ label "Database:" `styleBasic` [width 100]
            , textField dbPath
            , spacer
            , button "Open" OpenDatabaseClick
            , spacer
            , button "Close" CloseDatabaseClick
                `nodeEnabled` (model ^. connected)
            ] `styleBasic` [padding 5]

        , separatorLine

        , label "SQL Query:" `styleBasic` [padding 5]
        , textArea queryInput `styleBasic` [height 150, padding 5]

        , hstack
            [ filler
            , button "Execute Query" ExecuteQueryClick
                `nodeEnabled` (model ^. connected)
            ] `styleBasic` [padding 5]

        , separatorLine

        , label "Results:" `styleBasic` [padding 5]
        , buildResultsGrid model
            `styleBasic` [height 300, padding 5]

        ] `styleBasic` [padding 10]
    ]

buildResultsGrid :: AppModel -> WidgetNode AppModel AppEvent
buildResultsGrid model
  | null (model ^. resultColumns) = label "No results yet" `styleBasic` [padding 10]
  | otherwise =
      let cols = model ^. resultColumns
          rowsData = model ^. resultRows
          -- Each row is a [Text], we create columns that extract by index
          makeColumn :: Int -> Text -> H.Column AppEvent [Text]
          makeColumn idx colName =
            textColumn colName (\row -> if idx < length row then row !! idx else "")
          gridCols = zipWith makeColumn [0..] cols
          gridRows = Seq.fromList rowsData
      in hagrid gridCols gridRows