Alternative Semigroup/Monoid instances via newtype wrappers

AutoDeriving.hs

#!/usr/bin/env stack
-- stack --resolver=lts-12.6 script

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}

module TC (main) where

import Data.Data (Data)
import Data.Foldable (Foldable(..))
import Data.List (nub)

class Basics a c where
    empty :: c a
    singleton :: a -> c a
    fromList :: [a] -> c a

class AddL a c where
    (|<) :: Eq a => a -> c a -> c a

class AddR a c where
    (>|) :: Eq a => c a -> a -> c a

class AppendL a c where
    (|<>) :: Eq a => c a -> c a -> c a

class AppendR a c where
    (<>|) :: Eq a => c a -> c a -> c a

data OSet a = OSet [a] deriving (Data, Eq, Foldable, Ord)

instance Show a => Show (OSet a) where
    show (OSet as) = show as

instance Basics a OSet where
    empty = OSet []
    singleton a = OSet [a]
    fromList as = OSet as

instance Eq a => AddL a OSet where
    a |< (OSet bs) = OSet (nub $ a : bs)

instance Eq a => AddR a OSet where
    (OSet as) >| b = undefined

instance Eq a => AppendL a OSet where
    (OSet as) |<> (OSet bs) = OSet (nub $ as ++ bs)

instance Eq a => AppendR a OSet where
    (OSet as) <>| (OSet bs) = undefined

newtype OSetL a = OSetL (OSet a) deriving (Data, Eq, Foldable, Ord)
deriving instance Basics a OSetL
deriving instance Eq a => AddL a OSetL
deriving instance Eq a => AppendL a OSetL
instance Show a => Show (OSetL a) where show (OSetL o) = show o
instance Eq a => Semigroup (OSetL a) where (<>) = (|<>)
instance Eq a => Monoid (OSetL a) where mempty = empty

main :: IO ()
main = do
    osetTest
    osetLTest

osetTest :: IO ()
osetTest = do
    let s0 :: OSet Int
        s0 = empty
        s1 = 5 |< s0
        s2 = 3 |< s1
        s3 = 2 |< s2
        s4 = 5 |< s3
    print s4
    print $ toList s4

osetLTest :: IO ()
osetLTest = do
    let s0 :: OSetL Int
        s0 = empty
        s1 = 5 |< s0
        s2 = 3 |< s1
        s3 = 2 |< s2
        s4 = 5 |< s3
        s5 = s4 <> fromList [1..10] <> mempty
    print s5
    print $ toList s5

Deriving.hs

#!/usr/bin/env stack
-- stack --resolver=lts-12.6 script

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}

module Deriving (main) where

import Data.Data (Data)
import Data.Foldable (Foldable(..))
import Data.List (nub)

data NubSet a = NubSet [a]

class ConsL c a where consL :: Eq a => a -> c a -> c a

instance ConsL NubSet a where
    a `consL` (NubSet bs) = NubSet $ nub (a : bs)

newtype NubSetL a = NubSetL (NubSet a)

{-
Deriving.hs:26:1: error:
    • Can't make a derived instance of ‘ConsL NubSetL a’:
        The last argument of the instance must be a data or newtype application
    • In the stand-alone deriving instance for ‘Eq a => ConsL NubSetL a’
   |
26 | deriving instance Eq a => ConsL NubSetL a
   | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-}
deriving instance Eq a => ConsL NubSetL a

main :: IO ()
main = putStrLn "Done"

LICENSE

The MIT License (MIT)

Copyright (c) 2019 Richard Cook

Permission is hereby granted, free of charge, to any person obtaining a copy of
this software and associated documentation files (the "Software"), to deal in
the Software without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Software, and to permit persons to whom the Software is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

OSetDemo.hs

#!/usr/bin/env stack
-- stack --resolver=lts-12.6 script

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE StandaloneDeriving #-}

module Main (main) where

import Data.List (nub)

data OSet a = OSet [a]

deriving instance Show a => Show (OSet a)

empty :: OSet a
empty = OSet []

singleton :: a -> OSet a
singleton a = OSet [a]

insert :: Eq a => a -> OSet a -> OSet a
insert b (OSet as)= OSet (nub (as ++ [b]))

leftPreservingAppend :: Eq a => OSet a -> OSet a -> OSet a
leftPreservingAppend (OSet as) (OSet bs) = OSet (nub (as ++ bs))

