{-# HLINT ignore "Avoid restricted module" #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com
-- SPDX-License-Identifier: MIT

module Printer
  ( printExpression
  , printExpression'
  , printExpressionHidingRho'
  , printExpressionWith
  , printAttribute
  , printAlpha
  , printBinding
  , printBytes
  , printFunction
  , printExtraArg
  , printSubsts
  , printSubsts'
  , PrintConfig
  , logPrintConfig
  )
where

import AST
import CST
import Data.List (intercalate)
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import Encoding
import Lining
import Margin (defaultMargin, withLines)
import Matcher
import Render
import Sugar
import Yaml (ExtraArgument (ArgAttribute, ArgBinding, ArgBytes, ArgExpression))
import Prelude hiding (print)

type PrintConfig = (SugarType, Encoding, LineFormat, Int)

defaultPrintConfig :: PrintConfig
defaultPrintConfig :: PrintConfig
defaultPrintConfig = (SugarType
SWEET, Encoding
UNICODE, LineFormat
MULTILINE, Int
defaultMargin)

logPrintConfig :: (SugarType, Encoding, LineFormat, Int)
logPrintConfig :: PrintConfig
logPrintConfig = (SugarType
SWEET, Encoding
UNICODE, LineFormat
SINGLELINE, Int
defaultMargin)

printExpression' :: Expression -> PrintConfig -> String
printExpression' :: Expression -> PrintConfig -> String
printExpression' = (SugarType -> EXPRESSION -> EXPRESSION)
-> Expression -> PrintConfig -> String
printExpressionWith ((EXPRESSION -> EXPRESSION) -> SugarType -> EXPRESSION -> EXPRESSION
forall a b. a -> b -> a
const EXPRESSION -> EXPRESSION
forall a. a -> a
id)

printExpressionHidingRho' :: Expression -> PrintConfig -> String
printExpressionHidingRho' :: Expression -> PrintConfig -> String
printExpressionHidingRho' = (SugarType -> EXPRESSION -> EXPRESSION)
-> Expression -> PrintConfig -> String
printExpressionWith SugarType -> EXPRESSION -> EXPRESSION
withoutRho

printExpressionWith :: (SugarType -> EXPRESSION -> EXPRESSION) -> Expression -> PrintConfig -> String
printExpressionWith :: (SugarType -> EXPRESSION -> EXPRESSION)
-> Expression -> PrintConfig -> String
printExpressionWith SugarType -> EXPRESSION -> EXPRESSION
hide Expression
ex (SugarType
sugar, Encoding
encoding, LineFormat
line, Int
margin) =
  Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ EXPRESSION -> Text
forall a. Render a => a -> Text
render (LineFormat -> Int -> EXPRESSION -> EXPRESSION
forall a.
(WithMargin a, ToSingleLine a) =>
LineFormat -> Int -> a -> a
withLines LineFormat
line Int
margin (EXPRESSION -> EXPRESSION) -> EXPRESSION -> EXPRESSION
forall a b. (a -> b) -> a -> b
$ Encoding -> EXPRESSION -> EXPRESSION
forall a. ToASCII a => Encoding -> a -> a
withEncoding Encoding
encoding (EXPRESSION -> EXPRESSION) -> EXPRESSION -> EXPRESSION
forall a b. (a -> b) -> a -> b
$ SugarType -> EXPRESSION -> EXPRESSION
hide SugarType
sugar (EXPRESSION -> EXPRESSION) -> EXPRESSION -> EXPRESSION
forall a b. (a -> b) -> a -> b
$ SugarType -> EXPRESSION -> EXPRESSION
forall a. ToSalty a => SugarType -> a -> a
withSugarType SugarType
sugar (EXPRESSION -> EXPRESSION) -> EXPRESSION -> EXPRESSION
forall a b. (a -> b) -> a -> b
$ Expression -> EXPRESSION
expressionToCST Expression
ex)

printExpression :: Expression -> String
printExpression :: Expression -> String
printExpression Expression
ex = Expression -> PrintConfig -> String
printExpression' Expression
ex PrintConfig
defaultPrintConfig

printAttribute' :: Attribute -> Encoding -> String
printAttribute' :: Attribute -> Encoding -> String
printAttribute' Attribute
att Encoding
encoding = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ATTRIBUTE -> Text
forall a. Render a => a -> Text
render (Encoding -> ATTRIBUTE -> ATTRIBUTE
forall a. ToASCII a => Encoding -> a -> a
withEncoding Encoding
encoding (Attribute -> (Int, EOL) -> ATTRIBUTE
forall a b. ToCST a b => a -> (Int, EOL) -> b
toCST Attribute
att (Int
0, EOL
NO_EOL) :: ATTRIBUTE))

printAttribute :: Attribute -> String
printAttribute :: Attribute -> String
printAttribute Attribute
att =
  let (SugarType
_, Encoding
encoding, LineFormat
_, Int
_) = PrintConfig
defaultPrintConfig
   in Attribute -> Encoding -> String
printAttribute' Attribute
att Encoding
encoding

printAlpha' :: Alpha -> Encoding -> String
printAlpha' :: Alpha -> Encoding -> String
printAlpha' Alpha
index Encoding
encoding = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ALPHA -> Text
forall a. Render a => a -> Text
render (Encoding -> ALPHA -> ALPHA
forall a. ToASCII a => Encoding -> a -> a
withEncoding Encoding
encoding (Alpha -> (Int, EOL) -> ALPHA
forall a b. ToCST a b => a -> (Int, EOL) -> b
toCST Alpha
index (Int
0, EOL
NO_EOL) :: ALPHA))

printAlpha :: Alpha -> String
printAlpha :: Alpha -> String
printAlpha Alpha
index =
  let (SugarType
_, Encoding
encoding, LineFormat
_, Int
_) = PrintConfig
defaultPrintConfig
   in Alpha -> Encoding -> String
printAlpha' Alpha
index Encoding
encoding

printBinding' :: Binding -> PrintConfig -> String
printBinding' :: Binding -> PrintConfig -> String
printBinding' Binding
bd = Expression -> PrintConfig -> String
printExpression' ([Binding] -> Expression
ExFormation [Binding
bd])

