From 0d6ca1f464706987f91c59cc3edd678cf1aa5665 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jan=20Hamal=20Dvo=C5=99=C3=A1k?= <mordae@anilinux.org>
Date: Sat, 26 Sep 2020 19:16:19 +0200
Subject: [PATCH] Migrate to Relude
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            |  6 +++---
 lib/Hikaru/Action.hs    | 34 ++++++++++++++++++----------------
 lib/Hikaru/CSRF.hs      | 12 +++++-------
 lib/Hikaru/Dispatch.hs  | 22 +++++++++++-----------
 lib/Hikaru/Form.hs      | 30 +++++++++++++++---------------
 lib/Hikaru/Link.hs      |  4 +---
 lib/Hikaru/Localize.hs  | 12 ++++++------
 lib/Hikaru/Media.hs     |  4 ++--
 lib/Hikaru/Route.hs     |  7 +++----
 lib/Hikaru/Types.hs     |  4 ++--
 package.yaml            |  2 +-
 test/Hikaru/Demo.hs     | 21 ++++++++++-----------
 test/Hikaru/DemoSpec.hs |  3 ++-
 test/Hikaru/FormSpec.hs |  2 +-
 test/Hikaru/Test.hs     |  7 +++----
 15 files changed, 83 insertions(+), 87 deletions(-)

diff --git a/hikaru.cabal b/hikaru.cabal
index 2d65f29..b87781b 100644
--- a/hikaru.cabal
+++ b/hikaru.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: abedad9337bb68e5ffcb0364bf2152ac0633c4810698dfc652cd122bedd3290c
+-- hash: e297323a7b6cecac97f8dd18ae01703782f331a12328a6934ad0a62d7cb0daf3
 
 name:           hikaru
 version:        0.1.0.0
@@ -52,7 +52,6 @@ library
   build-depends:
       aeson >=1.4 && <1.5
     , base >=4.13 && <4.14
-    , base-prelude >=1.3 && <1.4
     , binary >=0.8 && <0.9
     , bytestring >=0.10 && <0.11
     , case-insensitive >=1.2 && <1.3
@@ -63,6 +62,7 @@ library
     , http-types >=0.12 && <0.13
     , lucid >=2.9 && <2.10
     , mtl >=2.2 && <2.3
+    , relude >=0.7 && <0.8
     , resourcet >=1.2 && <1.3
     , string-conversions >=0.4 && <0.5
     , text >=1.2 && <1.3
@@ -91,7 +91,6 @@ test-suite spec
   build-depends:
       aeson >=1.4 && <1.5
     , base >=4.13 && <4.14
-    , base-prelude >=1.3 && <1.4
     , binary >=0.8 && <0.9
     , bytestring >=0.10 && <0.11
     , case-insensitive >=1.2 && <1.3
@@ -104,6 +103,7 @@ test-suite spec
     , http-types >=0.12 && <0.13
     , lucid >=2.9 && <2.10
     , mtl >=2.2 && <2.3
+    , relude >=0.7 && <0.8
     , resourcet >=1.2 && <1.3
     , string-conversions >=0.4 && <0.5
     , text >=1.2 && <1.3
diff --git a/lib/Hikaru/Action.hs b/lib/Hikaru/Action.hs
index 35a3b58..d13e91d 100644
--- a/lib/Hikaru/Action.hs
+++ b/lib/Hikaru/Action.hs
@@ -104,8 +104,9 @@ module Hikaru.Action
   , FilePath
   )
 where
-  import BasePrelude hiding (length)
+  import Relude
 
+  import qualified Data.ByteString as BS
   import qualified Data.ByteString.Lazy as LBS
   import qualified Data.Configurator as Cfg
   import qualified Data.Configurator.Types as Cfg
@@ -113,13 +114,13 @@ where
   import qualified Data.Text.Lazy as LT
   import qualified Network.Wai.Parse as Parse
 
