Hooks.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{-# LANGUAGE NoRebindableSyntax #-}

module Indigo.Compilation.Hooks
  ( CommentsVerbosity (..)
  , CommentSettings (..)
  , defaultCommentSettings
  , CommentHooks (..)
  , settingsToHooks
  ) where

import Lens.Micro.TH (makeLensesFor)
import Prelude

import GHC.Stack.Types (SrcLoc(..))
import Indigo.Compilation.Sequential
  (InstrCollector(..), Instruction(..), SequentialHooks(..), stmtHookL)
import Indigo.Internal.State
import Indigo.Lorentz
import qualified Lorentz.Instr as L
import qualified Michelson.Typed.Convert as M
import qualified Michelson.Typed.Instr as M

---------------------------------------------
--- Comments settings
---------------------------------------------

data CommentSettings = CommentSettings
  { csVerbosity           :: CommentsVerbosity
  , csPrintFullStackTrace :: Bool
  , csPrintFileName       :: Bool
  } deriving stock (Eq, Show)

defaultCommentSettings :: CommentsVerbosity -> CommentSettings
defaultCommentSettings verb = CommentSettings verb False False

data CommentsVerbosity
  = NoComments
  | LogTopLevelFrontendStatements
  | LogBackendStatements
  | LogAuxCode
  | LogExpressionsComputations
  deriving stock (Show, Eq, Ord, Bounded, Enum)

instance Default CommentSettings where
  def = CommentSettings NoComments False False

makeLensesFor [ ("csVerbosity", "verbosityL")] ''CommentSettings

---------------------------------------------
--- Comments actions
---------------------------------------------

data CommentHooks = CommentHooks
  { chFrontendHooks :: SequentialHooks
  , chBackendHooks  :: GenCodeHooks
  }

instance Semigroup CommentHooks where
  CommentHooks f b <> CommentHooks f1 b1 = CommentHooks (f <> f1) (b <> b1)

instance Monoid CommentHooks where
  mempty = CommentHooks mempty mempty

makeLensesFor [ ("chFrontendHooks", "frontendHooksL")
              , ("chBackendHooks", "backendHooksL")]
              ''CommentHooks

-- | Basically copy-pasted version of 'prettyCallStack' with fixed 'prettySrcLoc'.
prettyFrontendCallStack :: Bool -> Bool -> (String, String) -> CallStack -> ([Text], Text)
prettyFrontendCallStack printFullStk fileName (strt, ends) cs = case getCallStack cs of
    (fn, loc) : rest ->
      ( prettyTop (fn ++ " " ++ strt, loc) :
        if printFullStk && not (null rest) then
          ("Full stacktrace for " <> fromString fn <> ": ") :
          zipWith (\i c -> fromString $ replicate (i * indentSpaces) ' ' ++ prettyCallSite c)
                  [1..] rest
        else []
      , prettyTop (fn ++ " " ++ ends, loc)
      )
    [] -> error "empty call stack in prettyFrontendCallStack"
  where
    prettyTop (fn, loc) = fromString $ prettyCallSite (fn, loc)

    indentSpaces = 2
    prettyCallSite (f, loc) = f ++ " (called at " ++ prettySrcLoc' loc ++ ")"

    prettySrcLoc' :: SrcLoc -> String
    prettySrcLoc' SrcLoc {..} = concat $
      [ srcLocModule, ":", show srcLocStartLine, ":", show srcLocStartCol]
      ++ if fileName then [" in ", srcLocFile] else []

-- | Convert from enum-based verbosity description to specific actions.
settingsToHooks :: CommentSettings -> CommentHooks
settingsToHooks (CommentSettings NoComments _ _) = mempty
settingsToHooks c@(CommentSettings LogTopLevelFrontendStatements p f) = settingsToHooks (c & verbosityL .~ NoComments)
  & frontendHooksL . stmtHookL .~ \cs blk -> do
      let (stCallStk, en) = prettyFrontendCallStack p f ("[fr-stmt starts]", "[fr-stmt ends]") cs
      modify $ \iColl -> iColl {instrList = Comment en : reverse blk ++ map Comment (reverse stCallStk) ++ instrList iColl}
settingsToHooks c@(CommentSettings LogBackendStatements _ _) = settingsToHooks (c & verbosityL .~ LogTopLevelFrontendStatements) &
  -- There was needed some extra hussle to define lenses for GenCodeHooks so I forwent this idea.
  backendHooksL %~ \bh -> bh
    {gchStmtHook = \t cd ->
        L.comment (M.JustComment $ t <> " [bk-stmt starts]") #
        cd #
        L.comment (M.JustComment $ t <> " [bk-stmt ends]")
    }
settingsToHooks c@(CommentSettings LogAuxCode _ _) = settingsToHooks (c & verbosityL .~ LogBackendStatements) &
  backendHooksL %~ \bh -> bh
    { gchAuxiliaryHook = \t cd ->
     let commInstr = L.comment (M.JustComment $ t <> " [bk-aux starts]") in
     -- Compile the passed code with default optimisation settings
     let resLorBlock = compileLorentz cd in
     -- Check if after an optimisation we get empty code block
     -- then omit comment instruction to make it less noisy
     if (M.instrToOps resLorBlock == M.instrToOps M.Nop)
     then cd
     else commInstr # cd
    }
settingsToHooks c@(CommentSettings LogExpressionsComputations _ _) = settingsToHooks (c & verbosityL .~ LogAuxCode) &
  backendHooksL %~ \bh -> bh
    { gchExprHook = \expr cd ->
        L.comment (M.JustComment $ expr <> " [bk-expr starts]") #
        cd #
        L.comment (M.JustComment $ expr <> " [bk-expr ends]")
    }