printBinding :: Binding -> String
printBinding :: Binding -> String
printBinding Binding
bd = Binding -> PrintConfig -> String
printBinding' Binding
bd PrintConfig
defaultPrintConfig

printBytes :: Bytes -> String
printBytes :: Bytes -> String
printBytes Bytes
bts = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ BYTES -> Text
forall a. Render a => a -> Text
render (Bytes -> (Int, EOL) -> BYTES
forall a b. ToCST a b => a -> (Int, EOL) -> b
toCST Bytes
bts (Int
0, EOL
NO_EOL) :: BYTES)

printFunction :: Function -> String
printFunction :: Function -> String
printFunction Function
fun = Text -> String
T.unpack (PAIR -> Text
spelled (Binding -> (Int, EOL) -> PAIR
forall a b. ToCST a b => a -> (Int, EOL) -> b
toCST (Function -> Binding
BiLambda Function
fun) (Int
0, EOL
NO_EOL) :: PAIR))
  where
    spelled :: PAIR -> T.Text
    spelled :: PAIR -> Text
spelled (PA_LAMBDA Text
name) = Text -> Text
forall a. Render a => a -> Text
render Text
name
    spelled (PA_META_LAMBDA META
sigil) = META -> Text
forall a. Render a => a -> Text
render META
sigil
    spelled PAIR
whole = PAIR -> Text
forall a. Render a => a -> Text
render PAIR
whole

printExtraArg' :: ExtraArgument -> PrintConfig -> String
printExtraArg' :: ExtraArgument -> PrintConfig -> String
printExtraArg' (ArgAttribute Attribute
att) (SugarType
_, Encoding
encoding, LineFormat
_, Int
_) = Attribute -> Encoding -> String
printAttribute' Attribute
att Encoding
encoding
printExtraArg' (ArgBinding Binding
bd) PrintConfig
config = Binding -> PrintConfig -> String
printBinding' Binding
bd PrintConfig
config
printExtraArg' (ArgExpression Expression
ex) PrintConfig
config = Expression -> PrintConfig -> String
printExpression' Expression
ex PrintConfig
config
printExtraArg' (ArgBytes Bytes
bts) PrintConfig
_ = Bytes -> String
printBytes Bytes
bts

