-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# 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.Common.State
import Indigo.Compilation.Sequential
  (InstrCollector(..), Instruction(..), SequentialHooks(..), stmtHookL)
import Indigo.Lorentz
import Lorentz.Ext qualified as L
import Morley.Michelson.Typed.Convert qualified as M
import Morley.Michelson.Typed.Instr qualified as M

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

data CommentSettings = CommentSettings
  { CommentSettings -> CommentsVerbosity
csVerbosity           :: CommentsVerbosity
  , CommentSettings -> Bool
csPrintFullStackTrace :: Bool
  , CommentSettings -> Bool
csPrintFileName       :: Bool
  } deriving stock (CommentSettings -> CommentSettings -> Bool
(CommentSettings -> CommentSettings -> Bool)
-> (CommentSettings -> CommentSettings -> Bool)
-> Eq CommentSettings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommentSettings -> CommentSettings -> Bool
$c/= :: CommentSettings -> CommentSettings -> Bool
== :: CommentSettings -> CommentSettings -> Bool
$c== :: CommentSettings -> CommentSettings -> Bool
Eq, Int -> CommentSettings -> ShowS
[CommentSettings] -> ShowS
CommentSettings -> [Char]
(Int -> CommentSettings -> ShowS)
-> (CommentSettings -> [Char])
-> ([CommentSettings] -> ShowS)
-> Show CommentSettings
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CommentSettings] -> ShowS
$cshowList :: [CommentSettings] -> ShowS
show :: CommentSettings -> [Char]
$cshow :: CommentSettings -> [Char]
showsPrec :: Int -> CommentSettings -> ShowS
$cshowsPrec :: Int -> CommentSettings -> ShowS
Show)

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

