gistfile1.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types #-}
data Exp = Var String | Lit Int | Add Exp Exp
         | Mul Exp Exp | Neg Exp
         | Do Stm
  deriving Show

data Stm = Decl Typ String | Assign String Exp | Return Exp | Block [Stm]
  deriving Show

data Typ = T_int | T_float
  deriving Show


data MyLangAlg f = MyLangAlg
  { aExp :: Exp -> f Exp
  , aStm :: Stm -> f Stm
  , aTyp :: Typ -> f Typ
--  , aList :: forall a. Compos MyLangAlg a => [a] -> f [a]
  }

composStm :: (forall a. a -> f a)
          -> (forall a b. f (a -> b) -> f a -> f b)
          -> MyLangAlg f
          -> Stm -> f Stm
composStm pure ap alg stm = case stm of
  Decl t v   -> pure Decl `ap` aTyp alg t `ap` pure v
  Assign v e -> pure Assign `ap` pure v `ap` aExp alg e
  Block stms -> pure Block `ap` mapF (aStm alg) stms
  Return e   -> pure Return `ap` aExp alg e
 where
   mapF f [] = pure []
   mapF f (x:xs) = pure (:) `ap` f x `ap` mapF f xs
{-# INLINE composStm #-}

-- composList :: Compos alg a =>
--               (forall a. a -> f a)
--            -> (forall a b. f (a -> b) -> f a -> f b)
--            -> alg f
--            -> [a] -> f [a]
-- composList pure ap alg lst = go lst
--   where go []     = pure []
--         go (x:xs) = pure (:) `ap` f x `ap` go xs
-- {-# INLINE composList #-}

composExp :: (forall a. a -> f a)
          -> (forall a b. f (a -> b) -> f a -> f b)
          -> MyLangAlg f
          -> Exp -> f Exp
composExp pure ap alg exp = case exp of
  Add e1 e2 -> pure Add `ap` aExp alg e1 `ap` aExp alg e2
  Mul e1 e2 -> pure Mul `ap` aExp alg e1 `ap` aExp alg e2
  Neg e     -> pure Neg `ap` aExp alg e
  Do stm    -> pure Do `ap` aStm alg stm
  _         -> pure exp
{-# INLINE composExp #-}

composTyp :: (forall a. a -> f a)
          -> (forall a b. f (a -> b) -> f a -> f b)
          -> MyLangAlg f
          -> Typ -> f Typ
composTyp pure _ap _alg typ = pure typ
{-# INLINE composTyp #-}

class Compos alg t where
  compos :: (forall a. a -> f a)
         -> (forall a b. f (a -> b) -> f a -> f b)
         -> alg f
         -> t
         -> f t
  run :: alg f -> t -> f t
  ext :: (t -> f t) -> alg f -> alg f

instance Compos MyLangAlg Stm where
    compos = composStm; run = aStm; ext f a = a { aStm = f }
instance Compos MyLangAlg Exp where
    compos = composExp; run = aExp; ext f a = a { aExp = f }
-- instance Compos MyLangAlg a => Compos MyLangAlg [a] where
--     compos pure ap alg = composList pure ap (compos pure ap alg)
--     run = aList
--     ext (f :: forall b. Compos MyLangAlg b => [b] -> f [b]) alg = alg { aList = f }
instance Compos MyLangAlg Typ where
    compos = composTyp; run = aTyp; ext f a = a { aTyp = f }

myLangCompos :: (forall a. a -> f a)
             -> (forall a b. f (a -> b) -> f a -> f b)
             -> (MyLangAlg f -> MyLangAlg f) -> MyLangAlg f
myLangCompos pure ap mod = self
  where
    self0 = MyLangAlg { aExp = composExp pure ap self
                      , aStm = composStm pure ap self
                      , aTyp = composTyp pure ap self
                      }
    self = mod self0

main = print ()