ErrorPos.hs

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

module Michelson.ErrorPos
  ( mkPos
  , unsafeMkPos
  , Pos (..)
  , SrcPos (..)
  , srcPos
  , InstrCallStack (..)
  , LetCallStack
  , LetName (..)
  ) where

import Data.Aeson.TH (deriveJSON)
import Data.Data (Data(..))
import Data.Default (Default(..))
import qualified Data.Text as T
import Fmt (Buildable (..))
import Michelson.Printer.Util (RenderDoc (..), renderAnyBuildable)
import Text.PrettyPrint.Leijen.Text


import Util.Aeson


newtype Pos = Pos {unPos :: Word}
  deriving stock (Eq, Ord, Show, Generic, Data)

instance NFData Pos

unsafeMkPos :: Int -> Pos
unsafeMkPos x
  | x < 0     = error $ "negative pos: " <> show x
  | otherwise = Pos $ fromIntegral x

mkPos :: Int -> Maybe Pos
mkPos x
  | x < 0     = Nothing
  | otherwise = Just $ Pos $ fromIntegral x

data SrcPos =
  SrcPos
  { srcLine :: Pos
  , srcCol :: Pos
  } deriving stock (Eq, Ord, Show, Generic, Data)

instance Buildable SrcPos where
  build (SrcPos (Pos l) (Pos c)) = build l <> ":" <> build c

instance NFData SrcPos

srcPos :: Word -> Word -> SrcPos
srcPos x y = SrcPos (Pos x) (Pos y)

newtype LetName = LetName T.Text
  deriving stock (Eq, Ord, Show, Data, Generic)
  deriving newtype Buildable

instance NFData LetName

type LetCallStack = [LetName]
data InstrCallStack = InstrCallStack
  { icsCallStack :: LetCallStack
  , icsSrcPos    :: SrcPos
  } deriving stock (Eq, Ord, Show, Generic, Data)

instance RenderDoc InstrCallStack where
  renderDoc _ InstrCallStack{icsCallStack, icsSrcPos = SrcPos (Pos row) (Pos col)} =
    "Error occurred on line" <+> (renderAnyBuildable (row + 1)) <+> "char" <+> (renderAnyBuildable (col + 1))
    <> case icsCallStack of
         [] -> "."
         _ -> " inside these let defenitions:" <+> (list $ fmap (text . show) icsCallStack) <> "."

instance NFData InstrCallStack

instance Default Pos where
  def = Pos 0

instance Default SrcPos where
  def = SrcPos def def

instance Default InstrCallStack where
  def = InstrCallStack def def

deriveJSON morleyAesonOptions ''Pos
deriveJSON morleyAesonOptions ''SrcPos
deriveJSON morleyAesonOptions ''LetName
deriveJSON morleyAesonOptions ''InstrCallStack