{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module UnitAnalysisValue where

import           Abstract
import           Data(joinList1'',Instruction)
import           GenericInterpreter hiding (Exc)
import qualified GenericInterpreter as Generic

import           Control.Arrow
import           Control.Arrow.Except
import           Control.Arrow.Fail as Fail
import           Control.Arrow.Order

import           Control.Arrow.Transformer.Value

import           Language.Wasm.Structure (BitSize(..), IBinOp(..), IRelOp(..), ValueType(..), IUnOp(..),
                                          FUnOp(..), FBinOp(..), FRelOp(..))
import qualified Language.Wasm.Interpreter as Wasm

import           Data.Hashable
import           Data.HashSet as HashSet
import           Data.Order

import           Prettyprinter

import           Text.Printf

newtype Exc v = Exc (HashSet (Generic.Exc v)) deriving (Eq, Show, Hashable, PreOrd, Complete)

instance (Show v) => Pretty (Exc v) where pretty = viaShow
instance (Show n) => Pretty (Instruction n) where pretty = viaShow


instance (ArrowExcept (Exc Value) c, ArrowChoice c) => IsException (Exc Value) Value (ValueT Value c) where
    type JoinExc y (ValueT Value c) = ArrowComplete y (ValueT Value c)
    exception = arr $ Exc . HashSet.singleton
    handleException f = proc (Exc excs,x) -> do
                            joinList1'' f -< (HashSet.toList excs,x)

newtype Value = Value (BaseValue () () () ()) deriving (Eq, Show, Hashable, PreOrd, Complete, Pretty)

valueI32, valueI64, valueF32, valueF64 :: Value
valueI32 = Value $ VI32 ()
valueI64 = Value $ VI64 ()
valueF32 = Value $ VF32 ()
valueF64 = Value $ VF64 ()

alpha :: Wasm.Value -> Value
alpha v = Value $ case v of
  Wasm.VI32 _ -> VI32 ()
  Wasm.VI64 _ -> VI64 ()
  Wasm.VF32 _ -> VF32 ()
  Wasm.VF64 _ -> VF64 ()

unitValue :: ValueType -> Value
unitValue I32 = Value $ VI32 ()
unitValue I64 = Value $ VI64 ()
unitValue F32 = Value $ VF32 ()
unitValue F64 = Value $ VF64 ()

instance (ArrowChoice c, ArrowFail Err c, Fail.Join Value c) => IsVal Value (ValueT Value c) where
    type JoinVal y (ValueT Value c) = ArrowComplete y (ValueT Value c)

    i32const = proc _ -> returnA -< valueI32
    i64const = proc _ -> returnA -< valueI64
    f32const = proc _ -> returnA -< valueF32
    f64const = proc _ -> returnA -< valueF64

    iUnOp = proc (bs,op,Value v0) -> case (bs,op,v0) of
        (BS32, IClz,    VI32 _) -> returnA -< valueI32
        (BS32, ICtz,    VI32 _) -> returnA -< valueI32
        (BS32, IPopcnt, VI32 _) -> returnA -< valueI32
        (BS64, IClz,    VI64 _) -> returnA -< valueI64
        (BS64, ICtz,    VI64 _) -> returnA -< valueI64
        (BS64, IPopcnt, VI64 _) -> returnA -< valueI64
        _ -> returnA -< error "iUnOp: cannot apply operator to arguments"
    iBinOp = proc (bs,op,Value v1,Value v2) -> case (bs,op,v1,v2) of
        (BS32, IAdd,  VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, ISub,  VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, IMul,  VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, IDivU, VI32 _, VI32 _) -> (returnA -< valueI32) <⊔> (trap -< "iBinOp: division by zero.")
        (BS32, IDivS, VI32 _, VI32 _) -> (returnA -< valueI32) <⊔> (trap -< "iBinOp: division by zero.")
        (BS32, IRemU, VI32 _, VI32 _) -> (returnA -< valueI32) <⊔> (trap -< "iBinOp: division by zero.")
        (BS32, IRemS, VI32 _, VI32 _) -> (returnA -< valueI32) <⊔> (trap -< "iBinOp: division by zero.")
        (BS32, IAnd,  VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, IOr,   VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, IXor,  VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, IShl,  VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, IShrU, VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, IShrS, VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, IRotl, VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, IRotr, VI32 _, VI32 _) -> returnA -< valueI32

        (BS64, IAdd,  VI64 _, VI64 _) -> returnA -< valueI64
        (BS64, ISub,  VI64 _, VI64 _) -> returnA -< valueI64
        (BS64, IMul,  VI64 _, VI64 _) -> returnA -< valueI64
        (BS64, IDivU, VI64 _, VI64 _) -> (returnA -< valueI64) <⊔> (trap -< "iBinOp: division by zero.")
        (BS64, IDivS, VI64 _, VI64 _) -> (returnA -< valueI64) <⊔> (trap -< "iBinOp: division by zero.")
        (BS64, IRemU, VI64 _, VI64 _) -> (returnA -< valueI64) <⊔> (trap -< "iBinOp: division by zero.")
        (BS64, IRemS, VI64 _, VI64 _) -> (returnA -< valueI64) <⊔> (trap -< "iBinOp: division by zero.")
        (BS64, IAnd,  VI64 _, VI64 _) -> returnA -< valueI64
        (BS64, IOr,   VI64 _, VI64 _) -> returnA -< valueI64
        (BS64, IXor,  VI64 _, VI64 _) -> returnA -< valueI64
        (BS64, IShl,  VI64 _, VI64 _) -> returnA -< valueI64
        (BS64, IShrU, VI64 _, VI64 _) -> returnA -< valueI64
        (BS64, IShrS, VI64 _, VI64 _) -> returnA -< valueI64
        (BS64, IRotl, VI64 _, VI64 _) -> returnA -< valueI64
        (BS64, IRotr, VI64 _, VI64 _) -> returnA -< valueI64
        _ -> returnA -< error "iBinOp: cannot apply binary operator to given arguments."
    iRelOp = proc (bs,op,Value v1, Value v2) -> case (bs,op,v1,v2) of
        (BS32, IEq,  VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, INe,  VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, ILtU, VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, ILtS, VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, IGtU, VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, IGtS, VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, ILeU, VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, ILeS, VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, IGeU, VI32 _, VI32 _) -> returnA -< valueI32
        (BS32, IGeS, VI32 _, VI32 _) -> returnA -< valueI32

        (BS64, IEq,  VI64 _, VI64 _) -> returnA -< valueI32
        (BS64, INe,  VI64 _, VI64 _) -> returnA -< valueI32
        (BS64, ILtU, VI64 _, VI64 _) -> returnA -< valueI32
        (BS64, ILtS, VI64 _, VI64 _) -> returnA -< valueI32
        (BS64, IGtU, VI64 _, VI64 _) -> returnA -< valueI32
        (BS64, IGtS, VI64 _, VI64 _) -> returnA -< valueI32
        (BS64, ILeU, VI64 _, VI64 _) -> returnA -< valueI32
        (BS64, ILeS, VI64 _, VI64 _) -> returnA -< valueI32
        (BS64, IGeU, VI64 _, VI64 _) -> returnA -< valueI32
        (BS64, IGeS, VI64 _, VI64 _) -> returnA -< valueI32
        _ -> returnA -< error "iRelOp: cannot apply binary operator to given arguments."

    i32eqz = proc (Value v) -> case v of
        (VI32 _) -> returnA -< valueI32
        _ -> returnA -< error "i32eqz: cannot apply operator to given argument."
    i64eqz = proc (Value v) -> case v of
        (VI64 _) -> returnA -< valueI32
        _ -> returnA -< error "i64eqz: cannot apply operator to given argument."

    i32ifNeqz f g = proc (v, x) -> case v of
        Value (VI32 _) -> (g -< x) <⊔> (f -< x)
        _                   -> returnA -< error "i32ifNeqz: condition of unexpected type"

    ifHasType f g = proc (Value v,t,x) -> do
      case (v,t) of
        (VI32 _, I32) -> f -< x
        (VI64 _, I64) -> f -< x
        (VF32 _, F32) -> f -< x
        (VF64 _, F64) -> f -< x
        _             -> g -< x

    fUnOp = proc (bs,op,Value v) -> case (bs,op,v) of
        (BS32, FAbs,     VF32 _) -> returnA -< valueF32
        (BS32, FNeg,     VF32 _) -> returnA -< valueF32
        (BS32, FCeil,    VF32 _) -> returnA -< valueF32
        (BS32, FFloor,   VF32 _) -> returnA -< valueF32
        (BS32, FTrunc,   VF32 _) -> returnA -< valueF32
        (BS32, FNearest, VF32 _) -> returnA -< valueF32
        (BS32, FSqrt,    VF32 _) -> returnA -< valueF32
        (BS64, FAbs,     VF64 _) -> returnA -< valueF64
        (BS64, FNeg,     VF64 _) -> returnA -< valueF64
        (BS64, FCeil,    VF64 _) -> returnA -< valueF64
        (BS64, FFloor,   VF64 _) -> returnA -< valueF64
        (BS64, FTrunc,   VF64 _) -> returnA -< valueF64
        (BS64, FNearest, VF64 _) -> returnA -< valueF64
        (BS64, FSqrt,    VF64 _) -> returnA -< valueF64
        _ -> returnA -< error "fUnOp: cannot apply operator to arguements"
    fBinOp = proc (bs,op,Value v1,Value v2) -> case (bs,op,v1,v2) of
        (BS32, FAdd,      VF32 _, VF32 _) -> returnA -< valueF32
        (BS32, FSub,      VF32 _, VF32 _) -> returnA -< valueF32
        (BS32, FMul,      VF32 _, VF32 _) -> returnA -< valueF32
        (BS32, FDiv,      VF32 _, VF32 _) -> returnA -< valueF32
        (BS32, FMin,      VF32 _, VF32 _) -> returnA -< valueF32
        (BS32, FMax,      VF32 _, VF32 _) -> returnA -< valueF32
        (BS32, FCopySign, VF32 _, VF32 _) -> returnA -< valueF32
        (BS64, FAdd,      VF64 _, VF64 _) -> returnA -< valueF64
        (BS64, FSub,      VF64 _, VF64 _) -> returnA -< valueF64
        (BS64, FMul,      VF64 _, VF64 _) -> returnA -< valueF64
        (BS64, FDiv,      VF64 _, VF64 _) -> returnA -< valueF64
        (BS64, FMin,      VF64 _, VF64 _) -> returnA -< valueF64
        (BS64, FMax,      VF64 _, VF64 _) -> returnA -< valueF64
        (BS64, FCopySign, VF64 _, VF64 _) -> returnA -< valueF64
        _ -> returnA -< error "fBinOp: cannot apply binary operator to given arguments."
    fRelOp = proc (bs,op,Value v1,Value v2) -> case (bs,op,v1,v2) of
        (BS32, FEq, VF32 _, VF32 _) -> returnA -< valueI32
        (BS32, FNe, VF32 _, VF32 _) -> returnA -< valueI32
        (BS32, FLt, VF32 _, VF32 _) -> returnA -< valueI32
        (BS32, FGt, VF32 _, VF32 _) -> returnA -< valueI32
        (BS32, FLe, VF32 _, VF32 _) -> returnA -< valueI32
        (BS32, FGe, VF32 _, VF32 _) -> returnA -< valueI32
        (BS64, FEq, VF64 _, VF64 _) -> returnA -< valueI32
        (BS64, FNe, VF64 _, VF64 _) -> returnA -< valueI32
        (BS64, FLt, VF64 _, VF64 _) -> returnA -< valueI32
        (BS64, FGt, VF64 _, VF64 _) -> returnA -< valueI32
        (BS64, FLe, VF64 _, VF64 _) -> returnA -< valueI32
        (BS64, FGe, VF64 _, VF64 _) -> returnA -< valueI32
        _ -> returnA -< error "fRelOp: cannot apply binary operator to given arguments."
    i32WrapI64 = proc (Value v) -> case v of
        (VI64 _) -> returnA -< valueI32
        _ -> returnA -< error "i32WrapI64: cannot apply operator to given argument."
    iTruncFU = proc (bs1,bs2,x@(Value v)) -> do
      let errorTrunc = printf "iTruncFU: truncation operator from %s to %s failed on %s." (show bs1) (show bs2) (show x)
      case (bs1,bs2,v) of
        (BS32, BS32, VF32 _) -> (returnA -< valueI32) <⊔> (trap -< errorTrunc)
        (BS32, BS64, VF64 _) -> (returnA -< valueI32) <⊔> (trap -< errorTrunc)
        (BS64, BS32, VF32 _) -> (returnA -< valueI64) <⊔> (trap -< errorTrunc)
        (BS64, BS64, VF64 _) -> (returnA -< valueI64) <⊔> (trap -< errorTrunc)
        _ -> returnA -< error "iTruncFU: cannot apply operator to given argument."
    iTruncFS = proc (bs1,bs2,x@(Value v)) -> do
      let errorTrunc = printf "iTruncFS: truncation operator from %s to %s failed on %s." (show bs1) (show bs2) (show x)
      case (bs1,bs2,v) of
        (BS32, BS32, VF32 _) -> (returnA -< valueI32) <⊔> (trap -< errorTrunc)
        (BS32, BS64, VF64 _) -> (returnA -< valueI32) <⊔> (trap -< errorTrunc)
        (BS64, BS32, VF32 _) -> (returnA -< valueI64) <⊔> (trap -< errorTrunc)
        (BS64, BS64, VF64 _) -> (returnA -< valueI64) <⊔> (trap -< errorTrunc)
        _ -> returnA -< error "iTruncFS: cannot apply operator to given argument."
    i64ExtendSI32 = proc (Value v) -> case v of
        (VI32 _) -> returnA -< valueI64
        _ -> returnA -< error "i64ExtendSI32: cannot apply operator to given argument."
    i64ExtendUI32 = proc (Value v) -> case v of
        (VI32 _) -> returnA -< valueI64
        _ -> returnA -< error "i64ExtendUI32: cannot apply operator to given argument."
    fConvertIU = proc (bs1,bs2,Value v) -> case (bs1,bs2,v) of
        (BS32, BS32, VI32 _) -> returnA -< valueF32
        (BS32, BS64, VI64 _) -> returnA -< valueF32
        (BS64, BS32, VI32 _) -> returnA -< valueF64
        (BS64, BS64, VI64 _) -> returnA -< valueF64
        _ -> returnA -< error "fConvertIU: cannot apply operator to given argument."
    fConvertIS = proc (bs1,bs2,Value v) -> case (bs1,bs2,v) of
        (BS32, BS32, VI32 _) -> returnA -< valueF32
        (BS32, BS64, VI64 _) -> returnA -< valueF32
        (BS64, BS32, VI32 _) -> returnA -< valueF64
        (BS64, BS64, VI64 _) -> returnA -< valueF64
        _ -> returnA -< error "fConvertIS: cannot apply operator to given argument."
    f32DemoteF64 = proc (Value v) -> case v of
        (VF64 _) -> returnA -< valueF32
        _ -> returnA -< error "f32DemoteF64: cannot apply operator to given argument."
    f64PromoteF32 = proc (Value v) -> case v of
        (VF32 _) -> returnA -< valueF64
        _ -> returnA -< error "f64PromoteF32: cannot apply operator to given argument."
    iReinterpretF = proc (bs,Value v) -> case (bs,v) of
        (BS32, VF32 _) -> returnA -< valueI32
        (BS64, VF64 _) -> returnA -< valueI64
        _ -> returnA -< error "iReinterpretF: cannot apply operator to given argument."
    fReinterpretI = proc (bs,Value v) -> case (bs,v) of
        (BS32, VI32 _) -> returnA -< valueF32
        (BS64, VI64 _) -> returnA -< valueF64
        _ -> returnA -< error "fReinterpretI: cannot apply operator to given argument."
    listLookup sCont eCont = proc (Value v,xs,x) -> case v of
        (VI32 _) -> do
            (joinList1'' (proc (x,()) -> sCont -< x) -< (xs,())) <⊔> (eCont -< x)
        _ -> returnA -< error "listLookup: cannot apply operator to given arguments."

    iTruncSatFU = error "not implemented"
    iTruncSatFS = error "not implemented"

-- deriving instance ArrowComplete () c => ArrowComplete () (ValueT v c)
-- deriving instance ArrowComplete y c => ArrowComplete y (ValueT Value c)
