------------------------------------------------------------------------

-- | Process a "points_to" statement from the precondition section of
-- the CrucibleSetup block. First, load the value from the address
-- indicated by 'ptr', and then match it against the pattern 'val'.
learnPointsTo ::
  Options                    ->
  SharedContext              ->
  JVMCrucibleContext            ->
  CrucibleMethodSpecIR       ->
  PrePost                    ->
  JVMPointsTo                   ->
  OverrideMatcher CJ.JVM w ()
learnPointsTo opts sc cc spec prepost pt =
  jccWithBackend cc $ \bak -> do
  let sym = backendGetSym bak
  let tyenv = MS.csAllocations spec
  let nameEnv = MS.csTypeNames spec
  let jc = cc ^. jccJVMContext
  globals <- OM (use overrideGlobals)
  case pt of

    JVMPointsToField loc ptr fid (Just val) ->
      do ty <- typeOfSetupValue cc tyenv nameEnv val
         rval <- resolveAllocIndexJVM ptr
         dyn <- liftIO $ CJ.doFieldLoad bak globals rval fid
         v <- liftIO $ projectJVMVal bak ty ("field load " ++ J.fieldIdName fid ++ ", " ++ show loc) dyn
         matchArg opts sc cc spec prepost v ty val

    JVMPointsToStatic loc fid (Just val) ->
      do ty <- typeOfSetupValue cc tyenv nameEnv val
         dyn <- liftIO $ CJ.doStaticFieldLoad bak jc globals fid
         v <- liftIO $ projectJVMVal bak ty ("static field load " ++ J.fieldIdName fid ++ ", " ++ show loc) dyn
         matchArg opts sc cc spec prepost v ty val

    JVMPointsToElem loc ptr idx (Just val) ->
      do ty <- typeOfSetupValue cc tyenv nameEnv val
         rval <- resolveAllocIndexJVM ptr
         dyn <- liftIO $ CJ.doArrayLoad bak globals rval idx
         v <- liftIO $ projectJVMVal bak ty ("array load " ++ show idx ++ ", " ++ show loc) dyn
         matchArg opts sc cc spec prepost v ty val

    JVMPointsToArray loc ptr (Just tt) ->
      do (len, ety) <-
           case ttIsMono (ttType tt) of
             Nothing -> fail "jvm_array_is: invalid polymorphic value"
             Just cty ->
               case Cryptol.tIsSeq cty of
                 Nothing -> fail "jvm_array_is: expected array type"
                 Just (lty, ety) ->
                   case Cryptol.tIsNum lty of
                     Nothing -> fail "jvm_array_is: expected finite-sized array"
                     Just len -> pure (len, ety)
         jty <-
           case toJVMType (Cryptol.evalValType mempty ety) of
             Nothing -> fail "jvm_array_is: invalid element type"
             Just jty -> pure jty
         rval <- resolveAllocIndexJVM ptr
         let tval = Cryptol.evalValType mempty ety
         let
           load idx =
             do dyn <- liftIO $ CJ.doArrayLoad bak globals rval idx
                let msg = "array load " ++ show idx ++ ", " ++ show loc
                jval <- liftIO $ projectJVMVal bak jty msg dyn
                let failMsg = StructuralMismatch (ppJVMVal jval) mempty (Just jty) jty -- REVISIT
                valueToSC sym loc failMsg tval jval

         when (len > toInteger (maxBound :: Int)) $ fail "jvm_array_is: array length too long"
         ety_tm <- liftIO $ Cryptol.importType sc Cryptol.emptyEnv ety
         ts <- traverse load [0 .. fromInteger len - 1]
         realTerm <- liftIO $ scVector sc ety_tm ts
         matchTerm sc cc loc prepost realTerm (ttTerm tt)

    -- If the right-hand-side is 'Nothing', this is indicates a "modifies" declaration,
    -- which should probably not appear in the pre-state section, and has no effect.
    _ -> pure ()

------------------------------------------------------------------------
learnPointsTo ::
  Options                    ->
  SharedContext              ->
  JVMCrucibleContext            ->
  CrucibleMethodSpecIR       ->
  PrePost                    ->
  JVMPointsTo                   ->
  OverrideMatcher CJ.JVM w ()