data CommentsVerbosity
  = NoComments
  | LogTopLevelFrontendStatements
  | LogBackendStatements
  | LogAuxCode
  | LogExpressionsComputations
  deriving stock (Int -> CommentsVerbosity -> ShowS
[CommentsVerbosity] -> ShowS
CommentsVerbosity -> [Char]
(Int -> CommentsVerbosity -> ShowS)
-> (CommentsVerbosity -> [Char])
-> ([CommentsVerbosity] -> ShowS)
-> Show CommentsVerbosity
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CommentsVerbosity] -> ShowS
$cshowList :: [CommentsVerbosity] -> ShowS
show :: CommentsVerbosity -> [Char]
$cshow :: CommentsVerbosity -> [Char]
showsPrec :: Int -> CommentsVerbosity -> ShowS
$cshowsPrec :: Int -> CommentsVerbosity -> ShowS
Show, CommentsVerbosity -> CommentsVerbosity -> Bool
(CommentsVerbosity -> CommentsVerbosity -> Bool)
-> (CommentsVerbosity -> CommentsVerbosity -> Bool)
-> Eq CommentsVerbosity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommentsVerbosity -> CommentsVerbosity -> Bool
$c/= :: CommentsVerbosity -> CommentsVerbosity -> Bool
== :: CommentsVerbosity -> CommentsVerbosity -> Bool
$c== :: CommentsVerbosity -> CommentsVerbosity -> Bool
Eq, Eq CommentsVerbosity
Eq CommentsVerbosity
-> (CommentsVerbosity -> CommentsVerbosity -> Ordering)
-> (CommentsVerbosity -> CommentsVerbosity -> Bool)
-> (CommentsVerbosity -> CommentsVerbosity -> Bool)
-> (CommentsVerbosity -> CommentsVerbosity -> Bool)
-> (CommentsVerbosity -> CommentsVerbosity -> Bool)
-> (CommentsVerbosity -> CommentsVerbosity -> CommentsVerbosity)
-> (CommentsVerbosity -> CommentsVerbosity -> CommentsVerbosity)
-> Ord CommentsVerbosity
CommentsVerbosity -> CommentsVerbosity -> Bool
CommentsVerbosity -> CommentsVerbosity -> Ordering
CommentsVerbosity -> CommentsVerbosity -> CommentsVerbosity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CommentsVerbosity -> CommentsVerbosity -> CommentsVerbosity
$cmin :: CommentsVerbosity -> CommentsVerbosity -> CommentsVerbosity
max :: CommentsVerbosity -> CommentsVerbosity -> CommentsVerbosity
$cmax :: CommentsVerbosity -> CommentsVerbosity -> CommentsVerbosity
>= :: CommentsVerbosity -> CommentsVerbosity -> Bool
$c>= :: CommentsVerbosity -> CommentsVerbosity -> Bool
> :: CommentsVerbosity -> CommentsVerbosity -> Bool
$c> :: CommentsVerbosity -> CommentsVerbosity -> Bool
<= :: CommentsVerbosity -> CommentsVerbosity -> Bool
$c<= :: CommentsVerbosity -> CommentsVerbosity -> Bool
< :: CommentsVerbosity -> CommentsVerbosity -> Bool
$c< :: CommentsVerbosity -> CommentsVerbosity -> Bool
compare :: CommentsVerbosity -> CommentsVerbosity -> Ordering
$ccompare :: CommentsVerbosity -> CommentsVerbosity -> Ordering
Ord, CommentsVerbosity
CommentsVerbosity -> CommentsVerbosity -> Bounded CommentsVerbosity
forall a. a -> a -> Bounded a
maxBound :: CommentsVerbosity
$cmaxBound :: CommentsVerbosity
minBound :: CommentsVerbosity
$cminBound :: CommentsVerbosity
Bounded, Int -> CommentsVerbosity
CommentsVerbosity -> Int
CommentsVerbosity -> [CommentsVerbosity]
CommentsVerbosity -> CommentsVerbosity
CommentsVerbosity -> CommentsVerbosity -> [CommentsVerbosity]
CommentsVerbosity
-> CommentsVerbosity -> CommentsVerbosity -> [CommentsVerbosity]
(CommentsVerbosity -> CommentsVerbosity)
-> (CommentsVerbosity -> CommentsVerbosity)
-> (Int -> CommentsVerbosity)
-> (CommentsVerbosity -> Int)
-> (CommentsVerbosity -> [CommentsVerbosity])
-> (CommentsVerbosity -> CommentsVerbosity -> [CommentsVerbosity])
-> (CommentsVerbosity -> CommentsVerbosity -> [CommentsVerbosity])
-> (CommentsVerbosity
    -> CommentsVerbosity -> CommentsVerbosity -> [CommentsVerbosity])
-> Enum CommentsVerbosity
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: CommentsVerbosity
-> CommentsVerbosity -> CommentsVerbosity -> [CommentsVerbosity]
$cenumFromThenTo :: CommentsVerbosity
-> CommentsVerbosity -> CommentsVerbosity -> [CommentsVerbosity]
enumFromTo :: CommentsVerbosity -> CommentsVerbosity -> [CommentsVerbosity]
$cenumFromTo :: CommentsVerbosity -> CommentsVerbosity -> [CommentsVerbosity]
enumFromThen :: CommentsVerbosity -> CommentsVerbosity -> [CommentsVerbosity]
$cenumFromThen :: CommentsVerbosity -> CommentsVerbosity -> [CommentsVerbosity]
enumFrom :: CommentsVerbosity -> [CommentsVerbosity]
$cenumFrom :: CommentsVerbosity -> [CommentsVerbosity]
fromEnum :: CommentsVerbosity -> Int
$cfromEnum :: CommentsVerbosity -> Int
toEnum :: Int -> CommentsVerbosity
$ctoEnum :: Int -> CommentsVerbosity
pred :: CommentsVerbosity -> CommentsVerbosity
$cpred :: CommentsVerbosity -> CommentsVerbosity
succ :: CommentsVerbosity -> CommentsVerbosity
$csucc :: CommentsVerbosity -> CommentsVerbosity
Enum)

instance Default CommentSettings where
  def :: CommentSettings
