feat: rudimentary TUI implementation

- Listing records and showing record details.
- Can not scroll record details (yet).

I did not really think about how I want to view and edit the
specification before. That was not a good idea :)

.hlint.yaml

@@ -36,6 +36,7 @@
         - QuasiQuotes
         - RecordWildCards
         - TemplateHaskell
+        - TypeApplications
 
 ################
 # CUSTOM RULES #

package.yaml

@@ -31,6 +31,7 @@ library:
     - hashable
     - hasql
     - hasql-th
+    - microlens-th
     - optparse-applicative
     - parsec
     - string-interpolate
@@ -39,6 +40,7 @@ library:
     - time
     - unordered-containers
     - vector
+    - vty
 
 executables:
   postmap:

src/Postmap/Tui/App.hs

@@ -1,9 +1,117 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
 module Postmap.Tui.App where
 
 import qualified Brick
-import Postmap.Spec (Spec)
+import qualified Brick.AttrMap
+import qualified Brick.Widgets.Border
+import qualified Brick.Widgets.List
+import qualified Brick.Widgets.List as Brick.Widgets
+import Control.Monad (void)
+import Data.Maybe (catMaybes)
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import qualified Graphics.Vty as Vty
+import Postmap.Introspect (TableName (unTableName), TableSchemaName (unTableSchemaName))
+import qualified Postmap.Meta as Meta
+import Postmap.Spec.Types (Field (..), FieldName (..), Record (..), RecordName (unRecordName), Spec (..))
+import Postmap.Tui.AppEvent (AppEvent, appHandleEvent)
+import Postmap.Tui.AppState (AppPerspective (..), AppState (..), initAppState)
 
 
 tui :: Spec -> IO ()
-tui _s = do
-  Brick.simpleMain (Brick.str "Hello, world!" :: Brick.Widget ())
+tui spec =
+  void $ Brick.defaultMain app initialState
+  where
+    app :: AppType
+    app =
+      Brick.App
+        { Brick.appDraw = appDraw
+        , Brick.appChooseCursor = Brick.showFirstCursor
+        , Brick.appHandleEvent = appHandleEvent
+        , Brick.appStartEvent = pure ()
+        , Brick.appAttrMap = const appAttrMap
+        }
+    initialState = initAppState spec
+
+
+type AppType = Brick.App AppState AppEvent ()
+
+
+appDraw :: AppState -> [Brick.Widget ()]
+appDraw _st =
+  [ Brick.Widgets.Border.borderWithLabel title $ renderPerspective _st
+  ]
+  where
+    title = Brick.str (" postmap " <> Meta.versionString <> " ")
+
+
+renderPerspective :: AppState -> Brick.Widget ()
+renderPerspective _st =
+  case _appStatePerspective _st of
+    AppPerspectiveAbout -> Brick.str "TODO: render about"
+    AppPerspectiveRecords listRecordsState ->
+      Brick.padLeftRight 3 . Brick.padTopBottom 1 $
+        Brick.hBox
+          [ Brick.hLimitPercent 30
+              . Brick.Widgets.Border.borderWithLabel (Brick.str " Records List ")
+              $ Brick.Widgets.renderList renderRecordListItem True listRecordsState
+          , Brick.hLimitPercent 100
+              . Brick.Widgets.Border.borderWithLabel (Brick.str " Record Details ")
+              $ renderRecordDetails listRecordsState
+          ]
+
+
+recordList :: Spec -> Brick.Widgets.List () Record
+recordList Spec {..} =
+  Brick.Widgets.list () (V.fromList specRecords) 0
+
+
+renderRecordListItem :: Bool -> Record -> Brick.Widget ()
+renderRecordListItem isSelected record =
+  if isSelected
+    then paintSelected widget
+    else widget
+  where
+    label = [Just (unRecordName (recordName record)), recordTitle record]
+    widget = Brick.str . T.unpack . T.intercalate " - " $ catMaybes label
+    paintSelected = Brick.withAttr (Brick.Widgets.List.listSelectedAttr <> Brick.AttrMap.attrName "highlight-list-item")
+
+
+renderRecordDetails :: Brick.Widgets.List.List () Record -> Brick.Widget ()
+renderRecordDetails listRecordsState =
+  case Brick.Widgets.List.listSelectedElement listRecordsState of
+    Nothing -> Brick.str "No record selected"
+    Just (_, record) ->
+      Brick.hBox
+        [ Brick.vBox
+            [ Brick.str "Name: " Brick.<+> Brick.str (T.unpack . unRecordName . recordName $ record)
+            , Brick.str "Title: " Brick.<+> Brick.str (maybe "<empty>" T.unpack $ recordTitle record)
+            , Brick.str "Description: " Brick.<+> Brick.str (maybe "<empty>" T.unpack $ recordDescription record)
+            , Brick.str "Table Name: " Brick.<+> Brick.str (T.unpack . unTableName $ recordTableName record)
+            , Brick.str "Table Schema: " Brick.<+> Brick.str (T.unpack . unTableSchemaName $ recordTableSchema record)
+            , Brick.str "Uniques: " Brick.<+> Brick.vBox (fmap renderUnique (recordUniques record))
+            , Brick.Widgets.Border.borderWithLabel (Brick.str " Fields ") $
+                Brick.vBox (fmap renderField (recordFields record))
+            ]
+        , Brick.fill ' '
+        ]
+
+
+renderField :: Field -> Brick.Widget ()
+renderField Field {..} =
+  Brick.str (T.unpack (unFieldName fieldName <> " (" <> fieldType <> ")"))
+
+
+renderUnique :: [FieldName] -> Brick.Widget ()
+renderUnique = Brick.str . T.unpack . T.intercalate ", " . fmap unFieldName
+
+
+appAttrMap :: Brick.AttrMap.AttrMap
+appAttrMap =
+  Brick.AttrMap.attrMap
+    Vty.defAttr
+    [ (Brick.Widgets.List.listAttr, Vty.defAttr)
+    , (Brick.Widgets.List.listSelectedAttr, Vty.black `Brick.on` Vty.cyan)
+    ]