learnPointsTo opts sc cc spec prepost pt =
  jccWithBackend cc $ \bak -> do
  let sym = backendGetSym bak
  let tyenv = MS.csAllocations spec
  let nameEnv = MS.csTypeNames spec
  let jc = cc ^. jccJVMContext
  globals <- OM (use overrideGlobals)
  case pt of

    JVMPointsToField loc ptr fid (Just val) ->
      do ty <- typeOfSetupValue cc tyenv nameEnv val
         rval <- resolveAllocIndexJVM ptr
         dyn <- liftIO $ CJ.doFieldLoad bak globals rval fid
         v <- liftIO $ projectJVMVal bak ty ("field load " ++ J.fieldIdName fid ++ ", " ++ show loc) dyn
         matchArg opts sc cc spec prepost v ty val

    JVMPointsToStatic loc fid (Just val) ->
      do ty <- typeOfSetupValue cc tyenv nameEnv val
         dyn <- liftIO $ CJ.doStaticFieldLoad bak jc globals fid
         v <- liftIO $ projectJVMVal bak ty ("static field load " ++ J.fieldIdName fid ++ ", " ++ show loc) dyn
         matchArg opts sc cc spec prepost v ty val

    JVMPointsToElem loc ptr idx (Just val) ->
      do ty <- typeOfSetupValue cc tyenv nameEnv val
         rval <- resolveAllocIndexJVM ptr
         dyn <- liftIO $ CJ.doArrayLoad bak globals rval idx
         v <- liftIO $ projectJVMVal bak ty ("array load " ++ show idx ++ ", " ++ show loc) dyn
         matchArg opts sc cc spec prepost v ty val

    JVMPointsToArray loc ptr (Just tt) ->
      do (len, ety) <-
           case ttIsMono (ttType tt) of
             Nothing -> fail "jvm_array_is: invalid polymorphic value"
             Just cty ->
               case Cryptol.tIsSeq cty of
                 Nothing -> fail "jvm_array_is: expected array type"
                 Just (lty, ety) ->
                   case Cryptol.tIsNum lty of
                     Nothing -> fail "jvm_array_is: expected finite-sized array"
                     Just len -> pure (len, ety)
         jty <-
           case toJVMType (Cryptol.evalValType mempty ety) of
             Nothing -> fail "jvm_array_is: invalid element type"
             Just jty -> pure jty
         rval <- resolveAllocIndexJVM ptr
         let tval = Cryptol.evalValType mempty ety
         let
           load idx =
             do dyn <- liftIO $ CJ.doArrayLoad bak globals rval idx
                let msg = "array load " ++ show idx ++ ", " ++ show loc
                jval <- liftIO $ projectJVMVal bak jty msg dyn
                let failMsg = StructuralMismatch (ppJVMVal jval) mempty (Just jty) jty -- REVISIT
                valueToSC sym loc failMsg tval jval

         when (len > toInteger (maxBound :: Int)) $ fail "jvm_array_is: array length too long"
         ety_tm <- liftIO $ Cryptol.importType sc Cryptol.emptyEnv ety
         ts <- traverse load [0 .. fromInteger len - 1]
         realTerm <- liftIO $ scVector sc ety_tm ts
         matchTerm sc cc loc prepost realTerm (ttTerm tt)

    -- If the right-hand-side is 'Nothing', this is indicates a "modifies" declaration,
    -- which should probably not appear in the pre-state section, and has no effect.
    _ -> pure ()

------------------------------------------------------------------------
learnPointsTo opts sc cc spec prepost pt =
  jccWithBackend cc $ \bak -> do
  let sym = backendGetSym bak
  let tyenv = MS.csAllocations spec
  let nameEnv = MS.csTypeNames spec
  let jc = cc ^. jccJVMContext
  globals <- OM (use overrideGlobals)
  case pt of

    JVMPointsToField loc ptr fid (Just val) ->
      do ty <- typeOfSetupValue cc tyenv nameEnv val
         rval <- resolveAllocIndexJVM ptr
         dyn <- liftIO $ CJ.doFieldLoad bak globals rval fid
         v <- liftIO $ projectJVMVal bak ty ("field load " ++ J.fieldIdName fid ++ ", " ++ show loc) dyn
         matchArg opts sc cc spec prepost v ty val

    JVMPointsToStatic loc fid (Just val) ->
      do ty <- typeOfSetupValue cc tyenv nameEnv val
         dyn <- liftIO $ CJ.doStaticFieldLoad bak jc globals fid
         v <- liftIO $ projectJVMVal bak ty ("static field load " ++ J.fieldIdName fid ++ ", " ++ show loc) dyn
         matchArg opts sc cc spec prepost v ty val

    JVMPointsToElem loc ptr idx (Just val) ->
      do ty <- typeOfSetupValue cc tyenv nameEnv val
         rval <- resolveAllocIndexJVM ptr
         dyn <- liftIO $ CJ.doArrayLoad bak globals rval idx
         v <- liftIO $ projectJVMVal bak ty ("array load " ++ show idx ++ ", " ++ show loc) dyn
         matchArg opts sc cc spec prepost v ty val

    JVMPointsToArray loc ptr (Just tt) ->
      do (len, ety) <-
           case ttIsMono (ttType tt) of
             Nothing -> fail "jvm_array_is: invalid polymorphic value"
             Just cty ->
               case Cryptol.tIsSeq cty of
                 Nothing -> fail "jvm_array_is: expected array type"
                 Just (lty, ety) ->
                   case Cryptol.tIsNum lty of
                     Nothing -> fail "jvm_array_is: expected finite-sized array"
                     Just len -> pure (len, ety)
         jty <-
           case toJVMType (Cryptol.evalValType mempty ety) of
             Nothing -> fail "jvm_array_is: invalid element type"
             Just jty -> pure jty
         rval <- resolveAllocIndexJVM ptr
         let tval = Cryptol.evalValType mempty ety
         let
           load idx =
             do dyn <- liftIO $ CJ.doArrayLoad bak globals rval idx
                let msg = "array load " ++ show idx ++ ", " ++ show loc
                jval <- liftIO $ projectJVMVal bak jty msg dyn
                let failMsg = StructuralMismatch (ppJVMVal jval) mempty (Just jty) jty -- REVISIT
                valueToSC sym loc failMsg tval jval

         when (len > toInteger (maxBound :: Int)) $ fail "jvm_array_is: array length too long"
         ety_tm <- liftIO $ Cryptol.importType sc Cryptol.emptyEnv ety
         ts <- traverse load [0 .. fromInteger len - 1]
         realTerm <- liftIO $ scVector sc ety_tm ts
         matchTerm sc cc loc prepost realTerm (ttTerm tt)

    -- If the right-hand-side is 'Nothing', this is indicates a "modifies" declaration,
    -- which should probably not appear in the pre-state section, and has no effect.
    _ -> pure ()

------------------------------------------------------------------------