add serialization for event traces

src/Pate/Memory/MemTrace.hs

@@ -109,7 +109,7 @@ import Data.Macaw.Memory
            , MemWord, memWordToUnsigned, segmentFlags
            , Memory, emptyMemory, memWord, segoffSegment
            , segoffAddr, readWord8, readWord16be, readWord16le
-           , readWord32le, readWord32be, readWord64le, readWord64be, MemAddr, asSegmentOff
+           , readWord32le, readWord32be, readWord64le, readWord64be, MemAddr (..), asSegmentOff
            )
 import qualified Data.Macaw.Memory.Permissions as MMP
 import Data.Macaw.Symbolic.Backend (MacawEvalStmtFunc, MacawArchEvalFn(..))
@@ -154,11 +154,15 @@ import qualified Pate.ExprMappable as PEM
 import           What4.ExprHelpers ( integerToNat )
 import qualified What4.ExprHelpers as WEH
 import qualified Pate.Memory as PM
-import Data.Macaw.CFG (ArchSegmentOff, RegisterInfo, ip_reg, MemAddr (MemAddr))
+import Data.Macaw.CFG (ArchSegmentOff, RegisterInfo, ip_reg)
 import qualified Pate.SimulatorRegisters as PSr
 import Data.Data (Typeable, eqT)
 import Data.Maybe (mapMaybe)
 import qualified Data.Parameterized.TraversableF as TF
+import qualified What4.JSON as W4S
+import qualified Data.Aeson as JSON
+import What4.JSON ((.=), (.==), (.=~))
+import qualified Pate.Pointer as Ptr
 
 ------
 -- * Undefined pointers
@@ -189,6 +193,11 @@ data UndefinedPtrOps sym =
 -- Needed since SymBV is a type alias
 newtype SymBV' sym w = SymBV' { unSymBV :: SymBV sym w }
 
