-- 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 :: Maybe (LetEnv :~: LetEnv)
isLetEnv = (LetEnv :~: LetEnv) -> Maybe (LetEnv :~: LetEnv)
forall a. a -> Maybe a
Just LetEnv :~: LetEnv
forall k (a :: k). a :~: a
Refl

instance HasLetEnv () where
  isLetEnv :: Maybe (() :~: LetEnv)
isLetEnv = Maybe (() :~: LetEnv)
forall a. Maybe a
Nothing

assertLetEnv :: forall le. Parser le (le :~: LetEnv)
assertLetEnv :: Parser' le (le :~: LetEnv)
assertLetEnv = Parser' le (le :~: LetEnv)
-> ((le :~: LetEnv) -> Parser' le (le :~: LetEnv))
-> Maybe (le :~: LetEnv)
-> Parser' le (le :~: LetEnv)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (CustomParserException -> Parser' le (le :~: LetEnv)
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure CustomParserException
DeprecatedException) (le :~: LetEnv) -> Parser' le (le :~: LetEnv)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (le :~: LetEnv) -> Parser' le (le :~: LetEnv))
-> Maybe (le :~: LetEnv) -> Parser' le (le :~: LetEnv)
forall a b. (a -> b) -> a -> b
$ HasLetEnv le => Maybe (le :~: LetEnv)
forall a. HasLetEnv a => Maybe (a :~: LetEnv)
isLetEnv @le

withLetEnv :: forall le a. Parser' LetEnv a -> Parser le a
withLetEnv :: Parser' LetEnv a -> Parser le a
withLetEnv Parser' LetEnv a
p = case HasLetEnv le => Maybe (le :~: LetEnv)
forall a. HasLetEnv a => Maybe (a :~: LetEnv)
isLetEnv @le of
  Just le :~: LetEnv
Refl -> Parser' le a
Parser' LetEnv a
p
  Maybe (le :~: LetEnv)
Nothing -> Parser' le a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance Default a => Default (Parser' le a) where
  def :: Parser' le a
def = a -> Parser' le a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Default a => a
def

data ParserOptions = ParserOptions
  { ParserOptions -> Bool
poMorleyExts :: Bool
  } deriving stock (Int -> ParserOptions -> ShowS
[ParserOptions] -> ShowS
ParserOptions -> String
(Int -> ParserOptions -> ShowS)
-> (ParserOptions -> String)
-> ([ParserOptions] -> ShowS)
-> Show ParserOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParserOptions] -> ShowS
$cshowList :: [ParserOptions] -> ShowS
show :: ParserOptions -> String
$cshow :: ParserOptions -> String
showsPrec :: Int -> ParserOptions -> ShowS
$cshowsPrec :: Int -> ParserOptions -> ShowS
Show, ParserOptions -> ParserOptions -> Bool
(ParserOptions -> ParserOptions -> Bool)
-> (ParserOptions -> ParserOptions -> Bool) -> Eq ParserOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParserOptions -> ParserOptions -> Bool
$c/= :: ParserOptions -> ParserOptions -> Bool
== :: ParserOptions -> ParserOptions -> Bool
$c== :: ParserOptions -> ParserOptions -> Bool
Eq)

-- | The environment containing lets from the let-block
data LetEnv = LetEnv
  { LetEnv -> Map Text LetMacro
letMacros :: Map Text LetMacro
  , LetEnv -> Map Text LetValue
letValues :: Map Text LetValue
  , LetEnv -> Map Text LetType
letTypes  :: Map Text LetType
  } deriving stock (Int -> LetEnv -> ShowS
[LetEnv] -> ShowS
LetEnv -> String
(Int -> LetEnv -> ShowS)
-> (LetEnv -> String) -> ([LetEnv] -> ShowS) -> Show LetEnv
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LetEnv] -> ShowS
$cshowList :: [LetEnv] -> ShowS
show :: LetEnv -> String
$cshow :: LetEnv -> String
showsPrec :: Int -> LetEnv -> ShowS
$cshowsPrec :: Int -> LetEnv -> ShowS
Show, LetEnv -> LetEnv -> Bool
(LetEnv -> LetEnv -> Bool)
-> (LetEnv -> LetEnv -> Bool) -> Eq LetEnv
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LetEnv -> LetEnv -> Bool
$c/= :: LetEnv -> LetEnv -> Bool
== :: LetEnv -> LetEnv -> Bool
$c== :: LetEnv -> LetEnv -> Bool
Eq)

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