def = CommentsVerbosity -> Bool -> Bool -> CommentSettings
CommentSettings CommentsVerbosity
NoComments Bool
False Bool
False

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

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

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

instance Semigroup CommentHooks where
  CommentHooks SequentialHooks
f GenCodeHooks
b <> :: CommentHooks -> CommentHooks -> CommentHooks
<> CommentHooks SequentialHooks
f1 GenCodeHooks
b1 = SequentialHooks -> GenCodeHooks -> CommentHooks
CommentHooks (SequentialHooks
f SequentialHooks -> SequentialHooks -> SequentialHooks
forall a. Semigroup a => a -> a -> a
<> SequentialHooks
f1) (GenCodeHooks
b GenCodeHooks -> GenCodeHooks -> GenCodeHooks
forall a. Semigroup a => a -> a -> a
<> GenCodeHooks
b1)

instance Monoid CommentHooks where
  mempty :: CommentHooks
mempty = SequentialHooks -> GenCodeHooks -> CommentHooks
CommentHooks SequentialHooks
forall a. Monoid a => a
mempty GenCodeHooks
forall a. Monoid a => a
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 :: Bool -> Bool -> ([Char], [Char]) -> CallStack -> ([Text], Text)
prettyFrontendCallStack Bool
printFullStk Bool
fileName ([Char]
strt, [Char]
ends) CallStack
cs = case CallStack -> [([Char], SrcLoc)]
getCallStack CallStack
cs of
    ([Char]
fn, SrcLoc
loc) : [([Char], SrcLoc)]
rest ->
      ( ([Char], SrcLoc) -> Text
forall {a}. IsString a => ([Char], SrcLoc) -> a
prettyTop ([Char]
fn [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
strt, SrcLoc
loc) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
        if Bool
printFullStk Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
&& Bool -> Bool
forall a. Boolean a => a -> a
not ([([Char], SrcLoc)] -> Bool
forall t. Container t => t -> Bool
null [([Char], SrcLoc)]
rest) then
          (Text
"Full stacktrace for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. IsString a => [Char] -> a
fromString [Char]
fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ") Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
          (Int -> ([Char], SrcLoc) -> Text)
-> [Int] -> [([Char], SrcLoc)] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i ([Char], SrcLoc)
c -> [Char] -> Text
forall a. IsString a => [Char] -> a
fromString ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
indentSpaces) Char
' ' [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ([Char], SrcLoc) -> [Char]
prettyCallSite ([Char], SrcLoc)
c)
                  [Int
1..] [([Char], SrcLoc)]
rest
        else []
      , ([Char], SrcLoc) -> Text
forall {a}. IsString a => ([Char], SrcLoc) -> a
prettyTop ([Char]
fn [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
ends, SrcLoc
loc)
      )
    [] -> Text -> ([Text], Text)
forall a. HasCallStack => Text -> a
error Text
"empty call stack in prettyFrontendCallStack"
  where
    prettyTop :: ([Char], SrcLoc) -> a
prettyTop ([Char]
fn, SrcLoc
loc) = [Char] -> a
forall a. IsString a => [Char] -> a
fromString ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ ([Char], SrcLoc) -> [Char]
prettyCallSite ([Char]
fn, SrcLoc
loc)

    indentSpaces :: Int
indentSpaces = Int
2
    prettyCallSite :: ([Char], SrcLoc) -> [Char]
prettyCallSite ([Char]
f, SrcLoc
loc) = [Char]
f [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" (called at " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ SrcLoc -> [Char]
prettySrcLoc' SrcLoc
loc [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"

    prettySrcLoc' :: SrcLoc -> String
    prettySrcLoc' :: SrcLoc -> [Char]
prettySrcLoc' SrcLoc {Int
[Char]
srcLocEndCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocFile :: SrcLoc -> [Char]
srcLocModule :: SrcLoc -> [Char]
srcLocPackage :: SrcLoc -> [Char]
srcLocStartCol :: SrcLoc -> Int
srcLocStartLine :: SrcLoc -> Int
srcLocEndCol :: Int
srcLocEndLine :: Int
srcLocStartCol :: Int
srcLocStartLine :: Int
srcLocFile :: [Char]
srcLocModule :: [Char]
srcLocPackage :: [Char]
..} = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
      [ [Char]
srcLocModule, [Char]
":", Int -> [Char]
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show Int
srcLocStartLine, [Char]
":", Int -> [Char]
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show Int
srcLocStartCol]
      [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ if Bool
fileName then [[Char]
" in ", [Char]
srcLocFile] else []

-- | Convert from enum-based verbosity description to specific actions.
settingsToHooks :: CommentSettings -> CommentHooks
settingsToHooks :: CommentSettings -> CommentHooks
settingsToHooks (CommentSettings CommentsVerbosity
NoComments Bool
_ Bool
_) = CommentHooks
forall a. Monoid a => a
mempty
settingsToHooks c :: CommentSettings
c@(CommentSettings CommentsVerbosity
LogTopLevelFrontendStatements Bool
p Bool
f) = CommentSettings -> CommentHooks
settingsToHooks (CommentSettings
c CommentSettings
-> (CommentSettings -> CommentSettings) -> CommentSettings
forall a b. a -> (a -> b) -> b
& (CommentsVerbosity -> Identity CommentsVerbosity)
-> CommentSettings -> Identity CommentSettings
Lens' CommentSettings CommentsVerbosity
verbosityL ((CommentsVerbosity -> Identity CommentsVerbosity)
 -> CommentSettings -> Identity CommentSettings)
-> CommentsVerbosity -> CommentSettings -> CommentSettings
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CommentsVerbosity
NoComments)
  CommentHooks -> (CommentHooks -> CommentHooks) -> CommentHooks
forall a b. a -> (a -> b) -> b
& (SequentialHooks -> Identity SequentialHooks)
-> CommentHooks -> Identity CommentHooks
Lens' CommentHooks SequentialHooks
frontendHooksL ((SequentialHooks -> Identity SequentialHooks)
 -> CommentHooks -> Identity CommentHooks)
-> (((CallStack -> Block -> State InstrCollector ())
     -> Identity (CallStack -> Block -> State InstrCollector ()))
    -> SequentialHooks -> Identity SequentialHooks)
-> ((CallStack -> Block -> State InstrCollector ())
    -> Identity (CallStack -> Block -> State InstrCollector ()))
-> CommentHooks
-> Identity CommentHooks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CallStack -> Block -> State InstrCollector ())
 -> Identity (CallStack -> Block -> State InstrCollector ()))
-> SequentialHooks -> Identity SequentialHooks
Lens'
  SequentialHooks (CallStack -> Block -> State InstrCollector ())
stmtHookL (((CallStack -> Block -> State InstrCollector ())
  -> Identity (CallStack -> Block -> State InstrCollector ()))
 -> CommentHooks -> Identity CommentHooks)
-> (CallStack -> Block -> State InstrCollector ())
-> CommentHooks
-> CommentHooks
forall s t a b. ASetter s t a b -> b -> s -> t
.~ \CallStack
cs Block
blk -> do
      let ([Text]
stCallStk, Text
en) = Bool -> Bool -> ([Char], [Char]) -> CallStack -> ([Text], Text)
prettyFrontendCallStack Bool
p Bool
f ([Char]
"[fr-stmt starts]", [Char]
"[fr-stmt ends]") CallStack
cs
      (InstrCollector -> InstrCollector) -> State InstrCollector ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InstrCollector -> InstrCollector) -> State InstrCollector ())
