Util.hs

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

{-# OPTIONS_GHC -Wno-orphans #-}

-- | Utilities for rendering Michelson code in a format compatible with
-- Octez software (e.g @octez-client@)
module Morley.Michelson.Printer.Util
  ( RenderDoc(..)
  , printRenderDoc
  , renderOpsList
  , renderOpsListNoBraces
  , wrapInParens
  , renderDocList

    -- * Smart parentheses
  , RenderContext
  , needsParens
  , doesntNeedParens
  , addParens
  , addParensMultiline
  , assertParensNotNeeded
  ) where

import Prelude hiding (group)

import Control.Exception (assert)
import Data.Foldable qualified as Foldable
import Fmt (Buildable(build), FromSimpleDoc(..))
import Fmt.Operators ((<+>), (<//>))
import Fmt.Utils (Doc, SimpleDoc, isEmpty, mkLayoutOptions, renderOneLine)
import Prettyprinter
  (align, braces, enclose, encloseSep, group, hsep, layoutPretty, lbracket, parens, punctuate,
  rbracket, semi, sep, space)

-- | Environment carried during recursive rendering.
newtype RenderContext = RenderContext
  { _rcWillNeedParens :: Bool
    -- ^ Whether the current expression is going to be used as part of
    -- top-level expression or in a similar context.
    -- When set to 'True', you may need to wrap your rendered expression into
    -- parentheses.
  }

-- | Generalize converting a type into a 'Doc'. Used to pretty print Michelson
-- code and define 'Buildable' instances.
class RenderDoc a where
  renderDoc :: RenderContext -> a -> Doc

  -- | Whether a value can be represented in Michelson code.
  -- Normally either all values of some type are renderable or not renderable.
  -- However, in case of instructions we have extra instructions which should
  -- not be rendered.
  -- Note: it's not sufficient to just return 'mempty' for such instructions,
  -- because sometimes we want to print lists of instructions and we need to
  -- ignore them complete (to avoid putting redundant separators).
  isRenderable :: a -> Bool
  isRenderable _ = True

instance RenderDoc Text where
  renderDoc _ = build

instance RenderDoc Doc where
  renderDoc = addParens

-- | Renders a list of 'RenderDoc' elements surrounded with square brackets,
-- separated by a comma and a space.
renderDocList :: RenderDoc a => RenderContext -> [a] -> Doc
renderDocList context = align . encloseSep lbracket rbracket ", " . fmap (renderDoc context)

-- | Convert anything renderable to some text format with line width of 80.
printRenderDoc :: (RenderDoc a, FromSimpleDoc b) => Bool -> a -> b
printRenderDoc oneLine = fmtSimple . doRender oneLine . renderDoc doesntNeedParens

-- | Render a comma-separated list of items in braces
renderOpsList :: (RenderDoc op, Foldable f) => Bool -> f op -> Doc
renderOpsList oneLine ops =
  braces $ enclose space space $ renderOpsListNoBraces oneLine ops

-- | Render a semi-colon-separated list of items without braces
renderOpsListNoBraces :: (RenderDoc op, Foldable f) => Bool -> f op -> Doc
renderOpsListNoBraces oneLine =
  align . (if oneLine then hsep else sep) . punctuate semi .
    fmap (renderDoc doesntNeedParens) . filter isRenderable . Foldable.toList

-- | Wrap documents in parentheses if there are two or more in the list.
wrapInParens :: RenderContext -> NonEmpty Doc -> Doc
wrapInParens (RenderContext pn) ds =
  let moreThanOne = length (filter (not . isEmpty) (toList ds)) > 1
  in  addParens (RenderContext (pn && moreThanOne)) $
        foldr (<+>) mempty ds

instance {-# overlappable #-} RenderDoc a => Buildable a where
  build = align . group . renderDoc doesntNeedParens

-- | Here using a page width of 80 and a ribbon width of 1.0
-- https://hackage.haskell.org/package/wl-pprint-1.2.1/docs/Text-PrettyPrint-Leijen.html
doRender :: Bool -> Doc -> SimpleDoc
doRender oneLine = if oneLine then renderOneLine else layoutPretty $ mkLayoutOptions 1.0 80

-- Smart parentheses
----------------------------------------------------------------------------

{- Motivation:

Some expressions may need to be wrapped into parentheses, but only if they
are part of other expression, and are not already wrapped into braces or
brackets.
-}

-- | Constructors for 'RenderContext'
needsParens, doesntNeedParens :: RenderContext
needsParens = RenderContext True
doesntNeedParens = RenderContext False

-- | Add parentheses if needed.
addParens :: RenderContext -> Doc -> Doc
addParens = \case
  RenderContext True -> parens
  RenderContext False -> id

-- | Add parentheses if needed, multiline if necessary.
addParensMultiline :: RenderContext -> Doc -> Doc
addParensMultiline pn doc = case pn of
  RenderContext True -> "(" <> doc <//> ")"
  RenderContext False -> doc

-- | Ensure parentheses are not required, for case when you cannot
-- sensibly wrap your expression into them.
assertParensNotNeeded :: RenderContext -> a -> a
assertParensNotNeeded (RenderContext pn) = assert (not pn)