monomer-flatpak-example-0.0.3.0: app/Main.hs

module Main (main) where

import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Text (Text, pack, unpack)
import Monomer
import Monomer.Hagrid
import Paths_monomer_flatpak_example (getDataFileName)
import System.Directory (getCurrentDirectory, getHomeDirectory, listDirectory)
import System.Environment (getEnvironment)
import Prelude hiding (unwords)

data AppModel = AppModel
  { fileSystem :: Seq EnvironmentInfo,
    environmentVariables :: Seq EnvironmentInfo
  }
  deriving (Eq, Show)

data EnvironmentInfo = EnvironmentInfo
  { key :: Text,
    value :: Text
  }
  deriving (Eq, Show)

data AppEvent
  = AppInit
  | AppInitFinish (Seq EnvironmentInfo) (Seq EnvironmentInfo)

main :: IO ()
main = do
  regularFontPath <- pack <$> getDataFileName "/fonts/Cantarell/Cantarell-Regular.ttf"
  iconPath <- pack <$> getDataFileName "/io.github.Dretch.MonomerFlatpakExample.png"
  startApp initialModel handleEvent buildUI (config regularFontPath iconPath)
  where
    initialModel = AppModel {fileSystem = mempty, environmentVariables = mempty}
    config regularFontPath iconPath =
      [ appTheme darkTheme,
        appWindowTitle "Monomer Flatpak Example",
        appWindowIcon iconPath,
        appWindowState (MainWindowNormal (1000, 800)),
        appFontDef "Regular" regularFontPath,
        appDisableAutoScale True,
        appInitEvent AppInit
      ]

buildUI :: UIBuilder AppModel AppEvent
buildUI _wenv model =
  vstack_
    [childSpacing_ 5]
    [ label "Monomer Flatpak Example"
        `styleBasic` [textSize 40, paddingL 5, paddingT 10, paddingR 10],
      label "This is a demo of the monomer framework running inside the Flatpak sandbox."
        `styleBasic` [padding 5],
      hagrid
        [ (textColumn "File System Info" (.key)) {initialWidth = 300},
          (widgetColumn "" valueColumn) {initialWidth = 700}
        ]
        model.fileSystem,
      hagrid
        [ (textColumn "Environment Variable" (.key)) {initialWidth = 300},
          (widgetColumn "" valueColumn) {initialWidth = 700}
        ]
        model.environmentVariables
    ]

valueColumn :: Int -> EnvironmentInfo -> WidgetNode s e
valueColumn _ix model =
  label_ model.value [multiline, ellipsis]

handleEvent :: EventHandler AppModel AppEvent sp ep
handleEvent _wenv _node model = \case
  AppInit ->
    [ Task $ do
        curDir <- pack <$> getCurrentDirectory
        homeDir <- pack <$> getHomeDirectory
        lsRoot <- pack . unlines <$> listDirectory "/"
        lsCurDir <- pack . unlines <$> listDirectory (unpack curDir)
        lsHomeDir <- pack . unlines <$> listDirectory (unpack homeDir)
        envVars <- Seq.fromList . map (\(k, v) -> EnvironmentInfo (pack k) (pack v)) <$> getEnvironment
        pure $
          AppInitFinish
            ( Seq.fromList
                [ EnvironmentInfo "Current Directory" curDir,
                  EnvironmentInfo "Home Directory" homeDir,
                  EnvironmentInfo "ls /" lsRoot,
                  EnvironmentInfo ("ls " <> curDir) lsCurDir,
                  EnvironmentInfo ("ls " <> homeDir) lsHomeDir
                ]
            )
            envVars
    ]
  AppInitFinish fileSystem environmentVariables ->
    [Model model {fileSystem, environmentVariables}]