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

module Michelson.Untyped.Entrypoints
  ( EpName (..)
  , pattern DefEpName
  , epNameFromParamAnn
  , epNameToParamAnn
  , epNameFromRefAnn
  , epNameToRefAnn
  , EpNameFromRefAnnError (..)
  , buildEpName
  , unsafeBuildEpName
  , mkEntrypointsMap
  ) where

import Data.Aeson.TH (deriveJSON)
import Data.Default (Default(..))
import qualified Data.Map as Map
import Fmt (Buildable(..), pretty, (+|), (|+))
import Test.QuickCheck (Arbitrary(..), suchThatMap)

import Michelson.Untyped.Annotation
import Michelson.Untyped.Type
import Util.Aeson
import Util.CLI

-- | Entrypoint name.
--
-- Empty if this entrypoint is default one.
-- Cannot be equal to "default", the reference implementation forbids that.
-- Also, set of allowed characters should be the same as in annotations.
newtype EpName = EpNameUnsafe { unEpName :: Text }
  deriving stock (Show, Eq, Ord, Generic)

instance NFData EpName

deriveJSON morleyAesonOptions ''EpName

pattern DefEpName :: EpName
pattern DefEpName = EpNameUnsafe ""

instance Buildable EpName where
  build = \case
    DefEpName -> "<default>"
    EpNameUnsafe name -> build name

instance Default EpName where
  def = EpNameUnsafe ""

-- | Make up 'EpName' from annotation in parameter type declaration.
--
-- Returns 'Nothing' if no entrypoint is assigned here.
epNameFromParamAnn :: FieldAnn -> Maybe EpName
epNameFromParamAnn an@(Annotation a)
  | an == noAnn = Nothing
  | a == "default" = Just (EpNameUnsafe "")
  | otherwise = Just $ EpNameUnsafe a

-- | Turn entrypoint name into annotation for contract parameter declaration.
epNameToParamAnn :: EpName -> FieldAnn
epNameToParamAnn (EpNameUnsafe name)
  | name == "" = ann "default"
  | otherwise = ann name

data EpNameFromRefAnnError
  = InEpNameBadAnnotation FieldAnn
  deriving stock (Show, Eq, Generic)

instance NFData EpNameFromRefAnnError

instance Buildable EpNameFromRefAnnError where
  build = \case
    InEpNameBadAnnotation (Annotation an) ->
      "Invalid entrypoint reference `" +| an |+ "`"

-- | Make up 'EpName' from annotation which is reference to an entrypoint
-- (e.g. annotation in @CONTRACT@ instruction).
--
-- Fails if annotation is invalid.
epNameFromRefAnn :: FieldAnn -> Either EpNameFromRefAnnError EpName
epNameFromRefAnn an@(Annotation a)
  | a == "default" = Left $ InEpNameBadAnnotation an
  | otherwise = Right $ EpNameUnsafe a

-- | Turn entrypoint name into annotation used as reference to entrypoint.
epNameToRefAnn :: EpName -> FieldAnn
epNameToRefAnn (EpNameUnsafe name) = ann name

buildEpName :: Text -> Either String EpName
buildEpName txt = do
  annotation <-
    mkAnnotation txt
    & first (mappend "Failed to parse entrypoint: " . pretty)
  epNameFromRefAnn annotation
    & first pretty

unsafeBuildEpName :: Text -> EpName
unsafeBuildEpName = either (error . pretty) id . buildEpName

instance Arbitrary FieldAnn => Arbitrary EpName where
  arbitrary = arbitrary `suchThatMap` (rightToMaybe . epNameFromRefAnn)

instance HasCLReader EpName where
  getReader = eitherReader (buildEpName . toText)
  getMetavar = "ENTRYPOINT"

-- | Given an untyped type, extract a map that maps entrypoint names to the
-- their parameter types. If there are duplicate entrypoints in the given Type
-- then the duplicate entrypoints at a deeper nesting level will get
-- overwritten with the ones that are on top.
mkEntrypointsMap :: Type -> Map EpName Type
mkEntrypointsMap (Type t _) = case t of
  -- We are only interested in `Or` branches to extract entrypoint
  -- annotations.
  TOr f1 f2 t1 t2 -> extractSubmap f1 t1 <> extractSubmap f2 t2
  _ -> mempty
  where
    extractSubmap :: FieldAnn -> Type -> Map EpName Type
    extractSubmap f1 t1 = let
      -- If the field annotation is not empty then merge this field
      -- annotation/type pair with the entrypoint map of inner type. Else
      -- just fetch entrypoint map of inner type.
      innerMap = mkEntrypointsMap t1
      in case epNameFromParamAnn f1 of
        Just epName -> Map.singleton epName t1 <> innerMap
        Nothing -> innerMap