rightPreservingAppend :: Eq a => OSet a -> OSet a -> OSet a
rightPreservingAppend (OSet as) (OSet bs) = OSet (reverse $ nub (reverse bs ++ reverse as))

toList :: OSet a -> [a]
toList (OSet as) = as

newtype LeftPreservingOSet a = LeftPreservingOSet { getOSet :: OSet a }

instance Eq a => Semigroup (LeftPreservingOSet a) where
    (LeftPreservingOSet as) <> (LeftPreservingOSet bs) = LeftPreservingOSet (leftPreservingAppend as bs)

instance Eq a => Monoid (LeftPreservingOSet a) where
    mempty = LeftPreservingOSet empty

deriving instance Show a => Show (LeftPreservingOSet a)

newtype RightPreservingOSet a = RightPreservingOSet { getOSet :: OSet a }

instance Eq a => Semigroup (RightPreservingOSet a) where
    (RightPreservingOSet as) <> (RightPreservingOSet bs) = RightPreservingOSet (rightPreservingAppend as bs)

instance Eq a => Monoid (RightPreservingOSet a) where
    mempty = RightPreservingOSet empty

deriving instance Show a => Show (RightPreservingOSet a)

main :: IO ()
main = do
    print $ (getOSet :: LeftPreservingOSet Int -> OSet Int)
                            (LeftPreservingOSet (singleton 5)
                            <> LeftPreservingOSet (singleton 3)
                            <> LeftPreservingOSet (singleton 2)
                            <> LeftPreservingOSet (singleton 5))
    print $ (getOSet :: RightPreservingOSet Int -> OSet Int)
                            (RightPreservingOSet (singleton 5)
                            <> RightPreservingOSet (singleton 3)
                            <> RightPreservingOSet (singleton 2)
                            <> RightPreservingOSet (singleton 5))

TC.hs

#!/usr/bin/env stack
-- stack --resolver=lts-12.6 script

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module TC (main) where

import Data.Data (Data)
import Data.Foldable (Foldable(..))
import Data.List (nub)

class Basics c a where
    empty :: c a
    singleton :: a -> c a
    fromList :: [a] -> c a

class AddL c a where
    (|<) :: Eq a => a -> c a -> c a

class AddR c a where
    (>|) :: Eq a => c a -> a -> c a

class AppendL c a where
    (|<>) :: Eq a => c a -> c a -> c a

class AppendR c a where
    (<>|) :: Eq a => c a -> c a -> c a

data OSet a = OSet [a] deriving (Data, Eq, Foldable, Ord)

instance Show a => Show (OSet a) where
    show (OSet as) = show as

instance Basics OSet a where
    empty = OSet []
    singleton a = OSet [a]
    fromList as = OSet as

instance Eq a => AddL OSet a where
    a |< (OSet bs) = OSet (nub $ a : bs)

instance Eq a => AddR OSet a where
    (OSet as) >| b = undefined

instance Eq a => AppendL OSet a where
    (OSet as) |<> (OSet bs) = OSet (nub $ as ++ bs)

instance Eq a => AppendR OSet a where
    (OSet as) <>| (OSet bs) = undefined

newtype OSetL a = OSetL (OSet a) deriving (Data, Eq, Foldable, Ord)

instance Show a => Show (OSetL a) where
    show (OSetL o) = show o

instance Basics OSetL a where
    empty = OSetL empty
    singleton = OSetL . singleton
    fromList = OSetL . fromList

instance Eq a => AddL OSetL a where
    a |< (OSetL o) = OSetL (a |< o)

instance Eq a => AppendL OSetL a where
    (OSetL ao) |<> (OSetL bo) = OSetL (ao |<> bo)

instance Eq a => Semigroup (OSetL a) where
    (<>) = (|<>)

instance Eq a => Monoid (OSetL a) where
    mempty = empty

main :: IO ()
main = do
    osetTest
    osetLTest

osetTest :: IO ()
osetTest = do
    let s0 :: OSet Int
        s0 = empty
        s1 = 5 |< s0
        s2 = 3 |< s1
        s3 = 2 |< s2
        s4 = 5 |< s3
    print s4
    print $ toList s4

osetLTest :: IO ()
osetLTest = do
    let s0 :: OSetL Int
        s0 = empty
        s1 = 5 |< s0
        s2 = 3 |< s1
        s3 = 2 |< s2
        s4 = 5 |< s3
        s5 = s4 <> fromList [1..10] <> mempty
    print s5
    print $ toList s5