content: module Blaze.Pil.Construct where
  
  import Blaze.Prelude hiding (Symbol, const, sym)
  import qualified Blaze.Types.Pil as Pil
  import Blaze.Types.Function (Function(Function))
  import Blaze.Types.Pil
    ( AddressableStatement(Stmt),
      ExprOp,
      Expression (Expression),
      Size,
      PilVar (PilVar),
      Statement,
      Symbol,
    )
  
  
  class ExprConstructor attrs expr | expr -> attrs where
    mkExpr :: attrs -> Pil.ExprOp expr -> expr
  
  instance ExprConstructor (Size Expression) Expression where
    mkExpr = Expression
  
  class GetExprSize a where
    getExprSize :: a -> Size Expression
  
  instance GetExprSize Expression where
    getExprSize = view #size
  
  instance GetExprSize (Size Expression) where
    getExprSize = identity
  
  getPilVarSize :: GetExprSize a => a -> Size PilVar
  getPilVarSize = fromByteBased . getExprSize
  
  pilVar_ :: Size PilVar -> Maybe Pil.Ctx -> Symbol -> PilVar
  pilVar_ = PilVar
  
  pilVar' :: Size PilVar -> Pil.Ctx -> Symbol -> PilVar
  pilVar' sz = pilVar_ sz . Just
  
  pilVar :: Size PilVar -> Symbol -> PilVar
  pilVar sz = pilVar_ sz Nothing
  
  binOp
    :: ExprConstructor attrs expr
    => (a -> ExprOp expr)
    -> (expr -> expr -> a)
    -> expr
    -> expr
    -> attrs
    -> expr
  binOp f g x y size = mkExpr size $ f (g x y)
  
  unOp
    :: ExprConstructor attrs expr
    => (a -> ExprOp expr)
    -> (expr -> a)
    -> expr
    -> attrs
    -> expr
  unOp f g x size = mkExpr size $ f (g x)
  
  ---- Expressions
  const :: ExprConstructor attrs expr => Int64 -> attrs -> expr
  const x size = mkExpr size (Pil.CONST (Pil.ConstOp x))
  
  fconst :: ExprConstructor attrs expr => Double -> attrs -> expr
  fconst x size = mkExpr size (Pil.CONST_FLOAT (Pil.ConstFloatOp x))
  
  unit :: ExprConstructor attrs expr => attrs -> expr
  unit attrs = mkExpr attrs Pil.UNIT
  
  constPtr :: ExprConstructor attrs expr => Word64 -> attrs -> expr
  constPtr addr size = mkExpr size (Pil.CONST_PTR (Pil.ConstPtrOp (fromIntegral addr :: Int64)))
  
  externPtr :: ExprConstructor attrs expr => Address -> ByteOffset -> Maybe Symbol -> attrs -> expr
  externPtr addr off sym size = mkExpr size (Pil.ExternPtr (Pil.ExternPtrOp addr off sym))
  
  constStr :: ExprConstructor attrs expr => Text -> attrs -> expr
  constStr str size = mkExpr size (Pil.ConstStr (Pil.ConstStrOp str))
  
  constBool :: ExprConstructor attrs expr => Bool -> attrs -> expr
  constBool b size = mkExpr size (Pil.CONST_BOOL (Pil.ConstBoolOp b))
  
  var' :: ExprConstructor attrs expr => PilVar -> attrs -> expr
  var' pv size = mkExpr size (Pil.VAR $ Pil.VarOp pv)
  
  var :: (GetExprSize attrs, ExprConstructor attrs expr) => Symbol -> attrs -> expr
  var sym attrs = mkExpr attrs (Pil.VAR $ Pil.VarOp $ pilVar_ (getPilVarSize attrs) Nothing sym)
  
  add :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  add = binOp Pil.ADD Pil.AddOp
  
  addWillCarry :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  addWillCarry = binOp Pil.ADD_WILL_CARRY Pil.AddWillCarryOp
  
  addWillOverflow :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  addWillOverflow = binOp Pil.ADD_WILL_OVERFLOW Pil.AddWillOverflowOp
  
  sub :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  sub = binOp Pil.SUB Pil.SubOp
  
  subWillOverflow :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  subWillOverflow = binOp Pil.SUB_WILL_OVERFLOW Pil.SubWillOverflowOp
  
  mul :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  mul = binOp Pil.MUL Pil.MulOp
  
  cmpE :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  cmpE = binOp Pil.CMP_E Pil.CmpEOp
  
  cmpNE :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  cmpNE = binOp Pil.CMP_NE Pil.CmpNeOp
  
  cmpSge :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  cmpSge = binOp Pil.CMP_SGE Pil.CmpSgeOp
  
  cmpSgt :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  cmpSgt = binOp Pil.CMP_SGT Pil.CmpSgtOp
  
  cmpSle :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  cmpSle = binOp Pil.CMP_SLE Pil.CmpSleOp
  
  cmpSlt :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  cmpSlt = binOp Pil.CMP_SLT Pil.CmpSltOp
  
  cmpUge :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  cmpUge = binOp Pil.CMP_UGE Pil.CmpUgeOp
  
  cmpUgt :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  cmpUgt = binOp Pil.CMP_UGT Pil.CmpUgtOp
  
  cmpUle :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  cmpUle = binOp Pil.CMP_ULE Pil.CmpUleOp
  
  cmpUlt :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  cmpUlt = binOp Pil.CMP_ULT Pil.CmpUltOp
  
  -- float cmp
  fcmpE :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  fcmpE = binOp Pil.FCMP_E Pil.FcmpEOp
  
  fcmpNE :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  fcmpNE = binOp Pil.FCMP_NE Pil.FcmpNeOp
  
  fcmpGe :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  fcmpGe = binOp Pil.FCMP_GE Pil.FcmpGeOp
  
  fcmpGt :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  fcmpGt = binOp Pil.FCMP_GT Pil.FcmpGtOp
  
  fcmpLe :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  fcmpLe = binOp Pil.FCMP_LE Pil.FcmpLeOp
  
  fcmpLt :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  fcmpLt = binOp Pil.FCMP_LT Pil.FcmpLtOp
  
  sx :: ExprConstructor attrs expr => expr -> attrs -> expr
  sx = unOp Pil.SX Pil.SxOp
  
  zx :: ExprConstructor attrs expr => expr -> attrs -> expr
  zx = unOp Pil.ZX Pil.ZxOp
  
  strcmp :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  strcmp = binOp Pil.StrCmp Pil.StrCmpOp
  
  or :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  or = binOp Pil.OR Pil.OrOp
  
  and :: ExprConstructor attrs expr => expr -> expr -> attrs -> expr
  and = binOp Pil.AND Pil.AndOp
  
  not :: ExprConstructor attrs expr => expr -> attrs -> expr
  not = unOp Pil.NOT Pil.NotOp
  
  -- TODO: Change to just Load. PIL is being updated to drop versioned memory.
  load :: ExprConstructor attrs expr => expr -> attrs -> expr
  load addr size = mkExpr size (Pil.LOAD (Pil.LoadOp addr))
  
  varField
    :: (ExprConstructor attrs expr, GetExprSize attrs)
    => Pil.Symbol
    -> ByteOffset
    -> attrs
    -> expr
  varField sym offset attrs =
    mkExpr attrs (Pil.VAR_FIELD $ Pil.VarFieldOp (pilVar (getPilVarSize attrs) sym) offset)
  
  fieldAddr :: ExprConstructor attrs expr => expr -> ByteOffset -> attrs -> expr
  fieldAddr base offset size =
    mkExpr size . Pil.FIELD_ADDR $ Pil.FieldAddrOp base offset
  
  arrayAddr :: ExprConstructor attrs expr => expr -> expr -> Word64 -> attrs -> expr
  arrayAddr base index stride size =
    mkExpr size . Pil.ARRAY_ADDR $ Pil.ArrayAddrOp base index stride
  
  stackLocalAddr :: ExprConstructor attrs expr => expr -> ByteOffset -> attrs -> expr
  stackLocalAddr base offset size =
    mkExpr size . Pil.FIELD_ADDR $ Pil.FieldAddrOp base offset
  
  -- | Makes a statement with 0x0 address
  mkStmt_ :: Statement expr -> AddressableStatement expr
  mkStmt_ = Stmt 0
  
  def :: GetExprSize expr => Symbol -> expr -> AddressableStatement expr
  def sym expr = def' (pilVar_ (getPilVarSize expr) Nothing sym) expr
  
  -- | Constructs a 'Pil.Def' that assigns 'val' to 'pv'
  def' :: PilVar -> expr -> AddressableStatement expr
  def' pv val = mkStmt_ $ Pil.Def (Pil.DefOp pv val)
  
  -- TODO: This helper assumes the only output of the call operation
  --       is the variable being defined.
  defCall'
    :: forall attrs expr. ExprConstructor attrs expr
    => PilVar
    -> Pil.CallDest expr
    -> [expr]
    -> attrs
    -> AddressableStatement expr
  defCall' pv dest args size = def' pv callExpr
    where
      mname :: Maybe Text
      mname = case dest of
        Pil.CallFunc (Function _ nm _ _) -> Just nm
        _ -> Nothing
      callExpr :: expr
      callExpr = mkExpr size $ Pil.CALL $ Pil.CallOp dest mname args
  
  -- TODO: This helper assumes the only output of the call operation
  --       is the variable being defined.
  defCall
    :: forall attrs expr. (GetExprSize attrs, ExprConstructor attrs expr)
    => Symbol
    -> Pil.CallDest expr
    -> [expr]
    -> attrs
    -> AddressableStatement expr
  defCall sym cdest args attrs = defCall' (pilVar (getPilVarSize attrs) sym) cdest args attrs
  
  defPhi :: Size PilVar -> Symbol -> [Symbol] -> AddressableStatement expr
  defPhi sz sym = mkStmt_ . Pil.DefPhi . Pil.DefPhiOp (pilVar sz sym) . fmap (pilVar sz)
  
  defPhi' :: PilVar -> [PilVar] -> AddressableStatement expr
  defPhi' dest = mkStmt_ . Pil.DefPhi . Pil.DefPhiOp dest
  
  store :: expr -> expr -> AddressableStatement expr
  store addr val = mkStmt_ $ Pil.Store (Pil.StoreOp addr val)
  
  constraint :: expr -> AddressableStatement expr
  constraint e = mkStmt_ $ Pil.Constraint (Pil.ConstraintOp e)
  
  branchCond :: expr -> AddressableStatement expr
  branchCond e = mkStmt_ $ Pil.BranchCond (Pil.BranchCondOp e)
  
  ret :: expr -> AddressableStatement expr
  ret = mkStmt_ . Pil.Ret . Pil.RetOp
  
  enterContext :: Pil.Ctx -> [expr] -> AddressableStatement expr
  enterContext ctx args = mkStmt_ . Pil.EnterContext $ Pil.EnterContextOp ctx args
  
  exitContext :: Pil.Ctx -> Pil.Ctx -> AddressableStatement expr
  exitContext leavingCtx returningToCtx
    = mkStmt_ . Pil.ExitContext $ Pil.ExitContextOp leavingCtx returningToCtx
  
  nop :: AddressableStatement expr
  nop = mkStmt_ Pil.Nop
  
  callStmt :: Pil.CallDest expr -> [expr] -> AddressableStatement expr
  callStmt dest args = mkStmt_ . Pil.Call $ Pil.CallOp dest mname args
    where
      mname :: Maybe Text
      mname = case dest of
        Pil.CallFunc (Function _ nm _ _) -> Just nm
        _ -> Nothing
  