content: {-# OPTIONS_GHC -Wno-orphans #-}
  
  module Juvix.Compiler.Nockma.Pretty.Base
    ( module Juvix.Compiler.Nockma.Pretty.Base,
      module Juvix.Data.CodeAnn,
      module Juvix.Compiler.Nockma.Pretty.Options,
    )
  where
  
  import Juvix.Compiler.Nockma.Encoding.ByteString (atomToText)
  import Juvix.Compiler.Nockma.Language
  import Juvix.Compiler.Nockma.Pretty.Options
  import Juvix.Data.CodeAnn
  import Juvix.Extra.Strings qualified as Str
  import Juvix.Prelude hiding (Atom, Path)
  
  docDefault :: (PrettyCode c) => c -> Doc Ann
  docDefault = doc defaultOptions
  
  doc :: (PrettyCode c) => Options -> c -> Doc Ann
  doc opts =
    run
      . runReader opts
      . ppCode
  
  class PrettyCode c where
    ppCode :: (Member (Reader Options) r) => c -> Sem r (Doc Ann)
  
  runPrettyCode :: (PrettyCode c) => Options -> c -> Doc Ann
  runPrettyCode opts = run . runReader opts . ppCode
  
  instance PrettyCodeAnn NockNaturalNaturalError where
    ppCodeAnn = \case
      NaturalInvalidPath a -> "Invalid path" <+> docDefault a
      NaturalInvalidOp a -> "Invalid operator code" <+> docDefault a
  
  instance forall a. (PrettyCode a, NockNatural a) => PrettyCode (Atom a) where
    ppCode atm = do
      t <- runFail $ do
        failWhenM (asks (^. optIgnoreTags))
        failMaybe (atm ^. atomTag) >>= ppCode
      let def = fmap (t <?+>) (annotate (AnnKind KNameFunction) <$> ppCode (atm ^. atom))
      fmap (t <?+>) . runFailDefaultM def . failFromError @(ErrNockNatural a) $
        do
          whenM (asks (^. optIgnoreHints)) fail
          h' <- failMaybe (atm ^. atomHint)
          case h' of
            AtomHintOp -> nockOp atm >>= ppCode
            AtomHintPath -> nockPath atm >>= ppCode
            AtomHintBool
              | nockmaEq atm nockTrue -> return (annotate (AnnKind KNameInductive) Str.true_)
              | nockmaEq atm nockFalse -> return (annotate (AnnKind KNameAxiom) Str.false_)
              | otherwise -> fail
            AtomHintNil -> return (annotate (AnnKind KNameConstructor) Str.nil)
            AtomHintVoid -> return (annotate (AnnKind KNameAxiom) Str.void)
            AtomHintFunctionsPlaceholder -> return (annotate (AnnKind KNameAxiom) Str.functionsPlaceholder)
            AtomHintStdlibPlaceholder -> return (annotate (AnnKind KNameAxiom) Str.stdlibPlaceholder)
            AtomHintString -> atomToText atm >>= ppCode
  
  instance PrettyCode Text where
    ppCode = return . dquotes . pretty
  
  instance PrettyCode Interval where
    ppCode = return . pretty
  
  instance PrettyCode Natural where
    ppCode x = do
      isNock <- asks (^. optNock)
      return $
        if
            | isNock -> pretty (formatWithDots x)
            | otherwise -> pretty x
  
  instance PrettyCode Path where
    ppCode = return . ppCodeAnn
  
  instance PrettyCode Direction where
    ppCode = return . ppCodeAnn
  
  instance PrettyCode NockOp where
    ppCode =
      return . annotate (AnnKind KNameFunction) . pretty
  
  instance PrettyCode AnomaFunction where
    ppCode = \case
      AnomaStdlibFunction f -> ppCode f
      AnomaRmFunction f -> ppCode f
  
  instance PrettyCode AnomaValue where
    ppCode = \case
      AnomaRmValue v -> ppCode v
  
  instance PrettyCode StdlibFunction where
    ppCode = return . pretty
  
  instance PrettyCode RmFunction where
    ppCode = return . pretty
  
  instance PrettyCode RmValue where
    ppCode = return . pretty
  
  instance PrettyCode AnomaLib where
    ppCode = \case
      AnomaLibFunction f -> ppCode f
      AnomaLibValue v -> ppCode v
  
  instance (PrettyCode a, NockNatural a) => PrettyCode (AnomaLibCall a) where
    ppCode c = do
      fun <- ppCode (c ^. anomaLibCallRef)
      args <- ppCode (c ^. anomaLibCallArgs)
      return (Str.stdlibTag <> fun <+> Str.argsTag <> args)
  
  instance PrettyCode Tag where
    ppCode (Tag txt) = return (annotate AnnKeyword Str.tagTag <> pretty txt)
  
  instance (PrettyCode a, NockNatural a) => PrettyCode (Cell a) where
    ppCode c = do
      m <- asks (^. optPrettyMode)
      label <- runFail $ do
        failWhenM (asks (^. optIgnoreTags))
        failMaybe (c ^. cellTag) >>= ppCode
      anomaLibCall <- runFail $ do
        failWhenM (asks (^. optIgnoreHints))
        failMaybe (c ^. cellCall) >>= ppCode
      components <- case m of
        AllDelimiters -> do
          l' <- ppCode (c ^. cellLeft)
          r' <- ppCode (c ^. cellRight)
          return (l' <+> r')
        MinimizeDelimiters -> sep <$> mapM ppCode (unfoldCell c)
      let inside = label <?+> anomaLibCall <?+> components
      return (oneLineOrNextBrackets inside)
  
  unfoldCell :: Cell a -> NonEmpty (Term a)
  unfoldCell c = c ^. cellLeft :| reverse (go [] (c ^. cellRight))
    where
      go :: [Term a] -> Term a -> [Term a]
      go acc t = case t of
        TermAtom {} -> t : acc
        TermCell (Cell' l r i)
          | isNothing (i ^. cellInfoCall) && isNothing (i ^. cellInfoTag) -> go (l : acc) r
          | otherwise -> t : acc
  
  instance (PrettyCode a, NockNatural a) => PrettyCode (Term a) where
    ppCode = \case
      TermAtom t -> ppCode t
      TermCell c -> ppCode c
  
  instance (PrettyCode a, NockNatural a) => PrettyCode [Term a] where
    ppCode ts = do
      ts' <- mapM ppCode ts
      return (braces (commaSep ts'))
  