-> (InstrCollector -> InstrCollector) -> State InstrCollector ()
forall a b. (a -> b) -> a -> b
$ \InstrCollector
iColl -> InstrCollector
iColl {instrList :: Block
instrList = Text -> Instruction
Comment Text
en Instruction -> Block -> Block
forall a. a -> [a] -> [a]
: Block -> Block
forall a. [a] -> [a]
reverse Block
blk Block -> Block -> Block
forall a. [a] -> [a] -> [a]
++ (Text -> Instruction) -> [Text] -> Block
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Instruction
Comment ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
stCallStk) Block -> Block -> Block
forall a. [a] -> [a] -> [a]
++ InstrCollector -> Block
instrList InstrCollector
iColl}
settingsToHooks c :: CommentSettings
c@(CommentSettings CommentsVerbosity
LogBackendStatements Bool
_ Bool
_) = CommentSettings -> CommentHooks
settingsToHooks (CommentSettings
c CommentSettings
-> (CommentSettings -> CommentSettings) -> CommentSettings
forall a b. a -> (a -> b) -> b
& (CommentsVerbosity -> Identity CommentsVerbosity)
-> CommentSettings -> Identity CommentSettings
Lens' CommentSettings CommentsVerbosity
verbosityL ((CommentsVerbosity -> Identity CommentsVerbosity)
 -> CommentSettings -> Identity CommentSettings)
-> CommentsVerbosity -> CommentSettings -> CommentSettings
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CommentsVerbosity
LogTopLevelFrontendStatements) CommentHooks -> (CommentHooks -> CommentHooks) -> CommentHooks
forall a b. a -> (a -> b) -> b
&
  -- There was needed some extra hussle to define lenses for GenCodeHooks so I forwent this idea.
  (GenCodeHooks -> Identity GenCodeHooks)
