open-union AST

OpenUnionAst.hs

{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}

import           Data.OpenUnion          (Union, liftUnion)
import           Data.Singletons.Prelude (type (++))

-- * Union's Little helpers

type family a \/ b where
  Union xs \/ Union ys = Union (xs ++ ys)

-- * AST

data Add = Add deriving (Show)
data Mul = Mul deriving (Show)
type ArithOp = [Add, Mul]

data And = And deriving (Show)
type LogicalOp = '[And]

data Less = Less deriving (Show)
data Equal = Equal deriving (Show)
type CompareOp = [Less, Equal]

type AnyOp = Union (ArithOp ++ LogicalOp ++ CompareOp)

type Name = String

data Variable = Variable String deriving (Show)
data LiteralInteger = LiteralInteger Integer deriving (Show)
data Binary = Binary AnyOp Expr Expr deriving (Show)
type Expr = Union [Variable, LiteralInteger, Binary]

data Declare = Declare Name (Maybe Expr)
  deriving (Show)

data EmptyStmt = EmptyStmt deriving (Show)
data CallExpr = CallExpr Expr deriving (Show)
data Assign = Assign Name Expr deriving (Show)
type SideStmt = Union [EmptyStmt, CallExpr, Assign]

data Block = Block deriving (Show)

data While = While Expr Block deriving (Show)
data For = For (Union '[Declare] \/ SideStmt) SideStmt Expr Block
  deriving (Show)
type Stmt = Union [Declare, While, For] \/ SideStmt

example :: Stmt
example =
  liftUnion $ For
    (liftUnion $ Declare "i" $ Just $ liftUnion $ LiteralInteger 0)
    (liftUnion $ Assign "i" $
      liftUnion $ Binary
        (liftUnion Add)
        (liftUnion $ Variable "i")
        (liftUnion $ LiteralInteger 1))
    (liftUnion $ Binary
      (liftUnion Less)
      (liftUnion $ Variable "i")
      (liftUnion $ LiteralInteger 10))
    Block

-- $> example