noLetEnv :: LetEnv
noLetEnv :: LetEnv
noLetEnv = Map Text LetMacro
-> Map Text LetValue -> Map Text LetType -> LetEnv
LetEnv Map Text LetMacro
forall k a. Map k a
Map.empty Map Text LetValue
forall k a. Map k a
Map.empty Map Text LetType
forall k a. Map k a
Map.empty

instance Default LetEnv where
  def :: LetEnv
def = LetEnv
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 (Int -> MichelsonSource -> ShowS
[MichelsonSource] -> ShowS
MichelsonSource -> String
(Int -> MichelsonSource -> ShowS)
-> (MichelsonSource -> String)
-> ([MichelsonSource] -> ShowS)
-> Show MichelsonSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MichelsonSource] -> ShowS
$cshowList :: [MichelsonSource] -> ShowS
show :: MichelsonSource -> String
$cshow :: MichelsonSource -> String
showsPrec :: Int -> MichelsonSource -> ShowS
$cshowsPrec :: Int -> MichelsonSource -> ShowS
Show, MichelsonSource -> MichelsonSource -> Bool
(MichelsonSource -> MichelsonSource -> Bool)
-> (MichelsonSource -> MichelsonSource -> Bool)
-> Eq MichelsonSource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MichelsonSource -> MichelsonSource -> Bool
$c/= :: MichelsonSource -> MichelsonSource -> Bool
== :: MichelsonSource -> MichelsonSource -> Bool
$c== :: MichelsonSource -> MichelsonSource -> Bool
Eq)

-- | Designates @stdin@ source.
pattern MSStdin :: MichelsonSource
pattern $bMSStdin :: MichelsonSource
$mMSStdin :: forall r. MichelsonSource -> (Void# -> r) -> (Void# -> r) -> r
MSStdin = MSName "<stdin>"

-- | Designates command line input source.
pattern MSCli :: MichelsonSource
pattern $bMSCli :: MichelsonSource
$mMSCli :: forall r. MichelsonSource -> (Void# -> r) -> (Void# -> r) -> r
MSCli = MSName "<cli>"

instance IsString MichelsonSource where
  fromString :: String -> MichelsonSource
fromString = Text -> MichelsonSource
MSName (Text -> MichelsonSource)
-> (String -> Text) -> String -> MichelsonSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
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 :: MichelsonSource
codeSrc = SrcLoc -> MichelsonSource
MSCode (SrcLoc -> MichelsonSource) -> SrcLoc -> MichelsonSource
forall a b. (a -> b) -> a -> b
$
  case [(String, SrcLoc)] -> [(String, SrcLoc)]
forall a. [a] -> [a]
reverse (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack) of
    [] -> Text -> SrcLoc
forall a. HasCallStack => Text -> a
error Text
"Unexpectedly empty callstack"
    (String
_funName, SrcLoc
srcLoc) : [(String, SrcLoc)]
_ -> SrcLoc
srcLoc

instance Buildable MichelsonSource where
  build :: MichelsonSource -> Builder
build = \case
    MSFile String
file -> String -> Builder
forall p. Buildable p => p -> Builder
build String
file
    MichelsonSource
MSStdin -> Builder
"<user input>"
    MichelsonSource
MSCli -> Builder
"<user input via CLI>"
    MSName Text
name -> Text -> Builder
forall p. Buildable p => p -> Builder
build Text
name
    MSCode SrcLoc{Int
String
srcLocPackage :: SrcLoc -> String
srcLocModule :: SrcLoc -> String
srcLocFile :: SrcLoc -> String
srcLocStartLine :: SrcLoc -> Int
srcLocStartCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocEndCol :: SrcLoc -> Int
srcLocEndCol :: Int
srcLocEndLine :: Int
srcLocStartCol :: Int
srcLocStartLine :: Int
srcLocFile :: String
srcLocModule :: String
srcLocPackage :: String
..} ->
      String -> Builder
forall p. Buildable p => p -> Builder
build String
srcLocFile Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall p. Buildable p => p -> Builder
build Int
srcLocStartLine Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall p. Buildable p => p -> Builder
build Int
srcLocStartCol
    MichelsonSource
MSUnspecified -> Builder
""