-  import Control.Monad.Trans
+  import Control.Exception (throwIO, bracket_)
   import Control.Monad.Trans.Resource
   import Data.Aeson (Value, ToJSON, encode, eitherDecode')
   import Data.Binary.Builder
-  import Data.ByteString (ByteString, length)
+  import Data.Dynamic
+  import Data.List
   import Data.String.Conversions
-  import Data.Text (Text)
   import Hikaru.Media
   import Hikaru.Types
   import Lucid
@@ -127,6 +128,7 @@ where
   import Network.HTTP.Types.Method
   import Network.HTTP.Types.Status
   import Network.Wai
+  import System.IO.Unsafe
   import Web.Cookie
 
 
@@ -212,16 +214,16 @@ where
   --
   -- Whole operation is bracketed to ensure all finalizers are run.
   --
-  respond :: (ActionEnv -> IO ()) -> Cfg.Config -> Application
-  respond run cfg req resp = do
-    env <- makeActionEnv cfg req
+  respond :: (ActionEnv -> IO ()) -> Application
+  respond run req resp = do
+    env <- makeActionEnv req
 
     bracket_ (return ()) (finalize env) do
       _   <- run env
 
-      st  <- readIORef $ env & aeRespStatus
-      hs  <- readIORef $ env & aeRespHeaders
-      mk  <- readIORef $ env & aeRespMaker
+      st  <- readIORef $ aeRespStatus  $ env
+      hs  <- readIORef $ aeRespHeaders $ env
+      mk  <- readIORef $ aeRespMaker   $ env
 
       resp (mk st hs)
 
@@ -526,7 +528,7 @@ where
       if haveRead < limit
          then do
            chunk <- getChunk
-           writeIORef counter $ haveRead + fromIntegral (length chunk)
+           writeIORef counter $ haveRead + fromIntegral (BS.length chunk)
            return chunk
 
          else do
@@ -534,7 +536,7 @@ where
 
     where
       throwLimitIO :: Int64 -> IO a
-      throwLimitIO n = throwIO (PayloadTooLarge, cs msg :: Text)
+      throwLimitIO n = throwIO (PayloadTooLarge, msg :: Text)
         where msg = "Limit is " <> show n <> " bytes."
 
 
@@ -810,9 +812,9 @@ where
   -- If the header has been given multiple times, leave only one.
   --
   setHeader :: (MonadAction m) => HeaderName -> ByteString -> m ()
-  setHeader n v = modifyActionField aeRespHeaders modify
+  setHeader n v = modifyActionField aeRespHeaders update
     where
-      modify hs = (n, v) : deleteBy headerEq (n, v) hs
+      update hs = (n, v) : deleteBy headerEq (n, v) hs
 
 
   -- |
@@ -838,9 +840,9 @@ where
   --
   modifyHeader :: (MonadAction m)
                => HeaderName -> (Maybe ByteString -> ByteString) -> m ()
-  modifyHeader n fn = modifyActionField aeRespHeaders modify
+  modifyHeader n fn = modifyActionField aeRespHeaders update
     where
-      modify hs = (n, v') : deleteBy headerEq (n, v') hs
+      update hs = (n, v') : deleteBy headerEq (n, v') hs
         where v' = fn (lookup n hs)
 
 
diff --git a/lib/Hikaru/CSRF.hs b/lib/Hikaru/CSRF.hs
index 67fc98c..52e57c6 100644
--- a/lib/Hikaru/CSRF.hs
+++ b/lib/Hikaru/CSRF.hs
@@ -15,13 +15,12 @@ module Hikaru.CSRF
   , isTokenValid
   )
 where
-  import BasePrelude
+  import Relude
 
   import Crypto.Hash
   import Crypto.MAC.HMAC
-  import Data.ByteString (ByteString)
   import Data.String.Conversions
-  import Data.Text (Text, splitOn)
+  import Data.Text (splitOn)
   import Data.Time.Clock.POSIX (getPOSIXTime)
 
   import Hikaru.Action
@@ -36,7 +35,7 @@ where
     secret <- getConfigDefault "csrf.secret" ""
 
     let signature = sign now secret
-     in return $ mconcat [ cs (show now), ":", signature ]
+     in return $ mconcat [ show now, ":", signature ]
 
 
   -- |
@@ -69,12 +68,11 @@ where
 
 
   sign :: Int64 -> Text -> Text
-  sign timestamp secret = cs $ show $ hmacGetDigest digest
+  sign timestamp secret = show $ hmacGetDigest digest
     where
       digest      = hmac timeBytes secretBytes :: HMAC SHA256
       secretBytes = cs secret :: ByteString
-      timeBytes   = cs time :: ByteString
-      time        = show timestamp
+      timeBytes   = show timestamp :: ByteString
 
 
 -- vim:set ft=haskell sw=2 ts=2 et:
diff --git a/lib/Hikaru/Dispatch.hs b/lib/Hikaru/Dispatch.hs
index 75dcb43..4d68d6c 100644
--- a/lib/Hikaru/Dispatch.hs
+++ b/lib/Hikaru/Dispatch.hs
@@ -30,17 +30,17 @@ module Hikaru.Dispatch
   , TopLevel
   )
 where
-  import BasePrelude hiding (insert, lookup, app)
-  import qualified BasePrelude
+  import Relude
 
