From 84c9e725756cf5e29f4eb63937d3b097a3d66845 Mon Sep 17 00:00:00 2001
From: Jens Nolte <jens@nightmarestudio.de>
Date: Sat, 1 Feb 2020 03:27:20 +0100
Subject: [PATCH] Move BlockText into BlockOutput module
---
src/QBar/BlockOutput.hs | 166 +++++++++++++++++++++++++++++++++++-
src/QBar/BlockText.hs | 167 -------------------------------------
src/QBar/Blocks/Battery.hs | 1 -
src/QBar/Blocks/Date.hs | 1 -
src/QBar/ControlSocket.hs | 1 -
src/QBar/Core.hs | 1 -
src/QBar/Filter.hs | 1 -
src/QBar/Server.hs | 1 -
src/QBar/Themes.hs | 1 -
9 files changed, 165 insertions(+), 175 deletions(-)
delete mode 100644 src/QBar/BlockText.hs
diff --git a/src/QBar/BlockOutput.hs b/src/QBar/BlockOutput.hs
index a4a3f76..1b20587 100644
--- a/src/QBar/BlockOutput.hs
+++ b/src/QBar/BlockOutput.hs
@@ -1,13 +1,17 @@
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module QBar.BlockOutput where
-import QBar.BlockText
+import QBar.Pango
import Control.Lens
import Data.Aeson.TH
+import Data.Int (Int64)
import qualified Data.Text.Lazy as T
+
+
data BlockOutput = BlockOutput
{ _fullText :: BlockText
, _shortText :: Maybe BlockText
@@ -15,8 +19,34 @@ data BlockOutput = BlockOutput
, _invalid :: Bool
}
deriving (Eq, Show)
+
+
+newtype BlockText = BlockText [BlockTextSegment]
+ deriving (Eq, Show)
+instance Semigroup BlockText where
+ (BlockText a) <> (BlockText b) = BlockText (a <> b)
+instance Monoid BlockText where
+ mempty = BlockText []
+
+intercalate :: Monoid a => a -> [a] -> a
+intercalate _ [] = mempty
+intercalate _ [x] = x
+intercalate inter (x:xs) = x <> inter <> intercalate inter xs
+
+data BlockTextSegment = BlockTextSegment {
+ active :: Bool,
+ importance :: Importance,
+ text :: T.Text
+ }
+ | PangoTextSegment T.Text
+ deriving (Eq, Show)
+
+type Importance = Float
+
$(deriveJSON defaultOptions ''BlockOutput)
makeLenses ''BlockOutput
+$(deriveJSON defaultOptions ''BlockTextSegment)
+$(deriveJSON defaultOptions ''BlockText)
mkBlockOutput :: BlockText -> BlockOutput
@@ -36,3 +66,137 @@ emptyBlock = mkBlockOutput mempty
addIcon :: T.Text -> BlockOutput -> BlockOutput
addIcon icon = over fullText $ (<>) . normalText $ icon <> " "
+
+
+
+normalImportant :: Importance
+normalImportant = 1
+warnImportant :: Importance
+warnImportant = 2
+errorImportant :: Importance
+errorImportant = 3
+criticalImportant :: Importance
+criticalImportant = 4
+
+isCritical :: Importance -> Bool
+isCritical i
+ | i >= criticalImportant = True
+ | otherwise = False
+isError :: Importance -> Bool
+isError i
+ | isCritical i = False
+ | i >= errorImportant = True
+ | otherwise = False
+isWarning :: Importance -> Bool
+isWarning i
+ | isCritical i = False
+ | isError i = False
+ | i >= warnImportant = True
+ | otherwise = False
+isNormal :: Importance -> Bool
+isNormal i
+ | isCritical i = False
+ | isError i = False
+ | isWarning i = False
+ | otherwise = True
+
+toImportance :: Real a => (a, a, a, a, a, a) -> a -> Importance
+toImportance (tMax, tCrit, tErr, tWarn, tNorm, tMin) =
+ toImportance' (Just tMax, tCrit, tErr, tWarn, tNorm, Just tMin)
+
+toImportance' :: forall a. Real a => (Maybe a, a, a, a, a, Maybe a) -> a -> Importance
+toImportance' (tMax, tCrit, tErr, tWarn, tNorm, tMin) val
+ | tCrit <= val = 4 + valueCrit tMax tCrit val
+ | tErr <= val = 3 + linearMatch tCrit tErr val
+ | tWarn <= val = 2 + linearMatch tErr tWarn val
+ | tNorm <= val = 1 + linearMatch tWarn tNorm val
+ | otherwise = 0 + valueOtherwise tNorm tMin val
+ where
+ e :: Importance
+ e = exp 1
+ linearMatch :: a -> a -> a -> Importance
+ linearMatch u l v = frac (v - l) (u - l)
+ logarithmicMatch :: a -> a -> Importance
+ logarithmicMatch l u = 1 - 1 / log (e + realToFrac (u - l))
+ frac :: a -> a -> Importance
+ frac a b = realToFrac a / realToFrac b
+ valueCrit :: Maybe a -> a -> a -> Importance
+ valueCrit (Just tMax') tCrit' v
+ | tMax' > v = linearMatch tMax' tCrit' v
+ | otherwise = 1
+ valueCrit Nothing tCrit' v = logarithmicMatch tCrit' v
+ valueOtherwise :: a -> Maybe a -> a -> Importance
+ valueOtherwise tNorm' (Just tMin') v
+ | tMin' < v = linearMatch tNorm' tMin' v
+ | otherwise = 0
+ valueOtherwise tNorm' Nothing v = 1 - logarithmicMatch v tNorm'
+
+
+removePango :: BlockText -> T.Text
+removePango (BlockText b) = foldr ((<>) . removePangoFromSegment) "" b
+ where
+ removePangoFromSegment :: BlockTextSegment -> T.Text
+ removePangoFromSegment BlockTextSegment { active=_active, importance=_importance, text } = text
+ removePangoFromSegment (PangoTextSegment text) =
+ case parsePango text of
+ Left _ -> text
+ Right parsed -> removeFormatting parsed
+
+printedLength :: BlockText -> Int64
+printedLength (BlockText b) = foldr ((+) . printedLength') 0 b
+ where
+ printedLength' :: BlockTextSegment -> Int64
+ printedLength' BlockTextSegment { text, active=_, importance=_ } = T.length text
+ printedLength' (PangoTextSegment _) = 0
+
+mkText :: Bool -> Importance -> T.Text -> BlockText
+mkText active importance text = BlockText [BlockTextSegment { text = pangoFriendly text, active, importance }]
+ where
+ pangoFriendly :: T.Text -> T.Text
+ pangoFriendly = T.replace "<" "<" . T.replace ">" ">" . T.replace "&" "&"
+
+activeImportantText :: Importance -> T.Text -> BlockText
+activeImportantText = mkText True
+
+importantText :: Importance -> T.Text -> BlockText
+importantText = mkText False
+
+activeText :: T.Text -> BlockText
+activeText = mkText True normalImportant
+
+normalText :: T.Text -> BlockText
+normalText = mkText False normalImportant
+
+pangoText :: T.Text -> BlockText
+pangoText pango = BlockText [PangoTextSegment pango]
+
+surroundWith :: (T.Text -> BlockText) -> T.Text -> T.Text -> BlockText -> BlockText
+surroundWith format left right middle = format left <> middle <> format right
+
+data Color = ColorRGB Float Float Float | ColorRGBA Float Float Float Float
+colorToHex :: Color -> T.Text
+colorToHex = colorToHex'
+ where
+ colorToHex' :: Color -> T.Text
+ colorToHex' (ColorRGB r g b) = "#" <> (toDualHex . floor) (r * 255) <> (toDualHex . floor) (g * 255) <> (toDualHex . floor) (b * 255)
+ colorToHex' (ColorRGBA r g b a) = "#" <> (toDualHex . floor) (r * 255) <> (toDualHex . floor) (g * 255) <> (toDualHex . floor) (b * 255) <> (toDualHex . floor) (a * 255)
+ toHex :: Int -> T.Text
+ toHex 0 = "0"
+ toHex 1 = "1"
+ toHex 2 = "2"
+ toHex 3 = "3"
+ toHex 4 = "4"
+ toHex 5 = "5"
+ toHex 6 = "6"
+ toHex 7 = "7"
+ toHex 8 = "8"
+ toHex 9 = "9"
+ toHex 10 = "A"
+ toHex 11 = "B"
+ toHex 12 = "C"
+ toHex 13 = "D"
+ toHex 14 = "E"
+ toHex 15 = "F"
+ toHex x = toHex $ mod x 16
+ toDualHex :: Int -> T.Text
+ toDualHex x = toHex (div x 16) <> toHex x
diff --git a/src/QBar/BlockText.hs b/src/QBar/BlockText.hs
deleted file mode 100644
index 80c15b1..0000000
--- a/src/QBar/BlockText.hs
+++ /dev/null
@@ -1,167 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module QBar.BlockText where
-
-import Data.Aeson.TH
-import qualified Data.Text.Lazy as T
-import Data.Int (Int64)
-import QBar.Pango
-
-newtype BlockText = BlockText [BlockTextSegment]
- deriving (Eq, Show)
-instance Semigroup BlockText where
- (BlockText a) <> (BlockText b) = BlockText (a <> b)
-instance Monoid BlockText where
- mempty = BlockText []
-
-intercalate :: Monoid a => a -> [a] -> a
-intercalate _ [] = mempty
-intercalate _ [x] = x
-intercalate inter (x:xs) = x <> inter <> intercalate inter xs
-
-data BlockTextSegment = BlockTextSegment {
- active :: Bool,
- importance :: Importance,
- text :: T.Text
- }
- | PangoTextSegment T.Text
- deriving (Eq, Show)
-
-type Importance = Float
-
-$(deriveJSON defaultOptions ''BlockTextSegment)
-$(deriveJSON defaultOptions ''BlockText)
-
-
-normalImportant :: Importance
-normalImportant = 1
-warnImportant :: Importance
-warnImportant = 2
-errorImportant :: Importance
-errorImportant = 3
-criticalImportant :: Importance
-criticalImportant = 4
-
-isCritical :: Importance -> Bool
-isCritical i
- | i >= criticalImportant = True
- | otherwise = False
-isError :: Importance -> Bool
-isError i
- | isCritical i = False
- | i >= errorImportant = True
- | otherwise = False
-isWarning :: Importance -> Bool
-isWarning i
- | isCritical i = False
- | isError i = False
- | i >= warnImportant = True
- | otherwise = False
-isNormal :: Importance -> Bool
-isNormal i
- | isCritical i = False
- | isError i = False
- | isWarning i = False
- | otherwise = True
-
-toImportance :: Real a => (a, a, a, a, a, a) -> a -> Importance
-toImportance (tMax, tCrit, tErr, tWarn, tNorm, tMin) =
- toImportance' (Just tMax, tCrit, tErr, tWarn, tNorm, Just tMin)
-
-toImportance' :: forall a. Real a => (Maybe a, a, a, a, a, Maybe a) -> a -> Importance
-toImportance' (tMax, tCrit, tErr, tWarn, tNorm, tMin) val
- | tCrit <= val = 4 + valueCrit tMax tCrit val
- | tErr <= val = 3 + linearMatch tCrit tErr val
- | tWarn <= val = 2 + linearMatch tErr tWarn val
- | tNorm <= val = 1 + linearMatch tWarn tNorm val
- | otherwise = 0 + valueOtherwise tNorm tMin val
- where
- e :: Importance
- e = exp 1
- linearMatch :: a -> a -> a -> Importance
- linearMatch u l v = frac (v - l) (u - l)
- logarithmicMatch :: a -> a -> Importance
- logarithmicMatch l u = 1 - 1 / log (e + realToFrac (u - l))
- frac :: a -> a -> Importance
- frac a b = realToFrac a / realToFrac b
- valueCrit :: Maybe a -> a -> a -> Importance
- valueCrit (Just tMax') tCrit' v
- | tMax' > v = linearMatch tMax' tCrit' v
- | otherwise = 1
- valueCrit Nothing tCrit' v = logarithmicMatch tCrit' v
- valueOtherwise :: a -> Maybe a -> a -> Importance
- valueOtherwise tNorm' (Just tMin') v
- | tMin' < v = linearMatch tNorm' tMin' v
- | otherwise = 0
- valueOtherwise tNorm' Nothing v = 1 - logarithmicMatch v tNorm'
-
-
-removePango :: BlockText -> T.Text
-removePango (BlockText b) = foldr ((<>) . removePangoFromSegment) "" b
- where
- removePangoFromSegment :: BlockTextSegment -> T.Text
- removePangoFromSegment BlockTextSegment { active=_active, importance=_importance, text } = text
- removePangoFromSegment (PangoTextSegment text) =
- case parsePango text of
- Left _ -> text
- Right parsed -> removeFormatting parsed
-
-printedLength :: BlockText -> Int64
-printedLength (BlockText b) = foldr ((+) . printedLength') 0 b
- where
- printedLength' :: BlockTextSegment -> Int64
- printedLength' BlockTextSegment { text, active=_, importance=_ } = T.length text
- printedLength' (PangoTextSegment _) = 0
-
-mkText :: Bool -> Importance -> T.Text -> BlockText
-mkText active importance text = BlockText [BlockTextSegment { text = pangoFriendly text, active, importance }]
- where
- pangoFriendly :: T.Text -> T.Text
- pangoFriendly = T.replace "<" "<" . T.replace ">" ">" . T.replace "&" "&"
-
-activeImportantText :: Importance -> T.Text -> BlockText
-activeImportantText = mkText True
-
-importantText :: Importance -> T.Text -> BlockText
-importantText = mkText False
-
-activeText :: T.Text -> BlockText
-activeText = mkText True normalImportant
-
-normalText :: T.Text -> BlockText
-normalText = mkText False normalImportant
-
-pangoText :: T.Text -> BlockText
-pangoText pango = BlockText [PangoTextSegment pango]
-
-surroundWith :: (T.Text -> BlockText) -> T.Text -> T.Text -> BlockText -> BlockText
-surroundWith format left right middle = format left <> middle <> format right
-
-data Color = ColorRGB Float Float Float | ColorRGBA Float Float Float Float
-colorToHex :: Color -> T.Text
-colorToHex = colorToHex'
- where
- colorToHex' :: Color -> T.Text
- colorToHex' (ColorRGB r g b) = "#" <> (toDualHex . floor) (r * 255) <> (toDualHex . floor) (g * 255) <> (toDualHex . floor) (b * 255)
- colorToHex' (ColorRGBA r g b a) = "#" <> (toDualHex . floor) (r * 255) <> (toDualHex . floor) (g * 255) <> (toDualHex . floor) (b * 255) <> (toDualHex . floor) (a * 255)
- toHex :: Int -> T.Text
- toHex 0 = "0"
- toHex 1 = "1"
- toHex 2 = "2"
- toHex 3 = "3"
- toHex 4 = "4"
- toHex 5 = "5"
- toHex 6 = "6"
- toHex 7 = "7"
- toHex 8 = "8"
- toHex 9 = "9"
- toHex 10 = "A"
- toHex 11 = "B"
- toHex 12 = "C"
- toHex 13 = "D"
- toHex 14 = "E"
- toHex 15 = "F"
- toHex x = toHex $ mod x 16
- toDualHex :: Int -> T.Text
- toDualHex x = toHex (div x 16) <> toHex x
diff --git a/src/QBar/Blocks/Battery.hs b/src/QBar/Blocks/Battery.hs
index 7c0ece8..9bef2f6 100644
--- a/src/QBar/Blocks/Battery.hs
+++ b/src/QBar/Blocks/Battery.hs
@@ -6,7 +6,6 @@ module QBar.Blocks.Battery where
import QBar.Core hiding (name)
import QBar.BlockOutput
-import QBar.BlockText
import Pipes
import qualified Data.Text.Lazy as T
diff --git a/src/QBar/Blocks/Date.hs b/src/QBar/Blocks/Date.hs
index bfbff2a..6546484 100644
--- a/src/QBar/Blocks/Date.hs
+++ b/src/QBar/Blocks/Date.hs
@@ -1,7 +1,6 @@
module QBar.Blocks.Date where
import QBar.BlockOutput
-import QBar.BlockText
import QBar.Core
import QBar.Time
diff --git a/src/QBar/ControlSocket.hs b/src/QBar/ControlSocket.hs
index 90e3a23..195a8f1 100644
--- a/src/QBar/ControlSocket.hs
+++ b/src/QBar/ControlSocket.hs
@@ -8,7 +8,6 @@ import QBar.Core
-- TODO: remove dependency?
import QBar.Filter
import QBar.BlockOutput
-import QBar.BlockText
import Control.Exception (handle)
import Control.Monad (forever, void, when)
diff --git a/src/QBar/Core.hs b/src/QBar/Core.hs
index c9ec6d7..5bef93a 100644
--- a/src/QBar/Core.hs
+++ b/src/QBar/Core.hs
@@ -4,7 +4,6 @@
module QBar.Core where
import QBar.BlockOutput
-import QBar.BlockText
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
diff --git a/src/QBar/Filter.hs b/src/QBar/Filter.hs
index eef1b64..125d9af 100644
--- a/src/QBar/Filter.hs
+++ b/src/QBar/Filter.hs
@@ -3,7 +3,6 @@
module QBar.Filter where
import QBar.BlockOutput
-import QBar.BlockText
import Control.Monad.State.Lazy (State, evalState, get, put)
import Data.Aeson.TH
diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs
index 24729d1..e17590a 100644
--- a/src/QBar/Server.hs
+++ b/src/QBar/Server.hs
@@ -3,7 +3,6 @@
module QBar.Server where
import QBar.BlockOutput
-import QBar.BlockText
import QBar.Core
import QBar.Cli
import QBar.ControlSocket
diff --git a/src/QBar/Themes.hs b/src/QBar/Themes.hs
index cf62584..63531f9 100644
--- a/src/QBar/Themes.hs
+++ b/src/QBar/Themes.hs
@@ -1,7 +1,6 @@
module QBar.Themes where
import QBar.BlockOutput
-import QBar.BlockText
import qualified Data.Text.Lazy as T
--
GitLab