content: {-# LANGUAGE
    TemplateHaskell,
    FlexibleInstances,
    FlexibleContexts,
    TypeOperators,
    GADTs,
    KindSignatures,
    IncoherentInstances #-}
  
  -- base values
  
  module Multi.DataTypes.Comp where
  
  import Data.Comp.Derive
  import Data.Comp.Multi
  
  type ValueExpr = HTerm Value
  type ExprSig = Value :++: Op
  type Expr = HTerm ExprSig
  type SugarSig = Value :++: Op :++: Sugar
  type SugarExpr = HTerm SugarSig
  type BaseType = HTerm ValueT
  
  data ValueT e t = TInt
                  | TBool
                  | TPair (e t) (e t)
            deriving (Eq)
  
  data Value e t where
      VInt :: Int -> Value e Int
      VBool :: Bool -> Value e Bool
      VPair :: e s -> e t -> Value e (s,t)
  
  data Op e t where
      Plus :: e Int -> e Int -> Op e Int
      Mult :: e Int -> e Int -> Op e Int
      If :: e Bool -> e t -> e t -> Op e t
      Lt :: e Int -> e Int -> Op e Bool
      Eq :: e Int -> e Int -> Op e Bool
      And :: e Bool -> e Bool -> Op e Bool
      Not :: e Bool -> Op e Bool
      ProjLeft :: e (s,t) -> Op e s
      ProjRight :: e (s,t) -> Op e t
  
  data Sugar e t where
      Neg  :: e Int -> Sugar e Int
      Minus :: e Int -> e Int -> Sugar e Int
      Gt :: e Int -> e Int -> Sugar e Bool
      Or :: e Bool -> e Bool -> Sugar e Bool
      Impl :: e Bool -> e Bool -> Sugar e Bool
  
  $(derive
    [makeHFunctor, makeHFoldable, makeHTraversable, makeHEqF, smartHConstructors]
    [''ValueT, ''Value, ''Op, ''Sugar])
  
  
  showBinOp :: String -> String -> String -> String
  showBinOp op x y = "("++ x ++ op ++ y ++ ")"
  
  instance HShowF ValueT where
      hshowF' TInt = "Int"
      hshowF' TBool = "Bool"
      hshowF' (TPair (K x) (K y)) = showBinOp "," x y
  
  instance HShowF Value where
      hshowF' (VInt i) = show i
      hshowF' (VBool b) = show b
      hshowF' (VPair (K x) (K y)) = showBinOp "," x y
  
  instance HShowF Op where
      hshowF' (Plus (K x) (K y)) = showBinOp "+" x y
      hshowF' (Mult (K x) (K y)) = showBinOp "*" x y
      hshowF' (If (K b) (K x) (K y)) = "if " ++ b ++ " then " ++ x ++ " else " ++ y ++ " fi"
      hshowF' (Eq (K x) (K y)) = showBinOp "==" x y
      hshowF' (Lt (K x) (K y)) = showBinOp "<" x y
      hshowF' (And (K x) (K y)) = showBinOp "&&" x y
      hshowF' (Not (K x)) = "~" ++ x
      hshowF' (ProjLeft (K x)) = x ++ "!0"
      hshowF' (ProjRight (K x)) = x ++ "!1"