-  import Control.Monad.State (State, modify, execState)
+  import Control.Exception (catch)
   import Data.CaseInsensitive (original)
-  import Data.Map.Strict hiding (map)
-  import Data.Text (Text)
-  import Network.HTTP.Types.Header
-  import Network.Wai
+  import Data.List (lookup, deleteBy)
   import Hikaru.Route
   import Hikaru.Types
+  import Network.HTTP.Types.Header
+  import Network.Wai
+
+  import qualified Data.Map.Strict as Map
 
 
   -- |
@@ -120,7 +120,7 @@ where
                                    (\(exn, msg) -> mw (err exn msg) req' resp')
 
           err :: RequestError -> Text -> Application
-          err exn msg = case lookup exn envHandlers of
+          err exn msg = case Map.lookup exn envHandlers of
                           Just eh -> runner (eh exn msg)
                           Nothing -> defaultHandler exn msg
 
@@ -135,8 +135,8 @@ where
       fixup = modifyHeader "Vary" (maybe value (<> ", " <> value))
       value = mconcat $ intersperse ", " $ map original vs
 
-      modifyHeader n fn hs = (n, v') : deleteBy headerEq (n, v') hs
-        where v' = fn (BasePrelude.lookup n hs)
+      modifyHeader n fn hs = (n, v') : Data.List.deleteBy headerEq (n, v') hs
+        where v' = fn (Data.List.lookup n hs)
 
       headerEq (x, _) (y, _) = x == y
 
@@ -221,7 +221,7 @@ where
           -> Dispatch r TopLevel ()
   handler e h = Dispatch do
     modify \env@Env{envHandlers} ->
-      env { envHandlers = insert e h envHandlers }
+      env { envHandlers = Map.insert e h envHandlers }
 
 
 -- vim:set ft=haskell sw=2 ts=2 et:
diff --git a/lib/Hikaru/Form.hs b/lib/Hikaru/Form.hs
index 8eb2b3d..662c413 100644
--- a/lib/Hikaru/Form.hs
+++ b/lib/Hikaru/Form.hs
@@ -96,16 +96,16 @@ module Hikaru.Form
   , FromFormMessage(..)
   )
 where
-  import BasePrelude hiding (Option, Control)
+  import Relude hiding (Option, show, elem)
 
-  import Control.Monad.Reader (ReaderT, runReaderT, ask)
-  import Control.Monad.State (StateT, runStateT, execStateT, modify, get)
-  import Control.Monad.Trans (MonadTrans, lift)
-  import Data.Text (Text, strip)
+  import Data.Dynamic
+  import Data.List
+  import Data.Text (strip)
   import Hikaru.Action
   import Hikaru.CSRF
   import Hikaru.Localize
   import Hikaru.Types
+  import Text.Show
 
 
   data Env o
@@ -585,8 +585,8 @@ where
 
     new <- lift $ lift do
       let field = InputField "hidden" Nothing text
-          state = ControlState name field [] [] val
-       in flip execStateT state $ flip runReaderT env $ runControlT body
+          ctrst = ControlState name field [] [] val
+       in flip execStateT ctrst $ flip runReaderT env $ runControlT body
 
     ctrl <- lift $ lift $ buildControl env new
 
@@ -613,8 +613,8 @@ where
 
     new <- lift $ lift do
       let field = InputField "hidden" Nothing text
-          state = ControlState name field [] [] val
-       in flip execStateT state $ flip runReaderT env $ runControlT body
+          ctrst = ControlState name field [] [] val
+       in flip execStateT ctrst $ flip runReaderT env $ runControlT body
 
     ctrl <- lift $ lift $ buildControl env new
 
@@ -658,8 +658,8 @@ where
 
     new <- lift $ lift do
       let field = InputField "text" Nothing text
-          state = ControlState name field [] [] val
-       in flip execStateT state $ flip runReaderT env $ runControlT body
+          ctrst = ControlState name field [] [] val
+       in flip execStateT ctrst $ flip runReaderT env $ runControlT body
 
     ctrl <- lift $ lift $ buildControl env new
 
@@ -701,8 +701,8 @@ where
     new <- lift $ lift do
       let val'  = val <|> (getter <$> envValue)
           field = SelectField []
-          state = ControlState name field [] [] val'
-       in flip execStateT state $ flip runReaderT env $ runControlT body
+          ctrst = ControlState name field [] [] val'
+       in flip execStateT ctrst $ flip runReaderT env $ runControlT body
 
     ctrl <- lift $ lift $ buildControl env new
 
@@ -813,11 +813,11 @@ where
 
   dumpControl :: (MonadIO m, Show l, Show o, Show v) => ControlT t l o v m ()
   dumpControl = ControlT do
