{-# LANGUAGE DerivingStrategies #-}
module Michelson.Analyzer
( AnalyzerRes (..)
, analyze
) where
import Data.Default (def)
import qualified Data.HashMap.Strict as HM
import qualified Data.List.NonEmpty as NE
import Fmt (Buildable(..), Builder, blockMapF', hexF, nameF, (+|))
import Michelson.FailPattern
import Michelson.Text (MText)
import Michelson.Typed
data AnalyzerRes = AnalyzerRes
{ arConstStrings :: !(HashMap MText Word)
, arConstBytes :: !(HashMap ByteString Word)
, arErrorTags :: !(HashMap MText Word)
} deriving stock (Show, Eq)
instance Buildable AnalyzerRes where
build (AnalyzerRes
(toPairs -> constStrings)
(toPairs -> constBytes)
(toPairs -> errorTags)
) =
nameF "String constants"
(buildStrings $ sortByCount constStrings)
+|
nameF "Bytes constants"
(buildBytes $ sortByCount constBytes)
+|
nameF "Error tags"
(buildStrings $ sortByCount errorTags)
+|
longest "strings" constStrings buildStrings
+|
longest "bytes" constBytes buildBytes
where
inQuotes toBuilder x = "\"" <> toBuilder x <> "\""
buildStrings = blockMapF' (inQuotes build) build
buildBytes = blockMapF' (mappend "0x" . hexF) build
sortByCount :: [(k, Word)] -> [(k, Word)]
sortByCount = sortWith snd
sortByLength :: Container k => [(k, Word)] -> [(k, Word)]
sortByLength = sortWith (Down . length . fst)
longest ::
Container x =>
Builder -> [(x, Word)] -> ([(x, Word)] -> Builder) -> Builder
longest name items builder
| length items > 6 =
nameF ("Longest " <> name) $ builder $ take 4 $ sortByLength items
| otherwise = mempty
instance Semigroup AnalyzerRes where
ar1 <> ar2 = AnalyzerRes
{ arConstStrings = arConstStrings ar1 <+> arConstStrings ar2
, arConstBytes = arConstBytes ar1 <+> arConstBytes ar2
, arErrorTags = arErrorTags ar1 <+> arErrorTags ar2
}
where
m1 <+> m2 = HM.unionWith (+) m1 m2
instance Monoid AnalyzerRes where
mempty = AnalyzerRes
{ arConstStrings = mempty
, arConstBytes = mempty
, arErrorTags = mempty
}
analyze :: Instr inp out -> AnalyzerRes
analyze = dfsFoldInstr def{ dsGoToValues = True } step
where
step :: forall i o. Instr i o -> AnalyzerRes
step i = analyzeConstants i <> analyzeErrorTags i
countItems :: (Ord i, Hashable i) => [i] -> HashMap i Word
countItems = HM.fromList . map f . NE.group . sort
where
f ne = (head ne, fromIntegral $ length ne)
analyzeConstants :: forall i o. Instr i o -> AnalyzerRes
analyzeConstants = \case
PUSH v -> mempty
{ arConstStrings = countItems $ allAtomicValues isStringValue v
, arConstBytes = countItems $ allAtomicValues isBytesValue v
}
_ -> mempty
analyzeErrorTags :: forall i o. Instr i o -> AnalyzerRes
analyzeErrorTags i
| Just tfw <- isTypicalFailWith i =
mempty { arErrorTags = one (typicalFailWithTag tfw, 1) }
| otherwise = mempty