Is_this_a_typeclass.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

{- cabal:
build-depends: 
      base >= 4.14
    , ghc-prim
-}

module Main where

import Prelude hiding (Semigroup(..), Monoid(..))
import GHC.Classes (IP(..))
import GHC.TypeLits

data Semigroup a = Semigroup
  { (<>-) :: a -> a -> a
  }

data Monoid a = Monoid
  { mempty'  :: a
  , mappend' :: a -> a -> a
  }

type family ShowType a :: Symbol where
  ShowType String = "String"

monoid :: forall ip_name a.
  ( ip_name ~ (AppendSymbol "semigroup_" (ShowType a))
  , IP ip_name (Semigroup a) 
  )
  => a 
  -> Monoid a
monoid mempty = Monoid 
  { mempty' = mempty
  , mappend' = (<>-) (ip @ip_name)
  }

(<>) :: forall ip_name a.
  ( ip_name ~ (AppendSymbol "semigroup_" (ShowType a))
  , IP ip_name (Semigroup a) 
  ) => a -> a -> a
(<>) = (<>-) (ip @ip_name)

mappend :: forall ip_name a.
  ( ip_name ~ (AppendSymbol "monoid_" (ShowType a))
  , IP ip_name (Monoid a) 
  ) => a -> a -> a
mappend = mappend' (ip @ip_name)

mempty :: forall ip_name a.
  ( ip_name ~ (AppendSymbol "monoid_" (ShowType a))
  , IP ip_name (Monoid a) 
  ) => a
mempty = mempty' (ip @ip_name)

instance IP "semigroup_String" (Semigroup String) where
  ip = Semigroup (++)

instance IP "monoid_String" (Monoid String) where
  ip = monoid ""

main :: IO ()
main = do
  putStrLn $ "Hello " <> "world"