module Lorentz.Errors.Numeric
( ErrorTagMap
, ErrorTagExclusions
, gatherErrorTags
, addNewErrorTags
, buildErrorTagMap
, excludeErrorTags
, applyErrorTagMap
, applyErrorTagMapWithExclusions
, useNumericErrors
, errorFromValNumeric
) where
import Data.Bimap (Bimap)
import qualified Data.Bimap as Bimap
import Data.Default (def)
import qualified Data.HashSet as HS
import Data.Singletons (SingI, sing)
import Fmt (pretty)
import Lorentz.Base
import Lorentz.Errors
import Michelson.Analyzer
import Michelson.FailPattern
import Michelson.Text (MText)
import Michelson.Typed
type ErrorTagMap = Bimap Natural MText
type ErrorTagExclusions = HashSet MText
gatherErrorTags :: inp :-> out -> HashSet MText
gatherErrorTags = HS.fromMap . void . arErrorTags . analyze . iAnyCode
addNewErrorTags :: ErrorTagMap -> HashSet MText -> ErrorTagMap
addNewErrorTags existingMap newTags =
foldl' (flip $ uncurry Bimap.tryInsert) existingMap newItems
where
firstUnusedNumeric
| Bimap.null existingMap = 0
| otherwise = fst (Bimap.findMax existingMap) + 1
newItems :: [(Natural, MText)]
newItems = zip [firstUnusedNumeric .. ] (toList newTags)
buildErrorTagMap :: HashSet MText -> ErrorTagMap
buildErrorTagMap = addNewErrorTags Bimap.empty
excludeErrorTags
:: HasCallStack
=> ErrorTagExclusions -> ErrorTagMap -> ErrorTagMap
excludeErrorTags toExclude errMap =
foldl' (flip deleteExistingR) errMap toExclude
where
deleteExistingR k m = case Bimap.lookupR k m of
Just _ -> Bimap.deleteR k m
Nothing ->
error $ "Tag " <> show k <> " does not appear in the contract"
applyErrorTagMap :: HasCallStack => ErrorTagMap -> inp :-> out -> inp :-> out
applyErrorTagMap errorTagMap = applyErrorTagMapWithExclusions errorTagMap mempty
applyErrorTagMapWithExclusions
:: HasCallStack
=> ErrorTagMap -> ErrorTagExclusions -> inp :-> out -> inp :-> out
applyErrorTagMapWithExclusions errorTagMap exclusions =
iMapAnyCode (applyErrorTagMapWithExcT errorTagMap exclusions)
useNumericErrors ::
HasCallStack => inp :-> out -> (inp :-> out, ErrorTagMap)
useNumericErrors instr = (applyErrorTagMap errorTagMap instr, errorTagMap)
where
errorTagMap = buildErrorTagMap $ gatherErrorTags instr
applyErrorTagMapWithExcT ::
HasCallStack
=> ErrorTagMap
-> ErrorTagExclusions
-> Instr inp out
-> Instr inp out
applyErrorTagMapWithExcT errorTagMap exclusions instr =
dfsModifyInstr dfsSettings step instr
where
dfsSettings :: DfsSettings ()
dfsSettings = def
{ dsGoToValues = True
}
tagToNatValue :: HasCallStack => MText -> SomeConstrainedValue ConstantScope'
tagToNatValue tag =
case (HS.member tag exclusions, Bimap.lookupR tag errorTagMap) of
(True, _) -> SomeConstrainedValue (VC $ CvString tag)
(False, Nothing) -> error $ "Can't find a tag: " <> pretty tag
(False, Just n) -> SomeConstrainedValue (VC $ CvNat n)
step :: HasCallStack => Instr inp out -> Instr inp out
step = modifyTypicalFailWith tagToNatValue
errorFromValNumeric ::
(Typeable t, SingI t, IsError e) => ErrorTagMap -> Value t -> Either Text e
errorFromValNumeric errorTagMap v =
case v of
VC (CvNat tag)
| Just textualTag <- Bimap.lookup tag errorTagMap ->
errorFromVal . VC . CvString $ textualTag
VPair (VC (CvNat tag), something)
| Just textualTag <- Bimap.lookup tag errorTagMap
, _ :: Value pair <- v ->
case sing @pair of
STPair {} ->
errorFromVal $ VPair (VC $ CvString textualTag, something)
_ -> errorFromVal v