Blessings: don't compare during drop and take

This fixes divergence caused when calling drop or take on Append with
infinite left hand side.

1 files changed, 17 insertions, 8 deletions

diff --git a/src/Blessings.hs b/src/Blessings.hs
index 344fac2..3c00f38 100644
--- a/src/Blessings.hs
+++ b/src/Blessings.hs
@@ -272,10 +272,16 @@ instance Blessable a => Blessable (Blessings a) where
 
   drop n = \case
       Append t1 t2 ->
-          case compare n (Bless.length t1) of
-              LT -> Bless.drop n t1 <> t2
-              EQ -> t2
-              GT -> Bless.drop (n - Bless.length t1) t2
+          let
+            n1 = Bless.length (Bless.take n t1)
+            n2 = n - n1
+            t1' = Bless.drop n1 t1
+            t2' = Bless.drop n2 t2
+            isEmpty = (==0) . Bless.length . Bless.take 1
+          in
+            if n1 /= n || isEmpty t1'
+              then t2'
+              else Append t1' t2'
       Plain s ->
           Plain (Bless.drop n s)
       SGR pm t ->
@@ -285,10 +291,13 @@ instance Blessable a => Blessable (Blessings a) where
 
   take n = \case
       Append t1 t2 ->
-          case compare n (Bless.length t1) of
-              LT -> Bless.take n t1
-              EQ -> t1
-              GT -> t1 <> Bless.take (n - Bless.length t1) t2
+          let
+            t1' = Bless.take n t1
+            n' = n - Bless.length t1'
+          in
+            if n' > 0
+              then t1' <> Bless.take n' t2
+              else t1'
       Plain s ->
           Plain (Bless.take n s)
       SGR pm t ->