MicroHs-0.12.6.1: tests/Via.hs

module Via where
import Numeric
import Data.Kind
import Data.Semigroup
import Data.Coerce

newtype B = B Bool
  deriving newtype Eq

newtype N = N Int
  deriving newtype (Eq, Ord)
  deriving stock (Show)
  deriving newtype Num

data Id a = Id a
  deriving stock Eq

newtype BI = BI (Id Int)
  deriving newtype Eq

newtype Id2 a = Id2 (Id a)
  deriving newtype Eq

newtype Id3 a = Id3 a
  deriving newtype Eq

------

newtype Hex a = Hex a

instance (Integral a, Show a) => Show (Hex a) where
  show (Hex a) = "0x" ++ showHex a ""

newtype Unicode = U Int
  deriving Show via (Hex Int)

euroSign :: Unicode
euroSign = U 0x20ac

-------

class SPretty a where
  sPpr :: a -> String
  default sPpr :: Show a => a -> String
  sPpr = show

data S = S String
  deriving stock Show
  deriving anyclass SPretty

-------

newtype P a = P (Maybe a)
  deriving stock Show
  deriving newtype (Eq, Functor)

-------

class (Monoid w, Monad m) => MonadAccum w m | m -> w where
  add :: w -> m ()

newtype MaybeT m a = MaybeT (m (Maybe a))

instance Functor (MaybeT m) where fmap = undefined
instance Applicative (MaybeT m) where pure = undefined; (<*>) = undefined
instance Monad (MaybeT m) where (>>=) = undefined

newtype LiftingAccum (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) (a :: Type)
  = LiftingAccum (t m a)
  deriving
    (Functor, Applicative, Monad)
    via (t m)

instance (Monad (t m), MonadAccum w m) => MonadAccum w (LiftingAccum t m) where
  add x = undefined

deriving via
  (LiftingAccum MaybeT m)
  instance
    (MonadAccum w m) =>
    MonadAccum w (MaybeT m)

{-
hdr = (forall (w::Type) (m::(Type -> Type)) . ((MonadAccum w m) => (MonadAccum w (MaybeT m))))
newty = (MaybeT m)
narg=1,
tycon=MaybeT
iks=[(m::_a78),(a::_a79)]
c=Constr [] [] MaybeT (Left [(False,(m (Maybe a)))])
acls=(MonadAccum w)
mvis=Just (LiftingAccum MaybeT m)
oldty'=(m (Maybe a)))


newtypeDer: instance (forall (w::Type) (m::(Type -> Type)) . ((MonadAccum w m) => (MonadAccum w (MaybeT m)))) where
  add :: w -> (MaybeT m ()
  add = coerce @((w -> (LiftingAccum MaybeT m ()))) add


-}

{-
instance MonadAccum w m => MonadAccum w (MaybeT m) where
  add = coerce
          @(w -> LiftingAccum MaybeT m ())
          @(w -> MaybeT m ())
          (add @w @(LiftingAccum MaybeT m))
-}

-------

newtype M a = M [a]
  deriving stock Show
  deriving newtype Semigroup

-------

class C a where
  mc :: a -> a

instance C Int where
  mc = succ

newtype I = I Int
  deriving stock Show
  deriving newtype C

-------

class CC a b where
  mm :: b -> a -> b

instance CC a Int where
  mm x _ = x + 1

newtype II = II Int
  deriving stock Show
  deriving newtype (CC a)

-------

main :: IO ()
main = do
  print $ B True == B True

  let x = N 1
      y = N 2
  print $ x == x
  print $ x == y
  print $ x < y
  print $ x + y

  print $ BI (Id 1) == BI (Id 1)

  print $ Id2 (Id False) == Id2 (Id False)

  print $ Id3 (1 :: Int) == Id3 1

  print euroSign

  print $ sPpr $ S "hello"

  print $ fmap (*5) (P (Just 2))

  print $ stimes 3 (M "ab")

  print $ mc (I 1)

  print $ mm (II 99) ()

  putStrLn "done"