mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-09-11 12:05:35 +03:00
* Fix type error in examples
* Attempt to run build including examples
* Force build failure
* Revert "Force build failure"
This reverts commit 9728f0b0ac
.
213 lines
6.4 KiB
Haskell
213 lines
6.4 KiB
Haskell
{-|
|
|
Module : Main
|
|
Copyright : (c) 2018 Francisco Vallarino
|
|
License : BSD-3-Clause (see the LICENSE file)
|
|
Maintainer : fjvallarino@gmail.com
|
|
Stability : experimental
|
|
Portability : non-portable
|
|
|
|
Main module for the 'Books' example.
|
|
-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module Main where
|
|
|
|
import Control.Exception
|
|
import Control.Lens
|
|
import Data.Default
|
|
import Data.Either.Extra
|
|
import Data.Maybe
|
|
import Data.Text (Text)
|
|
import TextShow
|
|
|
|
import qualified Data.Text as T
|
|
import qualified Network.Wreq as W
|
|
import qualified Network.Wreq.Session as Sess
|
|
|
|
import BookTypes
|
|
import Monomer
|
|
|
|
import qualified Monomer.Lens as L
|
|
|
|
type BooksWenv = WidgetEnv BooksModel BooksEvt
|
|
type BooksNode = WidgetNode BooksModel BooksEvt
|
|
|
|
bookImage :: Maybe Int -> Text -> WidgetNode s BooksEvt
|
|
bookImage imgId size = maybe filler coverImg imgId where
|
|
baseUrl = "http://covers.openlibrary.org/b/id/<id>-<size>.jpg"
|
|
imgUrl i = T.replace "<size>" size $ T.replace "<id>" (showt i) baseUrl
|
|
coverImg i = image_ (imgUrl i) [fitHeight, alignRight]
|
|
|
|
bookRow :: BooksWenv -> Book -> BooksNode
|
|
bookRow wenv b = row where
|
|
rowBgColor = wenv ^. L.theme . L.userColorMap . at "rowBgColor" . non def
|
|
publishYear = maybe "" showt (b ^. year)
|
|
|
|
rowContent b = hstack [
|
|
vstack [
|
|
label_ (b ^. title) [resizeFactor 1]
|
|
`styleBasic` [textFont "Medium", textSize 16],
|
|
spacer,
|
|
label_ (T.intercalate ", " (b ^. authors)) [resizeFactor 1]
|
|
`styleBasic` [textSize 14]
|
|
],
|
|
filler,
|
|
vstack [
|
|
label publishYear `styleBasic` [width 50, textSize 14],
|
|
spacer
|
|
],
|
|
bookImage (b ^. cover) "S" `styleBasic` [width 35]
|
|
]
|
|
|
|
row = box_ cfg content `styleBasic` [padding 10, paddingT 0] where
|
|
cfg = [expandContent, onClick (BooksShowDetails b)]
|
|
content = rowContent b
|
|
`styleBasic` [height 80, padding 20, radius 5]
|
|
`styleHover` [bgColor rowBgColor, cursorIcon CursorHand]
|
|
|
|
bookDetail :: Book -> WidgetNode s BooksEvt
|
|
bookDetail b = content `styleBasic` [minWidth 500, paddingH 20] where
|
|
hasCover = isJust (b ^. cover)
|
|
publishYear = maybe "" showt (b ^. year)
|
|
|
|
shortLabel value = label value `styleBasic` [textFont "Medium", textTop]
|
|
longLabel value = label_ value [multiline, ellipsis, trimSpaces]
|
|
|
|
content = hstack [
|
|
vstack_ [childSpacing] [
|
|
longLabel (b ^. title)
|
|
`styleBasic` [textSize 20, textFont "Medium"],
|
|
longLabel (T.intercalate ", " (b ^. authors))
|
|
`styleBasic` [textSize 16],
|
|
label publishYear
|
|
`styleBasic` [textSize 14]
|
|
],
|
|
widgetIf hasCover $ hstack [
|
|
filler,
|
|
bookImage (b ^. cover) "M"
|
|
`styleBasic` [width 200]
|
|
]
|
|
]
|
|
|
|
buildUI
|
|
:: WidgetEnv BooksModel BooksEvt
|
|
-> BooksModel
|
|
-> WidgetNode BooksModel BooksEvt
|
|
buildUI wenv model = widgetTree where
|
|
sectionBgColor = wenv ^. L.theme . L.sectionColor
|
|
|
|
errorOverlay = alertMsg msg BooksCloseError where
|
|
msg = fromMaybe "" (model ^. errorMsg)
|
|
|
|
bookOverlay = alert BooksCloseDetails content where
|
|
content = maybe spacer bookDetail (model ^. selected)
|
|
|
|
searchOverlay = box content `styleBasic` [bgColor (darkGray & L.a .~ 0.8)] where
|
|
content = label "Searching" `styleBasic` [textSize 20, textColor black]
|
|
|
|
searchForm = keystroke [("Enter", BooksSearch)] $ vstack [
|
|
hstack [
|
|
label "Query:",
|
|
spacer,
|
|
textField query `nodeKey` "query",
|
|
spacer,
|
|
mainButton "Search" BooksSearch
|
|
] `styleBasic` [bgColor sectionBgColor, padding 25]
|
|
]
|
|
|
|
countLabel = label caption `styleBasic` [padding 10] where
|
|
caption = "Books (" <> showt (length $ model ^. books) <> ")"
|
|
|
|
booksChanged wenv old new = old ^. books /= new ^. books
|
|
|
|
widgetTree = zstack [
|
|
vstack [
|
|
searchForm,
|
|
countLabel,
|
|
box_ [mergeRequired booksChanged] $
|
|
vscroll (vstack (bookRow wenv <$> model ^. books)) `nodeKey` "mainScroll"
|
|
],
|
|
errorOverlay `nodeVisible` isJust (model ^. errorMsg),
|
|
bookOverlay `nodeVisible` isJust (model ^. selected),
|
|
searchOverlay `nodeVisible` model ^. searching
|
|
]
|
|
|
|
handleEvent
|
|
:: Sess.Session
|
|
-> WidgetEnv BooksModel BooksEvt
|
|
-> WidgetNode BooksModel BooksEvt
|
|
-> BooksModel
|
|
-> BooksEvt
|
|
-> [EventResponse BooksModel BooksEvt BooksModel BooksEvt]
|
|
handleEvent sess wenv node model evt = case evt of
|
|
BooksInit -> [SetFocusOnKey "query"]
|
|
BooksSearch -> [
|
|
Model $ model & searching .~ True,
|
|
Task $ searchBooks sess (model ^. query)
|
|
]
|
|
BooksSearchResult resp -> [
|
|
Message "mainScroll" ScrollReset,
|
|
Model $ model
|
|
& searching .~ False
|
|
& errorMsg .~ Nothing
|
|
& books .~ resp ^. docs
|
|
]
|
|
BooksSearchError msg -> [
|
|
Model $ model
|
|
& searching .~ False
|
|
& errorMsg ?~ msg
|
|
& books .~ []
|
|
]
|
|
BooksShowDetails book -> [Model $ model & selected ?~ book]
|
|
BooksCloseDetails -> [Model $ model & selected .~ Nothing]
|
|
BooksCloseError -> [Model $ model & errorMsg .~ Nothing]
|
|
|
|
searchBooks :: Sess.Session -> Text -> IO BooksEvt
|
|
searchBooks sess query = do
|
|
putStrLn . T.unpack $ "Searching: " <> query
|
|
result <- catchAny (fetch url) (return . Left . T.pack . show)
|
|
|
|
case result of
|
|
Right resp -> return (BooksSearchResult resp)
|
|
Left err -> return (BooksSearchError err)
|
|
where
|
|
url = "https://openlibrary.org/search.json?q=" <> T.unpack query
|
|
checkEmpty resp
|
|
| null (resp ^. docs) = Nothing
|
|
| otherwise = Just resp
|
|
fetch url = do
|
|
resp <- Sess.get sess url
|
|
>>= W.asJSON
|
|
>>= return . preview (W.responseBody . _Just)
|
|
|
|
return $ maybeToEither "Empty response" (resp >>= checkEmpty)
|
|
|
|
main :: IO ()
|
|
main = do
|
|
sess <- Sess.newAPISession
|
|
startApp initModel (handleEvent sess) buildUI config
|
|
where
|
|
config = [
|
|
appWindowTitle "Book search",
|
|
appWindowIcon "./assets/images/icon.png",
|
|
appTheme customDarkTheme,
|
|
appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",
|
|
appFontDef "Medium" "./assets/fonts/Roboto-Medium.ttf",
|
|
appInitEvent BooksInit
|
|
]
|
|
initModel = BooksModel "" False Nothing [] Nothing
|
|
|
|
customLightTheme :: Theme
|
|
customLightTheme = lightTheme
|
|
& L.userColorMap . at "rowBgColor" ?~ rgbHex "#ECECEC"
|
|
|
|
customDarkTheme :: Theme
|
|
customDarkTheme = darkTheme
|
|
& L.userColorMap . at "rowBgColor" ?~ rgbHex "#656565"
|
|
|
|
-- Utility function to avoid the "Ambiguous type variable..." error
|
|
catchAny :: IO a -> (SomeException -> IO a) -> IO a
|
|
catchAny = catch
|