MuV

muv.purs

type MuV t = Mu (VariantF t)

inv :: forall a b f s. RowCons s (FProxy f) a b 
        => IsSymbol s 
        => Functor f 
        => SProxy s 
        -> f (Mu (VariantF b)) 
        -> Mu (VariantF b)
inv x = In <<< (inj x)

type Lit r = (lit :: FProxy (Const Int) | r)
type Add r = (add :: FProxy (Join Tuple) | r)
type Mul r = (mul :: FProxy (Join Tuple) | r)

lit :: forall r. Int -> MuV (Lit r)
lit v = inv (SProxy :: SProxy "lit") (Const v)

add :: forall r. MuV (Add + r) -> MuV (Add + r) -> MuV (Add + r)
add x y = inv (SProxy :: SProxy "add") (Join $ Tuple x y)

mul :: forall r. MuV (Mul + r) -> MuV (Mul + r) -> MuV (Mul + r)
mul x y = inv (SProxy :: SProxy "mul") (Join $ Tuple x y)

exprAlg :: forall a. Semiring a ⇒ VariantF ( add ∷ FProxy (Join Tuple), lit ∷ FProxy (Const a), mul ∷ FProxy (Join Tuple) ) a -> a
exprAlg = match
    {
        lit: case _ of
            Const x -> x
        ,
        add: \x -> case unwrap x of
            Tuple x y -> x + y
        ,    
        mul: \x -> case unwrap x of
            Tuple x y -> x * y        
    }

showAlg :: VariantF ( add ∷ FProxy (Join Tuple), lit ∷ FProxy (Const Int), mul ∷ FProxy (Join Tuple) ) String -> String
showAlg = match
    {
        lit: \x -> case x of
            Const x -> "Val " <> show x
        ,
        add: \x -> case unwrap x of
            Tuple x y -> "(" <> x <> " + " <> y <> ")"
        ,
        mul: \x -> case unwrap x of
            Tuple x y -> "(" <> x <> " * " <> y <> ")"
    }

showExpr :: forall t.
  Recursive t
    (VariantF
       ( add :: FProxy (Join Tuple)
       , lit :: FProxy (Const Int)
       , mul :: FProxy (Join Tuple)
       )
    )
   => t -> String
showExpr = cata showAlg

exprRes :: Int
exprRes = cata exprAlg (mul (add (lit 10) (lit 20)) (add (lit 10) (lit 20)))

showRes :: String
showRes = showExpr (mul (add (lit 10) (lit 20)) (add (lit 10) (lit 20)))