-> CommentHooks -> Identity CommentHooks
Lens' CommentHooks GenCodeHooks
backendHooksL ((GenCodeHooks -> Identity GenCodeHooks)
 -> CommentHooks -> Identity CommentHooks)
-> (GenCodeHooks -> GenCodeHooks) -> CommentHooks -> CommentHooks
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \GenCodeHooks
bh -> GenCodeHooks
bh
    {gchStmtHook :: forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
gchStmtHook = \Text
t inp :-> out
cd ->
        CommentType -> inp :-> inp
forall (s :: [*]). CommentType -> s :-> s
L.comment (Text -> CommentType
M.JustComment (Text -> CommentType) -> Text -> CommentType
forall a b. (a -> b) -> a -> b
$ Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [bk-stmt starts]") (inp :-> inp) -> (inp :-> out) -> inp :-> out
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
        inp :-> out
cd (inp :-> out) -> (out :-> out) -> inp :-> out
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
        CommentType -> out :-> out
forall (s :: [*]). CommentType -> s :-> s
L.comment (Text -> CommentType
M.JustComment (Text -> CommentType) -> Text -> CommentType
forall a b. (a -> b) -> a -> b
$ Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [bk-stmt ends]")
    }
settingsToHooks c :: CommentSettings
c@(CommentSettings CommentsVerbosity
LogAuxCode Bool
_ Bool
_) = CommentSettings -> CommentHooks
settingsToHooks (CommentSettings
c CommentSettings
-> (CommentSettings -> CommentSettings) -> CommentSettings
forall a b. a -> (a -> b) -> b
& (CommentsVerbosity -> Identity CommentsVerbosity)
-> CommentSettings -> Identity CommentSettings
Lens' CommentSettings CommentsVerbosity
verbosityL ((CommentsVerbosity -> Identity CommentsVerbosity)
 -> CommentSettings -> Identity CommentSettings)
-> CommentsVerbosity -> CommentSettings -> CommentSettings
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CommentsVerbosity
LogBackendStatements) CommentHooks -> (CommentHooks -> CommentHooks) -> CommentHooks
forall a b. a -> (a -> b) -> b
&
  (GenCodeHooks -> Identity GenCodeHooks)
-> CommentHooks -> Identity CommentHooks
Lens' CommentHooks GenCodeHooks
backendHooksL ((GenCodeHooks -> Identity GenCodeHooks)
 -> CommentHooks -> Identity CommentHooks)
-> (GenCodeHooks -> GenCodeHooks) -> CommentHooks -> CommentHooks
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \GenCodeHooks
bh -> GenCodeHooks
bh
    { gchAuxiliaryHook :: forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
gchAuxiliaryHook = \Text
t inp :-> out
cd ->
     let commInstr :: inp :-> inp
commInstr = CommentType -> inp :-> inp
forall (s :: [*]). CommentType -> s :-> s
L.comment (Text -> CommentType
M.JustComment (Text -> CommentType) -> Text -> CommentType
forall a b. (a -> b) -> a -> b
$ Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [bk-aux starts]") in
     -- Compile the passed code with default optimisation settings
     let resLorBlock :: Instr (ToTs inp) (ToTs out)
resLorBlock = (inp :-> out) -> Instr (ToTs inp) (ToTs out)
forall (inp :: [*]) (out :: [*]).
(inp :-> out) -> Instr (ToTs inp) (ToTs out)
compileLorentz inp :-> out
cd in
     -- Check if after an optimisation we get empty code block
     -- then omit comment instruction to make it less noisy
     if (Instr (ToTs inp) (ToTs out) -> [ExpandedOp]
forall (inp :: [T]) (out :: [T]).
HasCallStack =>
Instr inp out -> [ExpandedOp]
M.instrToOps Instr (ToTs inp) (ToTs out)
resLorBlock [ExpandedOp] -> [ExpandedOp] -> Bool
forall a. Eq a => a -> a -> Bool
== Instr Any Any -> [ExpandedOp]
forall (inp :: [T]) (out :: [T]).
HasCallStack =>
Instr inp out -> [ExpandedOp]
M.instrToOps Instr Any Any
forall (inp :: [T]). Instr inp inp
M.Nop)
     then inp :-> out
cd
     else inp :-> inp
commInstr (inp :-> inp) -> (inp :-> out) -> inp :-> out
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# inp :-> out
cd
    }
settingsToHooks c :: CommentSettings
c@(CommentSettings CommentsVerbosity
LogExpressionsComputations Bool
_ Bool
_) = CommentSettings -> CommentHooks
settingsToHooks (CommentSettings
c CommentSettings
-> (CommentSettings -> CommentSettings) -> CommentSettings
forall a b. a -> (a -> b) -> b
& (CommentsVerbosity -> Identity CommentsVerbosity)
-> CommentSettings -> Identity CommentSettings
Lens' CommentSettings CommentsVerbosity
verbosityL ((CommentsVerbosity -> Identity CommentsVerbosity)
 -> CommentSettings -> Identity CommentSettings)
-> CommentsVerbosity -> CommentSettings -> CommentSettings
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CommentsVerbosity
LogAuxCode) CommentHooks -> (CommentHooks -> CommentHooks) -> CommentHooks
forall a b. a -> (a -> b) -> b
&
  (GenCodeHooks -> Identity GenCodeHooks)
-> CommentHooks -> Identity CommentHooks
Lens' CommentHooks GenCodeHooks
backendHooksL ((GenCodeHooks -> Identity GenCodeHooks)
 -> CommentHooks -> Identity CommentHooks)
-> (GenCodeHooks -> GenCodeHooks) -> CommentHooks -> CommentHooks
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \GenCodeHooks
bh -> GenCodeHooks
bh
    { gchExprHook :: forall (inp :: [*]) (out :: [*]).
Text -> (inp :-> out) -> inp :-> out
gchExprHook = \Text
expr inp :-> out
cd ->
        CommentType -> inp :-> inp
forall (s :: [*]). CommentType -> s :-> s
L.comment (Text -> CommentType
M.JustComment (Text -> CommentType) -> Text -> CommentType
forall a b. (a -> b) -> a -> b
$ Text
expr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [bk-expr starts]") (inp :-> inp) -> (inp :-> out) -> inp :-> out
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
        inp :-> out
cd (inp :-> out) -> (out :-> out) -> inp :-> out
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
        CommentType -> out :-> out
forall (s :: [*]). CommentType -> s :-> s
L.comment (Text -> CommentType
M.JustComment (Text -> CommentType) -> Text -> CommentType
forall a b. (a -> b) -> a -> b
$ Text
expr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [bk-expr ends]")
    }