-    state <- get
+    ctrst <- get
 
     liftIO do
       putStr "Control Dump:\n  "
-      putStrLn (show state)
+      putStrLn (show ctrst)
 
 
   -- Internal ----------------------------------------------------------------
diff --git a/lib/Hikaru/Link.hs b/lib/Hikaru/Link.hs
index 503184d..4410ae5 100644
--- a/lib/Hikaru/Link.hs
+++ b/lib/Hikaru/Link.hs
@@ -25,12 +25,10 @@ module Hikaru.Link
   , isActivePrefix
   )
 where
-  import BasePrelude
+  import Relude
 
   import Data.Binary.Builder
-  import Data.ByteString (ByteString)
   import Data.String.Conversions
-  import Data.Text (Text)
   import Lucid
   import Network.HTTP.Types.URI
   import Hikaru.Action
diff --git a/lib/Hikaru/Localize.hs b/lib/Hikaru/Localize.hs
index cc52926..1882e82 100644
--- a/lib/Hikaru/Localize.hs
+++ b/lib/Hikaru/Localize.hs
@@ -64,13 +64,13 @@ module Hikaru.Localize
   , selectLanguages
   )
 where
-  import BasePrelude
+  import Relude
 
+  import Data.List
   import Data.String.Conversions
-  import Data.Text (Text)
-  import Lucid
   import Hikaru.Action
   import Hikaru.Media
+  import Lucid
 
 
   -- |
@@ -122,14 +122,14 @@ where
 
   -- |
   -- Localize given message to the language indicated by the
-  -- 'getLanguages' of the current action. Uses 'localize' internally.
+  -- 'getLanguages' of the current action. Uses 'localize' internaly.
   --
   lc :: (MonadAction m, Localizable l) => l -> m Text
   lc msg = do
     langs <- getLanguages
 
     case mapMaybe (flip localize msg) langs of
-      []  -> return $ cs $ show msg
+      []  -> return $ show msg
       x:_ -> return x
 
 
@@ -142,7 +142,7 @@ where
     langs <- getLanguages
 
     case mapMaybe (flip localizeHtml msg) langs of
-      []  -> toHtml $ show msg
+      []  -> toHtml $ (show msg :: Text)
       x:_ -> x
 
 
diff --git a/lib/Hikaru/Media.hs b/lib/Hikaru/Media.hs
index b143df1..dd6c8a2 100644
--- a/lib/Hikaru/Media.hs
+++ b/lib/Hikaru/Media.hs
@@ -24,10 +24,10 @@ module Hikaru.Media
   , selectMedia
   )
 where
-  import BasePrelude hiding (group, find)
+  import Relude hiding (group, find, head)
+  import Relude.Unsafe (head)
 
   import Data.String.Conversions
-  import Data.Text (Text)
   import Data.Text.ICU
 
 
diff --git a/lib/Hikaru/Route.hs b/lib/Hikaru/Route.hs
index be6b572..fe8742f 100644
--- a/lib/Hikaru/Route.hs
+++ b/lib/Hikaru/Route.hs
@@ -55,11 +55,10 @@ module Hikaru.Route
   , Route
   )
 where
-  import BasePrelude hiding (head, delete)
+  import Relude hiding (get, put, head)
 
-  import Data.ByteString (ByteString)
   import Data.String.Conversions
-  import Data.Text (Text)
+  import Data.List (lookup)
   import Network.HTTP.Types.Header
   import Network.HTTP.Types.Method (Method)
   import Network.Wai
@@ -208,7 +207,7 @@ where
   -- Select the best route with respect to the request.
   --
   choosePath :: Request -> [Request -> RouteResult a] -> RouteResult a
-  choosePath req = choose . map (req &)
+  choosePath req = choose . map ($ req)
     where
       choose :: [RouteResult a] -> RouteResult a
       choose []     = RouteFailed NotFound "" []
diff --git a/lib/Hikaru/Types.hs b/lib/Hikaru/Types.hs
index 115e11c..8394f9a 100644
--- a/lib/Hikaru/Types.hs
+++ b/lib/Hikaru/Types.hs
@@ -17,11 +17,11 @@ module Hikaru.Types
   , defaultHandler
   )
 where
-  import BasePrelude
+  import Relude
 
   import Data.ByteString (ByteString)
   import Data.String.Conversions
-  import Data.Text (Text, pack, unpack)
+  import Data.Text (pack, unpack)
   import Network.HTTP.Types.Header
   import Network.HTTP.Types.Status
   import Network.Wai
