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


-- TODO [#712]: Remove this next major release
{-# OPTIONS_GHC -Wno-deprecations -Wno-orphans #-}

-- | Core parser types

module Morley.Michelson.Parser.Types
  ( Parser
  , Parser'
  , LetEnv (..)
  , noLetEnv
  , HasLetEnv(..)
  , assertLetEnv
  , withLetEnv

  , MichelsonSource (.., MSStdin, MSCli)
  , codeSrc
  ) where

import Data.Default (Default(..))
import Data.Map qualified as Map
import Data.Type.Equality ((:~:)(Refl))
import Fmt (Buildable(..))
import GHC.Stack (SrcLoc(..))
import Text.Megaparsec (Parsec, customFailure)

import Morley.Michelson.Let (LetType, LetValue)
import Morley.Michelson.Macro (LetMacro)
import Morley.Michelson.Parser.Error

type Parser a r = HasLetEnv a => Parser' a r
type Parser' a = ReaderT a (Parsec CustomParserException Text)

class HasLetEnv a where
  isLetEnv :: Maybe (a :~: LetEnv)

instance HasLetEnv LetEnv where
  isLetEnv = Just Refl

instance HasLetEnv () where
  isLetEnv = Nothing

assertLetEnv :: forall le. Parser le (le :~: LetEnv)
assertLetEnv = maybe (customFailure DeprecatedException) pure $ isLetEnv @le

withLetEnv :: forall le a. Parser' LetEnv a -> Parser le a
withLetEnv p = case isLetEnv @le of
  Just Refl -> p
  Nothing -> mzero

instance Default a => Default (Parser' le a) where
  def = pure def

data ParserOptions = ParserOptions
  { poMorleyExts :: Bool
  } deriving stock (Show, Eq)

-- | The environment containing lets from the let-block
data LetEnv = LetEnv
  { letMacros :: Map Text LetMacro
  , letValues :: Map Text LetValue
  , letTypes  :: Map Text LetType
  } deriving stock (Show, Eq)

{-# DEPRECATED LetEnv "Let macros are deprecated" #-}

noLetEnv :: LetEnv
noLetEnv = LetEnv Map.empty Map.empty Map.empty

instance Default LetEnv where
  def = noLetEnv

-- | Where a contract or value in Michelson comes from.
data MichelsonSource
  -- | From given file.
  = MSFile FilePath
  -- | Only source name is known.
  | MSName Text
  -- | Defined in Haskell code.
  | MSCode SrcLoc
  -- | Some unknown source.
  | MSUnspecified
  deriving stock (Show, Eq)

-- | Designates @stdin@ source.
pattern MSStdin :: MichelsonSource
pattern MSStdin = MSName "<stdin>"

-- | Designates command line input source.
pattern MSCli :: MichelsonSource
pattern MSCli = MSName "<cli>"

instance IsString MichelsonSource where
  fromString = MSName . fromString

-- Dunno why these are necessary, hlint behaves weirdly
{-# ANN module ("HLint: ignore Use 'callStack' from Universum" :: Text) #-}
{-# ANN module ("HLint: ignore Use 'getCallStack' from Universum" :: Text) #-}

-- | 'MichelsonSource' that points to the current position.
codeSrc :: HasCallStack => MichelsonSource
codeSrc = MSCode $
  case reverse (getCallStack callStack) of
    [] -> error "Unexpectedly empty callstack"
    (_funName, srcLoc) : _ -> srcLoc

instance Buildable MichelsonSource where
  build = \case
    MSFile file -> build file
    MSStdin -> "<user input>"
    MSCli -> "<user input via CLI>"
    MSName name -> build name
    MSCode SrcLoc{..} ->
      build srcLocFile <> ":" <> build srcLocStartLine <> ":" <> build srcLocStartCol
    MSUnspecified -> ""