+instance W4S.SerializableExprs sym => W4S.W4Serializable sym (SymBV' sym w) where
+  w4Serialize (SymBV' bv) = W4S.w4SerializeF bv
+
+instance W4S.SerializableExprs sym => W4S.W4SerializableF sym (SymBV' sym)
+
 instance OrdF (SymExpr sym) => TestEquality (SymBV' sym) where
   testEquality a b = case compareF a b of
     EQF -> Just Refl
@@ -620,6 +629,10 @@ data MemOpCondition sym
   = Unconditional
   | Conditional (Pred sym)
 
+instance W4S.SerializableExprs sym => W4S.W4Serializable sym (MemOpCondition sym) where
+  w4Serialize = \case
+    Unconditional -> W4S.w4SerializeString ("unconditional" :: String)
+    Conditional p -> W4S.object ["condition" .== p]
 
 deriving instance Show (Pred sym) => Show (MemOpCondition sym)
 
@@ -628,6 +641,8 @@ data MemOpDirection =
   | Write
   deriving (Eq, Ord, Show)
 
+instance W4S.W4Serializable sym MemOpDirection where
+  w4Serialize = W4S.w4SerializeString
 
 data MemOp sym ptrW where
   MemOp ::
@@ -731,6 +746,10 @@ instance OrdF (SymExpr sym) => Ord (MemOp sym ptrW) where
 data RegOp sym arch =
   RegOp (MapF.MapF (ArchReg arch) (PSr.MacawRegEntry sym))
 
+instance (W4S.W4SerializableFC (ArchReg arch), W4S.SerializableExprs sym)
+  => W4S.W4Serializable sym (RegOp sym arch) where
+  w4Serialize (RegOp m) = W4S.object ["reg_op" .= m]
+
 instance PEM.ExprMappable sym (RegOp sym arch) where
   mapExpr sym f (RegOp m) = (RegOp . PEM.unExprMapFElems) <$> PEM.mapExpr sym f (PEM.ExprMapFElems m)
 
@@ -744,6 +763,38 @@ instance PEM.ExprMappable sym (TraceEvent sym arch) where
     RegOpEvent i rop -> RegOpEvent <$> PEM.mapExpr sym f i <*> PEM.mapExpr sym f rop
     TraceMemEvent i mop -> TraceMemEvent <$> PEM.mapExpr sym f i <*> PEM.mapExpr sym f mop
 
+instance W4S.W4Serializable sym  (MemAddr w) where
+  w4Serialize addr = do
+    base_json <- return $ JSON.toJSON (addrBase addr)
+    off_json <- return $ JSON.toJSON (show (addrOffset addr))
+    return $ JSON.object ["base" JSON..= base_json, "offset" JSON..= off_json]
+
+instance W4S.W4Serializable sym  (MemSegmentOff w) where
+  w4Serialize segOff = W4S.w4Serialize $ segoffAddr segOff
+
+instance (W4S.W4SerializableFC (ArchReg arch), W4S.SerializableExprs sym)
+  => W4S.W4Serializable sym (TraceEvent sym arch) where
+    w4Serialize = \case
+      RegOpEvent i rop -> W4S.object ["instruction" .= i, "register_op" .= rop]
+      TraceMemEvent i mop -> W4S.object ["instruction" .= i, "memory_op" .= mop]
+
+instance W4S.SerializableExprs sym => W4S.W4Serializable sym (MemEvent sym ptrW) where
+  w4Serialize = \case
+    MemOpEvent mop -> W4S.object ["mem_op" .= mop]
+    SyscallEvent i r0 -> W4S.object ["syscall" .= i, "r0" .== r0]
+    ExternalCallEvent nm bvs -> W4S.object ["external_call" .= nm, "args" .= bvs]
+
+instance W4S.SerializableExprs sym => W4S.W4Serializable sym (MemOp sym ptrW) where
+  w4Serialize (MemOp addr dir cond n val end) =
+    W4S.object
+      [ "addr" .= Ptr.fromLLVMPointer addr
+      , "direction" .= dir
+      , "condition" .= cond
+      , "size" .= n
+      , "value" .= Ptr.fromLLVMPointer val
+      , "endianness" .=~ end
+      ]
+
 data MemEvent sym ptrW where
   MemOpEvent :: MemOp sym ptrW -> MemEvent sym ptrW
   SyscallEvent :: forall sym ptrW w.

src/Pate/PatchPair.hs

@@ -68,6 +68,7 @@ module Pate.PatchPair (
   , asSingleton
   , zip
   , jsonPatchPair
+  , w4SerializePair
   ) where
 
 import           Prelude hiding (zip)
@@ -92,6 +93,8 @@ import qualified Pate.ExprMappable as PEM
 import Data.Parameterized (Some(..))
 import Control.Monad.Identity
 import Pate.TraceTree
+import qualified What4.JSON as W4S
+import What4.JSON
 
 -- | A pair of values indexed based on which binary they are associated with (either the
 --   original binary or the patched binary).
@@ -519,4 +522,20 @@ jsonPatchPair f ppair = case ppair of
 
 
 instance (forall bin. JSON.ToJSON (tp bin)) => JSON.ToJSON (PatchPair tp) where
-  toJSON p = jsonPatchPair (JSON.toJSON) p
+  toJSON p = jsonPatchPair (JSON.toJSON) p
+
+w4SerializePair :: PatchPair f -> (forall bin. f bin -> W4S.W4S sym JSON.Value) -> W4S.W4S sym JSON.Value
+w4SerializePair ppair f = case ppair of
+    PatchPair o p -> do
+      o_v <- f o
+      p_v <- f p
+      return $ JSON.object ["original" JSON..= o_v, "patched" JSON..= p_v]
+    PatchPairOriginal o -> do
+      o_v <- f o
+      return $ JSON.object ["original" JSON..= o_v]
+    PatchPairPatched p -> do
+      p_v <- f p
+      return $ JSON.object ["patched" JSON..= p_v]
+
+instance W4S.W4SerializableF sym f => W4S.W4Serializable sym (PatchPair f) where
+  w4Serialize ppair = w4SerializePair ppair w4SerializeF

src/Pate/SimulatorRegisters.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Pate.SimulatorRegisters (
   CrucBaseTypes,

src/Pate/Verification/StrongestPosts/CounterExample.hs

@@ -11,6 +11,7 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 module Pate.Verification.StrongestPosts.CounterExample
   ( TotalityCounterexample(..)
@@ -61,6 +62,8 @@ import qualified What4.Concrete as W4
 import Data.Functor.Const
 import qualified Data.Parameterized.Map as MapF
 import Data.Maybe (mapMaybe)
+import qualified What4.JSON as W4S
+import What4.JSON
 
 -- | A totality counterexample represents a potential control-flow situation that represents
 --   desynchronization of the original and patched program. The first tuple represents
@@ -216,9 +219,17 @@ groundMuxTree sym evalFn = MT.collapseMuxTree sym ite
 data TraceEvents sym arch =
   TraceEvents (PPa.PatchPairC (MT.RegOp sym arch, [TraceEventGroup sym arch]))
 
+instance (PA.ValidArch arch, PSo.ValidSym sym) => W4S.W4Serializable sym (TraceEvents sym arch) where
+  w4Serialize (TraceEvents p) = PPa.w4SerializePair p $ \(Const (rop, evs)) ->
+    W4S.object [ "initial_regs" .= rop, "events" .= evs]
+
 data TraceEventGroup sym arch =
   TraceEventGroup (Maybe (MM.ArchSegmentOff arch)) [MT.TraceEvent sym arch]
 
+instance (PA.ValidArch arch, PSo.ValidSym sym) => W4S.W4Serializable sym (TraceEventGroup sym arch) where
+  w4Serialize (TraceEventGroup mi evs) =
+    W4S.object [ "instruction_addr" .= mi, "events" .= evs]
+
 ppRegOp :: forall sym arch ann. (PA.ValidArch arch, PSo.ValidSym sym) => MT.RegOp sym arch -> [PP.Doc ann]
 ppRegOp (MT.RegOp m) = mapMaybe (\(MapF.Pair r v) -> 
   case PA.displayRegister r of
@@ -260,6 +271,7 @@ instance (PSo.ValidSym sym, PA.ValidArch arch) => IsTraceNode '(sym,arch) "trace
       "Event Trace:" PP.<+> PPa.ppPatchPair' (\(Const (_init_regs, s)) -> 
         ppTraceEventSummary s) evs))
     [Summary, Simplified]
+  jsonNode () v = W4S.w4ToJSON @sym v
 
 ppTraceEventSummary ::
   forall sym arch a.

src/What4/JSON.hs

@@ -15,6 +15,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE LambdaCase #-}
 
 module What4.JSON 
   ( W4S
@@ -23,27 +24,25 @@ module What4.JSON
   , W4SerializableFC
   , SerializableExprs
   , w4ToJSON
+  , object
+  , w4SerializeString
+  , (.=)
+  , (.==)
+  , (.=~)
   ) where
 
-import           Control.Monad.Except (ExceptT, MonadError)
-import           Control.Monad.Reader (ReaderT, MonadReader)
-import           Control.Monad.IO.Class (MonadIO)
-import           Control.Monad.State (StateT, MonadState (..), State, modify, evalState, runState)
+import           Control.Monad.State (MonadState (..), State, modify, evalState, runState)
 
-import           Data.Map.Ordered (OMap)
 import qualified Data.Map.Ordered as OMap
 import           Data.Map (Map)
 import           Data.Text (Text)
-import qualified Data.Text as Text
 import           Data.Data (Proxy(..), Typeable)
 import qualified Data.Aeson as JSON
-import           Data.Aeson ( (.=) )
 
 import           Data.Parameterized.Some (Some(..))
 
 import qualified What4.Interface as W4
 
-import           What4.Serialize.Parser (SomeSymFn(..))
 import qualified What4.Serialize.Printer as W4S
 import qualified What4.Serialize.Parser as W4D
 import qualified What4.Expr.Builder as W4B
@@ -56,6 +55,12 @@ import qualified Data.Text as T
 import GHC.IO (catch, evaluate, unsafePerformIO)
 import GHC.IO.Exception (IOException)
 import Control.DeepSeq (force)
+import Data.Parameterized.Map (MapF)
+import qualified Data.Parameterized.Map as MapF
+import Data.Kind
+import qualified Lang.Crucible.Utils.MuxTree as MT
+import qualified Data.Parameterized.Context as Ctx
+import qualified Data.Parameterized.TraversableFC as TFC
 
 
 
@@ -67,11 +72,13 @@ newtype W4S sym a = W4S (State (ExprCache sym) a)
 class W4Serializable sym a where
   w4Serialize :: a -> W4S sym JSON.Value
 
+w4SerializeString :: Show a => a -> W4S sym JSON.Value
+w4SerializeString s = return $ JSON.String (T.pack (show s))
 
-w4ToJSON :: forall sym a. W4Serializable sym a => a -> JSON.Value
+w4ToJSON :: forall sym a. SerializableExprs sym => W4Serializable sym a => a -> JSON.Value
 w4ToJSON a = let W4S f = w4Serialize @sym a in evalState f (ExprCache Map.empty)
 
-class W4SerializableF sym f where
+class W4SerializableF sym (f :: k -> Type) where
   withSerializable :: Proxy sym -> p f -> q tp -> (W4Serializable sym (f tp) => a) -> a
 
   default withSerializable :: W4Serializable sym (f tp) => Proxy sym -> p f -> q tp -> (W4Serializable sym (f tp) => a) -> a
@@ -114,9 +121,9 @@ instance sym ~ W4B.ExprBuilder t fs scope => W4Serializable sym (W4B.Expr t tp)
               let var_env = map (\(Some bv, t) -> (show (W4B.bvarName bv), t)) $ OMap.toAscList $ W4S.resFreeVarEnv result
               let fn_env = map (\(W4S.SomeExprSymFn fn, t) -> (show (W4B.symFnName fn), t)) $ OMap.toAscList $ W4S.resSymFnEnv result
               let sexpr = W4S.resSExpr result
-              return $ JSON.object [ "symbolic" .= JSON.String (W4D.printSExpr mempty sexpr), "vars" .= var_env, "fns" .= fn_env ]
+              return $ JSON.object [ "symbolic" JSON..= JSON.String (W4D.printSExpr mempty sexpr), "vars" JSON..= var_env, "fns" JSON..= fn_env ]
             case mv of
-              Left er -> return $ JSON.object [ "symbolic_serialize_err" .= er]
+              Left er -> return $ JSON.object [ "symbolic_serialize_err" JSON..= er]
               Right v -> return v
         modify $ \(ExprCache s') -> ExprCache (Map.insert (Some e) v s')
         return v
@@ -129,35 +136,74 @@ instance W4SerializableF sym x => W4Serializable sym (Some x) where
   w4Serialize (Some x) = w4SerializeF x
 
 instance (W4Serializable sym x, W4Serializable sym y) => W4Serializable sym (x, y) where
-  w4Serialize (x,y) = do
-    x_v <- w4Serialize x
-    y_v <- w4Serialize y
-    return $ JSON.object [ "fst" .= x_v, "snd" .= y_v]
+  w4Serialize (x,y) = object [ "fst" .= x, "snd" .= y]
+
+instance (W4Serializable sym x) => W4Serializable sym [x] where
+  w4Serialize xs = do
+    xs_json <- mapM w4Serialize xs
+    return $ JSON.toJSON xs_json
+
+instance W4Serializable sym JSON.Value where
+  w4Serialize = return
 
 instance (W4Serializable sym x, W4Serializable sym y) => W4Serializable sym (Map x y) where
   w4Serialize x = do
-    objs <- forM (Map.toList x) $ \(k, v) -> do
-      k_v <- w4Serialize k
-      v_v <- w4Serialize v
-      return $ JSON.object [ "key" .= k_v, "val" .= v_v]
-    return $ JSON.object [ "map" .= objs ]
+    objs <- forM (Map.toList x) $ \(k, v) -> object [ "key" .= k, "val" .= v]
+    object [ "map" .= objs ]
 
 type SerializableExprs sym = W4SerializableF sym (W4.SymExpr sym)
 
 instance (SerializableExprs sym, W4Serializable sym x) => W4Serializable sym (W4P.PredMap sym x k) where
   w4Serialize x = do
-    objs <- forM (W4P.toList x) $ \(k,p) -> do
-      k_v <- w4Serialize k
-      p_v <- w4SerializeF p
-      return $ JSON.object [ "val" .= k_v, "pred" .= p_v]
-    let (repr :: String) = case typeRepr x of
+    objs <- forM (W4P.toList x) $ \(k,p) -> object [ "val" .= k, "pred" .== p]
+    let (repr :: Text) = case typeRepr x of
           W4P.PredConjRepr -> "conj"
           W4P.PredDisjRepr -> "disj"
-    return $ JSON.object [ "predmap" .= objs, "kind" .= repr ]
+    object [ "predmap" .= objs, "kind" .= repr ]
 
 instance W4Serializable sym Integer where
   w4Serialize i = return $ JSON.toJSON i
 
-instance W4Serializable sym String where
+instance W4Serializable sym Text where
   w4Serialize i = return $ JSON.toJSON i
 
+instance W4Serializable sym a => W4Serializable sym (Maybe a) where
+  w4Serialize = \case
+    Just a -> w4Serialize a
+    Nothing -> return $ JSON.Null
+
+instance W4Serializable sym (W4.NatRepr n) where
+  w4Serialize nr = w4Serialize $ W4.intValue nr
+
+instance (W4SerializableF sym x, W4SerializableF sym y) => W4Serializable sym (MapF x y) where
+  w4Serialize x = do
+    objs <- forM (MapF.toList x) $ \(MapF.Pair k v) -> object [ "key" .== k, "val" .== v]
+    object [ "map" .= objs ]
+
+instance (W4Serializable sym tp, SerializableExprs sym) => W4Serializable sym (MT.MuxTree sym tp) where
+  w4Serialize mt = case MT.viewMuxTree mt of
+    [] -> error "Serialize: Invalid Muxtree"
+    [(e,_)] -> w4Serialize e
+    es -> do
+      body <- forM es $ \(e,p) ->
+        object [ "val" .= e, "pred" .== p]
+      object ["muxtree" .= body]
+
+instance W4SerializableF sym f => W4Serializable sym (Ctx.Assignment f ctx) where
+  w4Serialize x = w4Serialize $ TFC.toListFC Some x
+
+data W4KeyValue sym = forall a. W4Serializable sym a => W4KeyValue JSON.Key a
+
+(.=) :: W4Serializable sym v => JSON.Key -> v -> W4KeyValue sym
+(.=) = W4KeyValue
+
+(.==) :: forall sym v tp. W4SerializableF sym v => JSON.Key -> v tp -> W4KeyValue sym
+(.==) = \k v -> withSerializable (Proxy @sym) (Proxy @v) (Proxy @tp) $ W4KeyValue k v
+
+(.=~) :: Show v => JSON.Key -> v -> W4KeyValue sym
+(.=~) = \k v -> W4KeyValue k (T.pack (show v))
+
+object :: [W4KeyValue sym] -> W4S sym JSON.Value
+object kvs = fmap JSON.object $ forM kvs $ \(W4KeyValue k v) -> do
+    v_json <- w4Serialize v
+    return $ k JSON..= v_json