Use Haskell definition of sconcat, using NonEmpty. Fixes #378.

Frege · Sep 4, 2019 · cf794ec · cf794ec
1 parent d52a081
commit cf794ec
Show file tree

Hide file tree

Showing 5 changed files with 36 additions and 23 deletions.
diff --git a/frege/data/Foldable.fr b/frege/data/Foldable.fr
@@ -5,6 +5,7 @@ import frege.Prelude hiding (fold, foldr, foldr1, foldl, foldl1,
    mapM_, forM_, sequence_, msum, concat, concatMap, and, or,
    any, all, sum, product, maximum, minimum, elem, notElem)
 
+import Data.NonEmpty (NonEmpty)
 import frege.data.wrapper.Identity
 import frege.data.wrapper.Dual
 import frege.data.wrapper.Boolean
@@ -254,6 +255,9 @@ instance Foldable [] where
     foldr = Prelude.foldr
     foldl = Prelude.fold    -- Prelude.foldl is considered harmful
 
+instance Foldable NonEmpty where
+    foldr f x (NonEmpty h t) = Prelude.foldr f x (h:t)
+    foldl f x (NonEmpty h t) = Prelude.fold  f x (h:t)
+
 instance Foldable Identity where
     foldMap f (Identity x) = f x
-
diff --git a/frege/data/Monoid.fr b/frege/data/Monoid.fr
@@ -2,16 +2,19 @@
 
 package Data.Monoid  where
 
+import Data.NonEmpty (NonEmpty)
+
 infixr 13 `<>` mappend
 
 (<>) = mappend
 
 class Semigroup a where
   mappend :: a -> a -> a
 
-  --doesn't support empty lists, use mconcat if possible
-  sconcat :: [a] -> a
-  sconcat xs = foldr mappend (head xs) (tail xs)
+  sconcat :: NonEmpty a -> a
+  sconcat (NonEmpty a as) = go a as where
+    go b (c:cs) = b <> go c cs
+    go b [] = b
 
   --doesn't support factor of 0, use mtimes if possible
   stimes :: Int -> a -> a
@@ -35,7 +38,12 @@ class Semigroup a => Monoid a where
 instance Monoid [a] where
   mempty = []
   mappend = (++)
-
+
+instance Semigroup (NonEmpty a) where
+  mappend xs ys = xs ++ ys
+
+-- String ---------------------------------------------------------------------
+
 instance Monoid String where
     mappend = (++)
     mempty  = String.empty
@@ -85,8 +93,6 @@ instance Monoid Ordering where
   Lt `mappend` _ = Lt
   Eq `mappend` y = y
   Gt `mappend` _ = Gt  
-
-
 
 instance Monoid (a->a) where
     f `mappend` g = f . g

diff --git a/frege/data/NonEmpty.fr b/frege/data/NonEmpty.fr
@@ -3,9 +3,6 @@ package frege.data.NonEmpty where
 
 import frege.Prelude hiding (reverse, scanl, scanl1, scanr, scanr1, iterate, cycle, zip, unzip)
 
-import Data.Foldable (Foldable)
-import Data.Traversable (Traversable)
-import Data.Monoid
 import frege.data.List () 
 
 {--
@@ -35,22 +32,12 @@ instance ListSemigroup NonEmpty where
 
 instance ListSource NonEmpty where
   toList (NonEmpty h t) = h : t
-
-instance Foldable NonEmpty where
-  foldr f x (NonEmpty h t) = Prelude.foldr f x (h:t)
-  foldl f x (NonEmpty h t) = Prelude.fold  f x (h:t)
-
-instance Traversable NonEmpty where
-  traverse f list = liftA2 nonEmpty (f list.neHead) (traverse f list.neTail)
 
 instance Show a => Show (NonEmpty a) where
-  show (NonEmpty h t) = fold1 ["|",show h, showT t, "|"] where
+  show (NonEmpty h t) = concat ["|",show h, showT t, "|"] where
      showT [] = ""
      showT (x:xs) = "," ++ show x ++ showT xs 
 
-instance Semigroup (NonEmpty a) where
-  mappend xs ys = xs ++ ys
-
 --- Constructs a non-empty list with the given head and tail.
 nonEmpty :: a -> [a] -> NonEmpty a
 nonEmpty x xs = NonEmpty x xs

diff --git a/frege/data/Traversable.fr b/frege/data/Traversable.fr
@@ -3,7 +3,8 @@ package Data.Traversable where
 
 import frege.Prelude hiding (mapM, forM, for, sequence, foldr)
 import Data.Foldable (Foldable)
-import Data.Monoid 
+import Data.Monoid
+import Data.NonEmpty (NonEmpty, nonEmpty)
 import frege.data.wrapper.Identity
 import frege.data.wrapper.Const
 
@@ -64,6 +65,9 @@ instance Traversable [] where
       where cons_f x ys = fmap (:) (f x) <*> ys
     mapM = Prelude.mapM
 
+instance Traversable NonEmpty where
+    traverse f list = liftA2 nonEmpty (f list.neHead) (traverse f list.neTail)
+
 instance Traversable Identity where
     traverse f (Identity x) = Identity `fmap` f x
 
@@ -134,4 +138,4 @@ fmapDefault f ts = Identity.run $ traverse (Identity . f) ts
     in a `Foldable` instance.
 -}
 foldMapDefault :: (Traversable t, Monoid m) => (a -> m) -> t a -> m
-foldMapDefault f ts = Const.get $ traverse (Const . f) ts
+foldMapDefault f ts = Const.get $ traverse (Const . f) ts
diff --git a/tests/qc/MonoidTest.fr b/tests/qc/MonoidTest.fr
@@ -0,0 +1,12 @@
+module tests.qc.MonoidTest where
+
+import Data.NonEmpty (nonEmpty)
+import Data.Monoid (Monoid, sconcat, mconcat, <>)
+import Test.QuickCheck
+
+checkSemigroupConcat :: (Monoid a, Eq a) => a -> [a] -> Bool
+checkSemigroupConcat head tail =
+  head <> mconcat tail == sconcat (nonEmpty head tail)
+
+p_semigroupConcatStrings =
+  property (checkSemigroupConcat :: String -> [String] -> Bool)