diff --git a/package.yaml b/package.yaml
index d697cb7..d493b40 100644
--- a/package.yaml
+++ b/package.yaml
@@ -45,7 +45,7 @@ default-extensions:
 dependencies:
   - aeson              >= 1.4  && <1.5
   - base               >= 4.13 && <4.14
-  - base-prelude       >= 1.3  && <1.4
+  - relude             >= 0.7  && <0.8
   - binary             >= 0.8  && <0.9
   - bytestring         >= 0.10 && <0.11
   - case-insensitive   >= 1.2  && <1.3
diff --git a/test/Hikaru/Demo.hs b/test/Hikaru/Demo.hs
index f4b68a6..4bc1e73 100644
--- a/test/Hikaru/Demo.hs
+++ b/test/Hikaru/Demo.hs
@@ -12,11 +12,10 @@ module Hikaru.Demo
   ( makeDemo
   )
 where
-  import BasePrelude hiding (for_, Option, Control)
+  import Relude hiding (for_, Option, get)
 
-  import Control.Monad.Reader
+  import Control.Concurrent.MVar (modifyMVar_)
   import Data.Aeson ()
-  import Data.Text (Text)
   import Hikaru
   import Lucid
   import Network.HTTP.Types.Header
@@ -146,7 +145,7 @@ where
     -- Present fancy HTML result.
     sendHTML do
       h1_ "Welcome!"
-      p_ $ "You are " >> toHtml (show n) >> ". visitor!"
+      p_ $ "You are " >> toHtml (show n :: Text) >> ". visitor!"
 
 
   getRootTextR :: Action ()
@@ -155,9 +154,9 @@ where
     n <- countVisitor
 
     -- Present a plain textual result.
-    sendString $ unlines [ "Welcome!"
-                         , "You are " <> show n <> ". visitor!"
-                         ]
+    sendText $ unlines [ "Welcome!"
+                       , "You are " <> show n <> ". visitor!"
+                       ]
 
 
   postEchoR :: Action ()
@@ -211,13 +210,13 @@ where
           th_ "Mode"
           th_ "Active"
 
-        for cases \Case{..} -> do
+        forM cases \Case{..} -> do
           tr_ do
-            td_ $ toHtml $ show caseId
+            td_ $ toHtml $ (show caseId :: Text)
             td_ $ toHtml $ caseName
             td_ $ toHtml $ caseRecNo
-            td_ $ toHtml $ show caseMode
-            td_ $ toHtml $ show caseActive
+            td_ $ toHtml $ (show caseMode :: Text)
+            td_ $ toHtml $ (show caseActive :: Text)
 
 
   -- Forms -------------------------------------------------------------------
diff --git a/test/Hikaru/DemoSpec.hs b/test/Hikaru/DemoSpec.hs
index 35f0057..161e9e5 100644
--- a/test/Hikaru/DemoSpec.hs
+++ b/test/Hikaru/DemoSpec.hs
@@ -14,10 +14,11 @@ module Hikaru.DemoSpec
   ( spec
   )
 where
-  import BasePrelude
+  import Relude hiding (get)
 
   import Hikaru.Demo
   import Hikaru.Test
+  import System.IO.Unsafe
 
 
   spec :: Spec
diff --git a/test/Hikaru/FormSpec.hs b/test/Hikaru/FormSpec.hs
index a845d7c..e2a9e4b 100644
--- a/test/Hikaru/FormSpec.hs
+++ b/test/Hikaru/FormSpec.hs
@@ -12,7 +12,7 @@ module Hikaru.FormSpec
   ( spec
   )
 where
-  import BasePrelude
+  import Relude
 
   import Hikaru ()
   import Hikaru.Test
diff --git a/test/Hikaru/Test.hs b/test/Hikaru/Test.hs
index 5941094..23626fe 100644
--- a/test/Hikaru/Test.hs
+++ b/test/Hikaru/Test.hs
@@ -21,11 +21,10 @@ module Hikaru.Test
   , module Test.Hspec
   )
 where
-  import BasePrelude
+  import Relude hiding (get)
 
-  import qualified Data.ByteString.Lazy as Lazy
+  import qualified Data.ByteString.Lazy as LBS
 
-  import Data.ByteString (ByteString)
   import Network.HTTP.Types
   import Network.Wai
   import Network.Wai.Internal
@@ -45,7 +44,7 @@ where
   post path headers body = srequest sreq
     where
       req = setPath defaultRequest path
-      sreq = SRequest { simpleRequestBody = Lazy.fromStrict body
+      sreq = SRequest { simpleRequestBody = LBS.fromStrict body
                       , simpleRequest     = req { requestMethod  = methodPost
                                                 , requestHeaders = headers
                                                 }
-- 
GitLab