From 297c8335d278c1faf5b24c1c448839eb29b67275 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jan=20Hamal=20Dvo=C5=99=C3=A1k?= <mordae@anilinux.org>
Date: Sat, 5 Feb 2022 20:04:08 +0100
Subject: [PATCH] Some more cleanup
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Signed-off-by: Jan Hamal Dvořák <mordae@anilinux.org>
---
hikaru.cabal | 14 +++++++-------
lib/Hikaru/CSRF.hs | 12 +++++-------
lib/Hikaru/Dispatch.hs | 5 ++---
lib/Hikaru/Link.hs | 7 ++-----
lib/Hikaru/Media.hs | 5 ++---
lib/Hikaru/Route.hs | 9 ++++-----
lib/Hikaru/Widget.hs | 17 ++++++++++++++---
test/Hikaru/Demo.hs | 27 +++++++++++++--------------
8 files changed, 49 insertions(+), 47 deletions(-)
diff --git a/hikaru.cabal b/hikaru.cabal
index 8559e1f..a306e4f 100644
--- a/hikaru.cabal
+++ b/hikaru.cabal
@@ -55,7 +55,7 @@ library
DisambiguateRecordFields NoFieldSelectors OverloadedRecordDot
ghc-options:
- -Wall -Wcompat -Wincomplete-uni-patterns
+ -Wall -Wcompat -Wincomplete-uni-patterns -Wpartial-fields
-Wincomplete-record-updates -Widentities -Wredundant-constraints
-Wunused-packages
@@ -69,6 +69,7 @@ library
containers >=0.6,
cookie >=0.4,
foreign-store >=0.2,
+ HsOpenSSL >=0.11,
http-types >=0.12,
hvect >=0.4,
lucid >=2.9,
@@ -82,8 +83,7 @@ library
wai >=3.2,
wai-extra >=3.0,
wai-websockets >=3.0,
- websockets >=0.12,
- HsOpenSSL >=0.11
+ websockets >=0.12
test-suite spec
type: exitcode-stdio-1.0
@@ -111,7 +111,7 @@ test-suite spec
DisambiguateRecordFields NoFieldSelectors OverloadedRecordDot
ghc-options:
- -Wall -Wcompat -Wincomplete-uni-patterns
+ -Wall -Wcompat -Wincomplete-uni-patterns -Wpartial-fields
-Wincomplete-record-updates -Widentities -Wredundant-constraints
-threaded -rtsopts -with-rtsopts=-N
@@ -125,6 +125,8 @@ test-suite spec
containers >=0.6,
cookie >=0.4,
foreign-store >=0.2,
+ hikaru,
+ hspec,
http-types >=0.12,
hvect >=0.4,
lucid >=2.9,
@@ -138,6 +140,4 @@ test-suite spec
wai >=3.2,
wai-extra >=3.0,
wai-websockets >=3.0,
- websockets >=0.12,
- hikaru,
- hspec
+ websockets >=0.12
diff --git a/lib/Hikaru/CSRF.hs b/lib/Hikaru/CSRF.hs
index 0d1f2ec..d99a1b8 100644
--- a/lib/Hikaru/CSRF.hs
+++ b/lib/Hikaru/CSRF.hs
@@ -18,17 +18,15 @@ where
import Praha
import Praha.Config.Environment
- import System.IO.Unsafe
+ import Hikaru.Action
+ import Data.Text (splitOn)
+ import Data.Time.Clock.POSIX (getPOSIXTime)
import OpenSSL
- import OpenSSL.Random
import OpenSSL.EVP.Base64
import OpenSSL.EVP.Digest
-
- import Data.Text (splitOn)
- import Data.Time.Clock.POSIX (getPOSIXTime)
-
- import Hikaru.Action
+ import OpenSSL.Random
+ import System.IO.Unsafe
sha256 :: Digest
diff --git a/lib/Hikaru/Dispatch.hs b/lib/Hikaru/Dispatch.hs
index f19237e..1052d94 100644
--- a/lib/Hikaru/Dispatch.hs
+++ b/lib/Hikaru/Dispatch.hs
@@ -34,12 +34,11 @@ where
import Hikaru.Action (abortMiddleware)
import Hikaru.Route
- import Network.HTTP.Types.Status
+ import Data.List (sortOn, reverse, lookup)
import Network.HTTP.Types.Header
+ import Network.HTTP.Types.Status
import Network.Wai
- import Data.List (reverse, lookup, sortOn)
-
-- |
-- Since routes do not share a common type (due to their captured parameters
diff --git a/lib/Hikaru/Link.hs b/lib/Hikaru/Link.hs
index eae4ab1..5de3cb1 100644
--- a/lib/Hikaru/Link.hs
+++ b/lib/Hikaru/Link.hs
@@ -24,15 +24,12 @@ where
import Hikaru.Route
import Hikaru.Types
- import Network.HTTP.Types.URI
-
import Data.Binary.Builder
+ import Data.HVect
import Data.List (map, filter)
import Data.Maybe (isJust)
-
- import Data.HVect
-
import Lucid
+ import Network.HTTP.Types.URI
-- |
diff --git a/lib/Hikaru/Media.hs b/lib/Hikaru/Media.hs
index b8d3620..63901d3 100644
--- a/lib/Hikaru/Media.hs
+++ b/lib/Hikaru/Media.hs
@@ -27,10 +27,9 @@ module Hikaru.Media
where
import Praha
- import Data.List (filter, lookup, sortOn)
-
- import Data.Char
import Data.Attoparsec.Text
+ import Data.Char
+ import Data.List (filter, lookup, sortOn)
-- |
diff --git a/lib/Hikaru/Route.hs b/lib/Hikaru/Route.hs
index cfd6b8d..9a74029 100644
--- a/lib/Hikaru/Route.hs
+++ b/lib/Hikaru/Route.hs
@@ -55,18 +55,17 @@ module Hikaru.Route
)
where
import Praha hiding (curry)
+
import Hikaru.Media
import Hikaru.Types
+ import Data.HVect hiding (reverse)
+ import Data.List (nub, reverse, lookup)
+ import Data.Typeable (TypeRep, typeRep)
import Network.HTTP.Types.Header
import Network.Wai
import Network.Wai.Handler.WebSockets
- import Data.List (reverse, nub, lookup)
- import Data.Typeable (TypeRep, typeRep)
-
- import Data.HVect hiding (reverse)
-
-- |
-- Route combines path description with a handler that gets saturated
diff --git a/lib/Hikaru/Widget.hs b/lib/Hikaru/Widget.hs
index d3ac9d9..d2b06f8 100644
--- a/lib/Hikaru/Widget.hs
+++ b/lib/Hikaru/Widget.hs
@@ -54,6 +54,7 @@ module Hikaru.Widget
-- * Building Widgets
, WidgetT
+ , getPrefix
, getArguments
, getArgumentMaybe
, getArgumentDefault
@@ -64,11 +65,12 @@ module Hikaru.Widget
)
where
import Praha
- import Data.Text (stripPrefix)
+
import Data.List (lookup, filter)
- import Lucid
- import Hikaru.Types
+ import Data.Text (stripPrefix)
import Hikaru.Action
+ import Hikaru.Types
+ import Lucid
-- |
@@ -161,6 +163,15 @@ where
}
+ -- |
+ -- Obtain widget prefix as text.
+ --
+ getPrefix :: (Monad m) => WidgetT m Text
+ getPrefix = WidgetT do
+ Env{prefix} <- ask
+ return prefix
+
+
-- |
-- Obtain all widget arguments as pieces of text.
--
diff --git a/test/Hikaru/Demo.hs b/test/Hikaru/Demo.hs
index 2def376..d5c006d 100644
--- a/test/Hikaru/Demo.hs
+++ b/test/Hikaru/Demo.hs
@@ -16,13 +16,12 @@ where
import Hikaru
- import UnliftIO.MVar
import Data.Aeson (Value)
+ import Data.Text (unlines)
import Lucid
import Network.HTTP.Types.Header
import Network.HTTP.Types.Status
- import Network.Wai
- import Data.Text (unlines)
+ import UnliftIO.MVar
-- Action ------------------------------------------------------------------
@@ -39,10 +38,10 @@ where
deriving (Functor, Applicative, Monad, MonadIO)
instance MonadAction Action where
- getActionEnv = Action (demoActionEnv <$> ask)
+ getActionEnv = Action ((.demoActionEnv) <$> ask)
instance MonadModel Action where
- getModelEnv = Action (demoModelEnv <$> ask)
+ getModelEnv = Action ((.demoModelEnv) <$> ask)
data DemoEnv
@@ -74,7 +73,7 @@ where
countVisitor :: (MonadModel m) => m Word
countVisitor = do
- counter <- modelCounter <$> getModelEnv
+ counter <- (.modelCounter) <$> getModelEnv
liftIO do
modifyMVar_ counter (return . (+ 1))
readMVar counter
@@ -82,7 +81,7 @@ where
addCase :: (MonadModel m) => AddCase -> m Case
addCase AddCase{..} = do
- nextId <- liftIO . readMVar . modelCounter =<< getModelEnv
+ nextId <- liftIO . readMVar . (.modelCounter) =<< getModelEnv
let case' = Case { caseId = nextId
, caseName = acName
@@ -91,7 +90,7 @@ where
, caseActive = acActive
}
- cases <- modelCases <$> getModelEnv
+ cases <- (.modelCases) <$> getModelEnv
liftIO do
modifyMVar_ cases (return . (<> [case']))
@@ -110,7 +109,7 @@ where
runAction :: ModelEnv -> Action () -> Application
runAction me act = do
respond \ae -> do
- runReaderT (unAction act) (DemoEnv ae me)
+ runReaderT ((.unAction) act) (DemoEnv ae me)
makeApplication :: ModelEnv -> Application
@@ -215,7 +214,7 @@ where
handle = do
setHeader hCacheControl "no-store"
- cases <- liftIO . readMVar . modelCases =<< getModelEnv
+ cases <- liftIO . readMVar . (.modelCases) =<< getModelEnv
sendHTML do
h1_ "Cases"
@@ -361,18 +360,18 @@ where
(\(x1, x2) x3 x4 -> AddCase x1 x2 x3 x4)
<$> element MsgCaseName do
(,)
- <$> input "name" acName do
+ <$> input "name" (.acName) do
return ()
- <*> input "recno" acRecNo do
+ <*> input "recno" (.acRecNo) do
return ()
<*> element MsgCaseMode do
- select "mode" acMode do
+ select "mode" (.acMode) do
return ()
<*> element MsgCaseEnabled do
- select "active" acActive do
+ select "active" (.acActive) do
hint RenderExpanded
--
GitLab