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

{-# OPTIONS_HADDOCK not-home #-}

-- | Actual decision implementation for 'NumChildren'.
module Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.NumChildren
  ( module Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.NumChildren
  ) where

import Prelude hiding (Type)

import Language.Haskell.TH (Type(..))

import Morley.Michelson.Typed.ClassifiedInstr.Internal.Types
import Morley.Michelson.Typed.Instr (ExtInstr, Instr)

-- | Given a list of constructor arguments, count how many of those arguments
-- are instructions (i.e. 'Instr'), and return the corresponding classification.
-- There is one unfortunate case of ambiguity in 'ExtInstr' we have to handle
-- manually. If arguments mention 'Instr' indirectly, e.g. @Value' Instr t@
-- 'HasIndirectChildren' is returned instead.
numChildren :: [Type] -> NumChildren
numChildren :: [Type] -> NumChildren
numChildren [Type]
args
  | (Element [Type] -> Bool) -> [Type] -> Bool
forall c b.
(Container c, BooleanMonoid b) =>
(Element c -> b) -> c -> b
any Type -> Bool
Element [Type] -> Bool
isExtInstr [Type]
args = NumChildren
MayHaveChildren
  | (Element [Type] -> Bool) -> [Type] -> Bool
forall c b.
(Container c, BooleanMonoid b) =>
(Element c -> b) -> c -> b
any (Type -> Bool
isAppToInstr (Type -> Bool) -> (Type -> Bool) -> Type -> Bool
forall a. Boolean a => a -> a -> a
&& Bool -> Bool
forall a. Boolean a => a -> a
not (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
isInstr) [Type]
args = NumChildren
HasIndirectChildren
  | Bool
otherwise = case [Type] -> Int
countInstrArgs [Type]
args of
      Int
0 -> NumChildren
NoChildren
      Int
1 -> NumChildren
OneChild
      Int
2 -> NumChildren
TwoChildren
      Int
x -> Text -> NumChildren
forall a. HasCallStack => Text -> a
error (Text -> NumChildren) -> Text -> NumChildren
forall a b. (a -> b) -> a -> b
$ Text
"Instruction has too many children: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show Int
x

countInstrArgs :: [Type] -> Int
countInstrArgs :: [Type] -> Int
countInstrArgs = Int -> [Type] -> Int
forall {t}. Num t => t -> [Type] -> t
go Int
0
  where
    go :: t -> [Type] -> t
go !t
n = \case
      [] -> t
n
      (Type
x:[Type]
xs)
        | Type -> Bool
isInstr Type
x -> t -> [Type] -> t
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
+ t
1) [Type]
xs
        | Bool
otherwise -> t -> [Type] -> t
go t
n [Type]
xs

isExtInstr :: Type -> Bool
isExtInstr :: Type -> Bool
isExtInstr = \case
  AppT Type
x Type
_ -> Type -> Bool
isExtInstr Type
x
  ConT Name
n | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''ExtInstr -> Bool
True
  Type
_ -> Bool
False

isInstr :: Type -> Bool
isInstr :: Type -> Bool
isInstr = \case
  AppT Type
x Type
_ -> Type -> Bool
isInstr Type
x
  ConT Name
n | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Instr -> Bool
True
  Type
_ -> Bool
False

isAppToInstr :: Type -> Bool
isAppToInstr :: Type -> Bool
isAppToInstr = \case
  AppT Type
x Type
y -> Type -> Bool
isAppToInstr Type
x Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| Type -> Bool
isAppToInstr Type
y
  ConT Name
n | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Instr -> Bool
True
  Type
_ -> Bool
False