printExtraArg :: ExtraArgument -> String
printExtraArg :: ExtraArgument -> String
printExtraArg ExtraArgument
arg = ExtraArgument -> PrintConfig -> String
printExtraArg' ExtraArgument
arg PrintConfig
defaultPrintConfig

printMetaValue :: MetaValue -> PrintConfig -> String
printMetaValue :: MetaValue -> PrintConfig -> String
printMetaValue (MvAttribute Attribute
att) (SugarType
_, Encoding
encoding, LineFormat
_, Int
_) = Attribute -> Encoding -> String
printAttribute' Attribute
att Encoding
encoding
printMetaValue (MvIndex Int
index) PrintConfig
_ = Int -> String
forall a. Show a => a -> String
show Int
index
printMetaValue (MvExpression Expression
ex) PrintConfig
config = Expression -> PrintConfig -> String
printExpression' Expression
ex PrintConfig
config
printMetaValue (MvBytes Bytes
bts) PrintConfig
_ = Bytes -> String
printBytes Bytes
bts
printMetaValue (MvBindings [Binding]
bds) PrintConfig
config = Expression -> PrintConfig -> String
printExpression' ([Binding] -> Expression
ExFormation [Binding]
bds) PrintConfig
config
printMetaValue (MvFunction Function
fun) PrintConfig
_ = Function -> String
printFunction Function
fun

printMeta :: Meta -> String
printMeta :: Meta -> String
printMeta (Named Text
name) = Text -> String
T.unpack Text
name
printMeta (Anon (Slot Text
kind Int
_)) = Text -> String
T.unpack Text
kind

printSubst :: Subst -> PrintConfig -> String
printSubst :: Subst -> PrintConfig -> String
printSubst (Subst Map Meta MetaValue
mp) PrintConfig
config =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
    String
"\n"
    (((Meta, MetaValue) -> String) -> [(Meta, MetaValue)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Meta
key, MetaValue
value) -> Meta -> String
numbered Meta
key String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" >> " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> MetaValue -> PrintConfig -> String
printMetaValue MetaValue
value PrintConfig
config) (Map Meta MetaValue -> [(Meta, MetaValue)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Meta MetaValue
mp))
  where
    numbered :: Meta -> String
    numbered :: Meta -> String
numbered anon :: Meta
anon@(Anon slot :: Slot
slot@(Slot Text
kind Int
_))
      | [Slot] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Slot]
kin Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = Meta -> String
printMeta Meta
anon String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"#" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Slot] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Slot -> Bool) -> [Slot] -> [Slot]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Slot -> Slot -> Bool
forall a. Eq a => a -> a -> Bool
/= Slot
slot) [Slot]
kin) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      where
        kin :: [Slot]
        kin :: [Slot]
kin = [Slot
other | Anon other :: Slot
other@(Slot Text
kind' Int
_) <- Map Meta MetaValue -> [Meta]
forall k a. Map k a -> [k]
Map.keys Map Meta MetaValue
mp, Text
kind' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
kind]
    numbered Meta
other = Meta -> String
printMeta Meta
other

printSubsts' :: [Subst] -> PrintConfig -> String
printSubsts' :: [Subst] -> PrintConfig -> String
printSubsts' [] PrintConfig
_ = String
"------"
printSubsts' [Subst]
substs PrintConfig
config = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n------\n" ((Subst -> String) -> [Subst] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Subst -> PrintConfig -> String
`printSubst` PrintConfig
config) [Subst]
substs)

printSubsts :: [Subst] -> String
printSubsts :: [Subst] -> String
printSubsts [Subst]
substs = [Subst] -> PrintConfig -> String
printSubsts' [Subst]
substs PrintConfig
defaultPrintConfig