blamario / grampa Goto Github PK

{-# OPTIONS_GHC -ddump-splices #-}
{-# LANGUAGE TemplateHaskell #-}

import Control.Monad.Identity
import Data.Functor.Classes
import qualified Rank2
import qualified Rank2.TH

data Stm r = Unit | ExpStmt (r Int) (Exp r)
data Exp r = Nil | Cons (r Bool) (Exp r) (Stm r)

instance Show1 r => Show (Stm r) where
  show Unit = "Unit"
  show (ExpStmt r e) = "(Stmt (" ++ showsPrec1 0 r (") " ++ show e ++ ")")
instance Show1 r => Show (Exp r) where
  show Nil = "Nil"
  show (Cons r e s) =
    "(Cons (" ++ showsPrec1 0 r (") " ++ show e ++ " " ++ show s ++ ")")

$(mconcat <$> traverse
  (\derive -> mconcat <$> traverse derive [''Stm, ''Exp])
  [ Rank2.TH.deriveFunctor
  , Rank2.TH.deriveFoldable
  , Rank2.TH.deriveTraversable
  ])

expToMaybe :: Exp Identity -> Exp Maybe
expToMaybe = Rank2.fmap (Just . runIdentity)

maybeToExp :: Exp Maybe -> Maybe (Exp Identity)
maybeToExp = Rank2.traverse (fmap Identity)

myExp :: Exp Identity
myExp = Cons
  (Identity True)
  (Cons (Identity False) Nil (ExpStmt (Identity 2) Nil))
  (ExpStmt (Identity 3) (Cons (Identity True) Nil Unit))

main :: IO ()
main = do
  print myExp
  let myExp' = expToMaybe myExp
  print myExp'
  print $ maybeToExp myExp'

    mconcat
      <$>
        traverse
          (\ derive_a1fm -> mconcat <$> traverse derive_a1fm [''Stm, ''Exp])
          [Rank2.TH.deriveFunctor, Rank2.TH.deriveFoldable,
           Rank2.TH.deriveTraversable]
  ======>
    instance Rank2.Functor Stm where
      {-# INLINE (Rank2.<$>) #-}
      (Rank2.<$>) f_a32G Unit = Unit
      (Rank2.<$>) f_a32H (ExpStmt x_a32I x_a32J)
        = (ExpStmt (f_a32H x_a32I)) ((f_a32H Rank2.<$>) x_a32J)
    instance Rank2.Functor Exp where
      {-# INLINE (Rank2.<$>) #-}
      (Rank2.<$>) f_a32M Nil = Nil
      (Rank2.<$>) f_a32N (Cons x_a32O x_a32P x_a32Q)
        = ((Cons (f_a32N x_a32O)) ((f_a32N Rank2.<$>) x_a32P))
            ((f_a32N Rank2.<$>) x_a32Q)
    instance Rank2.Foldable Stm where
      {-# INLINABLE Rank2.foldMap #-}
      Rank2.foldMap f_a32T Unit = mempty
      Rank2.foldMap f_a32U (ExpStmt x_a32V x_a32W)
        = (f_a32U x_a32V <> (Rank2.foldMap f_a32U) x_a32W)
    instance Rank2.Foldable Exp where
      {-# INLINABLE Rank2.foldMap #-}
      Rank2.foldMap f_a32Z Nil = mempty
      Rank2.foldMap f_a330 (Cons x_a331 x_a332 x_a333)
        = (f_a330 x_a331
             <>
               ((Rank2.foldMap f_a330) x_a332 <> (Rank2.foldMap f_a330) x_a333))
    instance Rank2.Traversable Stm where
      {-# INLINABLE Rank2.traverse #-}
      Rank2.traverse _ _ = pure Unit
      Rank2.traverse f_a336 (ExpStmt x_a337 x_a338)
        = ((ExpStmt <$> f_a336 x_a337) <*> (Rank2.traverse f_a336) x_a338)
    instance Rank2.Traversable Exp where
      {-# INLINABLE Rank2.traverse #-}
      Rank2.traverse _ _ = pure Nil
      Rank2.traverse f_a33b (Cons x_a33c x_a33d x_a33e)
        = (((Cons <$> f_a33b x_a33c) <*> (Rank2.traverse f_a33b) x_a33d)
             <*> (Rank2.traverse f_a33b) x_a33e)