diff options
Diffstat (limited to 'src/Blessings.hs')
| -rw-r--r-- | src/Blessings.hs | 143 |
1 files changed, 96 insertions, 47 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 |