diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Blessings.hs | 143 | ||||
| -rw-r--r-- | src/Blessings/ByteString.hs | 20 | ||||
| -rw-r--r-- | src/Blessings/ByteString/Lazy.hs | 20 | ||||
| -rw-r--r-- | src/Blessings/Internal.hs | 16 | ||||
| -rw-r--r-- | src/Blessings/String.hs | 21 | ||||
| -rw-r--r-- | src/Blessings/String/WCWidth.hs | 66 | ||||
| -rw-r--r-- | src/Blessings/Text.hs | 21 | ||||
| -rw-r--r-- | src/Blessings/Text/WCWidth.hs | 66 |
8 files changed, 96 insertions, 277 deletions
diff --git a/src/Blessings.hs b/src/Blessings.hs index a62546e..3ee32a2 100644 --- a/src/Blessings.hs +++ b/src/Blessings.hs @@ -1,21 +1,29 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} -module Blessings - ( module Export - , module Blessings - ) where +module Blessings where -import Blessings.Internal as Export (Blessable) -import qualified Blessings.Internal as Bless import Control.Applicative import Data.Ix (inRange) import Data.List (genericDrop) +import Data.List qualified as L +import Data.MonoTraversable (Element, GrowingAppend, MonoFoldable(..), MonoFunctor(..), MonoPointed(..), MonoTraversable(..)) +import Data.Sequences (Index, IsSequence, SemiSequence(..)) +import Data.Sequences qualified as S import Data.String import Data.Tuple.Extra (both, first, second) import Data.Word (Word8) +type Blessable t = + ( Eq t + , IsString t + , Monoid t + , IsSequence t + , Index t ~ Int + ) + type Ps = Word8 type Pm = [Ps] @@ -62,6 +70,58 @@ instance IsString a => IsString (Blessings a) where fromString = Plain . fromString +type instance Element (Blessings a) = a + +instance MonoFoldable (Blessings a) + +instance MonoPointed (Blessings a) where + opoint = Plain + +instance MonoFunctor (Blessings a) where + omap = fmap + +instance MonoTraversable (Blessings a) where + otraverse f = \case + Plain a -> Plain <$> f a + SGR pm t -> SGR pm <$> otraverse f t + Append t1 t2 -> Append <$> otraverse f t1 <*> otraverse f t2 + Empty -> pure Empty + +instance GrowingAppend (Blessings a) + +instance Blessable a => SemiSequence (Blessings a) where + type Index (Blessings a) = Int + + cons a b + | a == mempty = b + cons a (Plain b) = Plain (a <> b) + cons a Empty = Plain a + cons a b = Append (Plain a) b + + snoc b a + | a == mempty = b + snoc (Plain b) a = Plain (b <> a) + snoc Empty a = Plain a + snoc b a = Append b (Plain a) + + intersperse sep xs = + case otoList xs of + [] -> Empty + (y:ys) -> + foldl' + (\acc z -> snoc (snoc acc sep) z) + (Plain y) + ys + + find p = ofoldr (\x acc -> if p x then Just x else acc) Nothing + + sortBy cmp xs = + foldr cons Empty (L.sortBy cmp (otoList xs)) + + reverse xs = + foldr cons Empty (L.reverse (otoList xs)) + + class IsPm a where toPm :: a -> Pm fromPm :: Pm -> Maybe a @@ -216,7 +276,7 @@ emptyRenderState :: RenderState emptyRenderState = [(ECMA48FColor 39, ECMA48BColor 49, NoBlink, NoBold, NoUnderline)] -render :: (Blessable a) => RenderState -> Blessings a -> a -> a +render :: Blessable a => RenderState -> Blessings a -> a -> a render _ (Plain s) y = s <> y @@ -249,10 +309,10 @@ render r (Append t1 t2) y = render _ Empty y = y -renderSGR :: (Blessable a) => Pm -> a +renderSGR :: Blessable a => Pm -> a renderSGR [] = mempty renderSGR pm = - ("\ESC["<>) . (<>"m") . Bless.intercalate ";" . map Bless.fromWord8 $ pm + "\ESC[" <> mconcat (L.intersperse ";" (map (fromString . show) pm)) <> "m" stripSGR :: Blessings a -> Blessings a @@ -372,46 +432,43 @@ normalizePm pm0 = [] -> xs -pp :: (Blessable a) => Blessings a -> a -pp t = render emptyRenderState t "" +pp :: Blessable a => Blessings a -> a +pp t = render emptyRenderState t mempty -instance (Eq a, Blessable a) => Blessable (Blessings a) where - length (Plain x) = Bless.length x - length (SGR _ t) = Bless.length t - length (Append t1 t2) = Bless.length t1 + Bless.length t2 - length Empty = 0 +instance Blessable a => IsSequence (Blessings a) where + lengthIndex = ofoldl' (\acc w -> acc + S.lengthIndex w) 0 drop n = \case Append t1 t2 -> let - n1 = Bless.length (Bless.take n t1) + n1 = S.lengthIndex (S.take n t1) n2 = n - n1 - t1' = Bless.drop n1 t1 - t2' = Bless.drop n2 t2 + t1' = S.drop n1 t1 + t2' = S.drop n2 t2 in normalizeHead $ Append t1' t2' Plain s -> - normalizeHead $ Plain (Bless.drop n s) + normalizeHead $ Plain (S.drop n s) SGR pm t -> - normalizeHead $ SGR pm (Bless.drop n t) + normalizeHead $ SGR pm (S.drop n t) Empty -> Empty take n = \case Append t1 t2 -> let - t1' = Bless.take n t1 - n' = n - Bless.length t1' + t1' = S.take n t1 + n' = n - S.lengthIndex t1' in normalizeHead $ if n' > 0 - then t1' <> Bless.take n' t2 + then t1' <> S.take n' t2 else t1' Plain s -> - normalizeHead $ Plain (Bless.take n s) + normalizeHead $ Plain (S.take n s) SGR pm t -> - normalizeHead $ SGR pm (Bless.take n t) + normalizeHead $ SGR pm (S.take n t) Empty -> Empty @@ -419,47 +476,39 @@ instance (Eq a, Blessable a) => Blessable (Blessings a) where Append t1 t2 -> both normalizeHead $ let - nt1 = Bless.length t1 + nt1 = S.lengthIndex t1 in if n <= nt1 - then second (<>t2) $ Bless.splitAt n t1 - else first (t1<>) $ Bless.splitAt (n - nt1) t2 + then second (<>t2) $ S.splitAt n t1 + else first (t1<>) $ S.splitAt (n - nt1) t2 Plain s -> - both (normalizeHead . Plain) $ Bless.splitAt n s + both (normalizeHead . Plain) $ S.splitAt n s SGR pm t -> - both (normalizeHead . SGR pm) $ Bless.splitAt n t + both (normalizeHead . SGR pm) $ S.splitAt n t Empty -> (Empty, Empty) break p = \case Append t1 t2 -> both normalizeHead $ - case Bless.break p t1 of + case S.break p t1 of (t1l, t1r) - | t1r == mempty -> first (t1l<>) $ Bless.break p t2 + | t1r == mempty -> first (t1l<>) $ S.break p t2 | otherwise -> (t1l, t1r <> t2) - Plain s -> - both (normalizeHead . Plain) $ Bless.break p s + Plain s + | p s -> (Empty, Plain s) + | otherwise -> (Plain s, Empty) SGR pm t -> - both (normalizeHead . SGR pm) $ Bless.break p t + both (normalizeHead . SGR pm) $ S.break p t Empty -> (Empty, Empty) - intercalate i = \case - [] -> mempty - [t] -> t - (t:ts) -> normalize $ t <> i <> Bless.intercalate i ts - - fromWord8 = Plain . Bless.fromWord8 - - show = Plain . Bless.show - -chunksOf :: (Eq a, Blessable a) => Int -> a -> [a] +chunksOf :: Blessable a => Int -> a -> [a] chunksOf k = rec where rec t = - case Bless.splitAt k t of + case S.splitAt k t of (tl, tr) | tl == mempty -> [] | otherwise -> tl : rec tr diff --git a/src/Blessings/ByteString.hs b/src/Blessings/ByteString.hs deleted file mode 100644 index 4fe66cc..0000000 --- a/src/Blessings/ByteString.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Blessings.ByteString - ( module Blessings - ) where - -import Blessings -import Blessings.Internal -import qualified Data.ByteString.Char8 as B - - -instance Blessable B.ByteString where - length = B.length - drop = B.drop - take = B.take - splitAt = B.splitAt - break = B.break - intercalate = B.intercalate - fromWord8 = B.pack . Prelude.show - show = B.pack . Prelude.show diff --git a/src/Blessings/ByteString/Lazy.hs b/src/Blessings/ByteString/Lazy.hs deleted file mode 100644 index 23394b5..0000000 --- a/src/Blessings/ByteString/Lazy.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Blessings.ByteString.Lazy - ( module Blessings - ) where - -import Blessings -import Blessings.Internal -import qualified Data.ByteString.Lazy.Char8 as L - - -instance Blessable L.ByteString where - length = fromIntegral . L.length - drop = L.drop . fromIntegral - take = L.take . fromIntegral - splitAt = L.splitAt . fromIntegral - break = L.break - intercalate = L.intercalate - fromWord8 = L.pack . Prelude.show - show = L.pack . Prelude.show diff --git a/src/Blessings/Internal.hs b/src/Blessings/Internal.hs deleted file mode 100644 index 62d8fd4..0000000 --- a/src/Blessings/Internal.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE ConstrainedClassMethods #-} -module Blessings.Internal where - -import Data.String (IsString) -import Data.Word (Word8) - - -class (IsString a, Monoid a) => Blessable a where - length :: a -> Int - drop :: Int -> a -> a - take :: Int -> a -> a - splitAt :: Int -> a -> (a, a) - break :: (Char -> Bool) -> a -> (a, a) - intercalate :: a -> [a] -> a - fromWord8 :: Word8 -> a - show :: Show x => x -> a diff --git a/src/Blessings/String.hs b/src/Blessings/String.hs deleted file mode 100644 index 8dc6bcf..0000000 --- a/src/Blessings/String.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Blessings.String - ( module Blessings - ) where - -import Blessings -import Blessings.Internal -import qualified Data.List as L - - -instance Blessable String where - length = L.length - drop = L.drop - take = L.take - splitAt = L.splitAt - break = L.break - intercalate = L.intercalate - fromWord8 = Prelude.show - show = Prelude.show diff --git a/src/Blessings/String/WCWidth.hs b/src/Blessings/String/WCWidth.hs deleted file mode 100644 index 16ab853..0000000 --- a/src/Blessings/String/WCWidth.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE PatternGuards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Blessings.String.WCWidth - ( module Blessings - ) where - -import Blessings -import Blessings.Internal -import Data.Char.WCWidth qualified as WCWidth -import Data.List qualified as List - - -instance Blessable String where - length = length' - drop = drop' - take = take' - splitAt = splitAt' - break = List.break - intercalate = List.intercalate - fromWord8 = Prelude.show - show = Prelude.show - - -length' :: String -> Int -length' = foldr ((+) . wcwidth') 0 - -drop' :: Int -> String -> String -drop' k t = - if k <= 0 - then t - else - case t of - c : t' -> - drop' (k - wcwidth' c) t' - [] -> mempty - -take' :: Int -> String -> String -take' k0 = - rec k0 - where - rec k t = - if | (c : t') <- t, nc <- wcwidth' c, nc <= k -> - c : rec (k - nc) t' - - | otherwise -> - [] - -splitAt' :: Int -> String -> (String, String) -splitAt' k0 = - rec k0 [] - where - rec k a t = - if | (c : t') <- t, nc <- wcwidth' c, nc <= k -> - rec (k - nc) (c : a) t' - - | otherwise -> - (reverse a, t) - --- TODO this breaks when WCWidth.wcwidth returns -1, which happens for --- non-printable characters like '\n'. --- Following wcwidth' isn't entirely correct because WCWidth.wcwidth '\0' == 0 -wcwidth' :: Char -> Int -wcwidth' = max 1 . WCWidth.wcwidth diff --git a/src/Blessings/Text.hs b/src/Blessings/Text.hs deleted file mode 100644 index 04572dd..0000000 --- a/src/Blessings/Text.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Blessings.Text - ( module Blessings - ) where - -import Blessings -import Blessings.Internal -import Data.Text (Text) -import qualified Data.Text as T - - -instance Blessable Text where - length = T.length - drop = T.drop - take = T.take - splitAt = T.splitAt - break = T.break - intercalate = T.intercalate - fromWord8 = T.pack . Prelude.show - show = T.pack . Prelude.show diff --git a/src/Blessings/Text/WCWidth.hs b/src/Blessings/Text/WCWidth.hs deleted file mode 100644 index 84e7cfa..0000000 --- a/src/Blessings/Text/WCWidth.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE PatternGuards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Blessings.Text.WCWidth - ( module Blessings - ) where - -import Blessings -import Blessings.Internal -import Data.Char.WCWidth qualified as WCWidth -import Data.Text (Text) -import Data.Text qualified as Text - - -instance Blessable Text where - length = length' - drop = drop' - take = take' - splitAt = splitAt' - break = Text.break - intercalate = Text.intercalate - fromWord8 = Text.pack . Prelude.show - show = Text.pack . Prelude.show - - -length' :: Text -> Int -length' = Text.foldr ((+) . wcwidth') 0 - -drop' :: Int -> Text -> Text -drop' k t = - if k <= 0 - then t - else - case Text.uncons t of - Just (c, t') -> - drop' (k - wcwidth' c) t' - Nothing -> mempty - -take' :: Int -> Text -> Text -take' k0 = - Text.pack . rec k0 - where - rec k t = - if | Just (c, t') <- Text.uncons t, nc <- wcwidth' c, nc <= k -> - c : rec (k - nc) t' - - | otherwise -> - [] - -splitAt' :: Int -> Text -> (Text, Text) -splitAt' k0 = - rec k0 mempty - where - rec k a t = - if | Just (c, t') <- Text.uncons t, nc <- wcwidth' c, nc <= k -> - rec (k - nc) (c : a) t' - - | otherwise -> - (Text.pack $ reverse a, t) - --- TODO this breaks when WCWidth.wcwidth returns -1, which happens for --- non-printable characters like '\n'. --- Following wcwidth' isn't entirely correct because WCWidth.wcwidth '\0' == 0 -wcwidth' :: Char -> Int -wcwidth' = max 1 . WCWidth.wcwidth |