src/Postmap/Tui/AppEvent.hs

@@ -0,0 +1,32 @@
+module Postmap.Tui.AppEvent where
+
+import qualified Brick
+import qualified Brick.Widgets.List
+import qualified Graphics.Vty as V
+import Postmap.Tui.AppState
+
+
+data AppEvent
+  = AppEventNone
+
+
+appHandleEvent :: Brick.BrickEvent () AppEvent -> Brick.EventM () AppState ()
+appHandleEvent e =
+  case e of
+    Brick.VtyEvent (V.EvKey (V.KChar 'q') [V.MCtrl]) -> Brick.halt
+    le -> do
+      state <- Brick.get
+      case _appStatePerspective state of
+        AppPerspectiveAbout -> pure ()
+        AppPerspectiveRecords _ -> appHandleEventListRecords le
+
+
+appHandleEventListRecords :: Brick.BrickEvent () AppEvent -> Brick.EventM () AppState ()
+appHandleEventListRecords (Brick.VtyEvent ev) = do
+  state <- Brick.get
+  case _appStatePerspective state of
+    AppPerspectiveRecords ps -> do
+      (nlr, _) <- Brick.nestEventM ps $ Brick.Widgets.List.handleListEvent ev
+      Brick.put $ state {_appStatePerspective = AppPerspectiveRecords nlr}
+    _ -> pure ()
+appHandleEventListRecords _ = pure ()

src/Postmap/Tui/AppState.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Postmap.Tui.AppState where
+
+import qualified Brick.Widgets.List
+import qualified Data.Vector as V
+import Lens.Micro.TH (makeLenses)
+import Postmap.Spec (Record, Spec (..))
+
+
+-- * State
+
+
+data AppState = AppState
+  { _appStateSpec :: !Spec
+  , _appStateSpecPath :: !(Maybe FilePath)
+  , _appStatePerspective :: !AppPerspective
+  }
+
+
+initAppState :: Spec -> AppState
+initAppState spec =
+  AppState
+    { _appStateSpec = spec
+    , _appStateSpecPath = Nothing
+    , _appStatePerspective = AppPerspectiveRecords (mkListRecordsState spec)
+    }
+
+
+-- ** Perspectives
+
+
+data AppPerspective
+  = AppPerspectiveAbout
+  | AppPerspectiveRecords RecordsPerspective
+
+
+-- *** Records
+
+
+type RecordsPerspective = Brick.Widgets.List.List () Record
+
+
+mkListRecordsState :: Spec -> RecordsPerspective
+mkListRecordsState =
+  flip (Brick.Widgets.List.list ()) 1 . V.fromList . specRecords
+
+
+makeLenses ''AppState