-- For Viewer
{-# LANGUAGE GADTs #-}
-- For convenience
{-# LANGUAGE OverloadedStrings #-}
-- For Show (SomeData a)
{-# LANGUAGE UndecidableInstances #-}

-- | This module provides the 'Viewer' semantic
-- which interprets combinators as human-readable text.
module Symantic.Semantics.Viewer where

import Data.Function qualified as Fun
import Data.Int (Int)
import Data.String
import Text.Show
import Prelude qualified

import Symantic.Semantics.Data
import Symantic.Semantics.Viewer.Fixity
import Symantic.Syntaxes.Classes
import Symantic.Syntaxes.Derive

-- * Type 'Viewer'
data Viewer a where
  Viewer :: (ViewerEnv -> ShowS) -> Viewer a
  ViewerUnifix :: Unifix -> String -> String -> Viewer (a -> b)
  ViewerInfix :: Infix -> String -> String -> Viewer (a -> b -> c)
  ViewerApp :: Viewer (b -> a) -> Viewer b -> Viewer a

runViewer :: Viewer a -> ViewerEnv -> ShowS
runViewer (Viewer v) env = v env
runViewer (ViewerInfix _op name _infixName) _env = showString name
runViewer (ViewerUnifix _op name _unifixName) _env = showString name
runViewer (ViewerApp f x) env =
  pairViewer env op Fun.$
    runViewer f env{viewEnv_op = (op, SideL)}
      Fun.. showString " "
      Fun.. runViewer x env{viewEnv_op = (op, SideR)}
  where
    op = infixN 10

-- | Unusual, but enables to leverage default definition of methods.
type instance Derived Viewer = Viewer

instance LiftDerived Viewer where
  liftDerived = Fun.id

instance IsString (Viewer a) where
  fromString s = Viewer Fun.$ \_env -> showString s
instance Show (Viewer a) where
  showsPrec p =
    ( `runViewer`
        ViewerEnv
          { viewEnv_op = (infixN p, SideL)
          , viewEnv_pair = pairParen
          , viewEnv_lamDepth = 1
          }
    )
instance Show (SomeData Viewer a) where
  showsPrec p (SomeData x) = showsPrec p (derive x :: Viewer a)

data ViewerEnv = ViewerEnv
  { viewEnv_op :: (Infix, Side)
  , viewEnv_pair :: Pair
  , viewEnv_lamDepth :: Int
  }

pairViewer :: ViewerEnv -> Infix -> ShowS -> ShowS
pairViewer env op s =
  if isPairNeeded (viewEnv_op env) op
    then showString o Fun.. s Fun.. showString c
    else s
  where
    (o, c) = viewEnv_pair env

instance Abstractable Viewer where
  lam f = Viewer Fun.$ \env ->
    pairViewer env op Fun.$
      let x = showString "x" Fun.. shows (viewEnv_lamDepth env)
       in showString "\\"
            Fun.. x
            Fun.. showString " -> "
            Fun.. runViewer
              (f (Viewer (\_env -> x)))
              env
                { viewEnv_op = (op, SideL)
                , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)
                }
    where
      op = infixN 0
instance Abstractable1 Viewer where
  lam1 f = Viewer Fun.$ \env ->
    pairViewer env op Fun.$
      let x = showString "u" Fun.. shows (viewEnv_lamDepth env)
       in showString "\\"
            Fun.. x
            Fun.. showString " -> "
            Fun.. runViewer
              (f (Viewer (\_env -> x)))
              env
                { viewEnv_op = (op, SideL)
                , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)
                }
    where
      op = infixN 0
instance Instantiable Viewer where
  ViewerInfix op _name infixName .@ ViewerApp x y = Viewer Fun.$ \env ->
    pairViewer env op Fun.$
      runViewer x env{viewEnv_op = (op, SideL)}
        Fun.. showString " "
        Fun.. showString infixName
        Fun.. showString " "
        Fun.. runViewer y env{viewEnv_op = (op, SideR)}
  ViewerInfix op name _infixName .@ x = Viewer Fun.$ \env ->
    showParen Prelude.True Fun.$
      runViewer x env{viewEnv_op = (op, SideL)}
        Fun.. showString " "
        Fun.. showString name
  f .@ x = ViewerApp f x
instance Unabstractable Viewer where
  ap = ViewerInfix (infixL 4) "(<*>)" "<*>"
  const = "const"
  id = "id"
  (.) = ViewerInfix (infixR 9) "(.)" "."
  flip = flip
  ($) = ViewerInfix (infixR 0) "($)" "$"
instance Varable Viewer where
  var = Fun.id
instance Anythingable Viewer
instance Bottomable Viewer where
  bottom = "<hidden>"
instance Show c => Constantable c Viewer where
  constant c = Viewer Fun.$ \_env -> shows c
instance Eitherable Viewer where
  either = "either"
  left = "Left"
  right = "Right"
instance Equalable Viewer where
  equal = ViewerInfix (infixN 4) "(==)" "=="
instance Listable Viewer where
  cons = ViewerInfix (infixR 5) "(:)" ":"
  nil = "[]"
instance Maybeable Viewer where
  nothing = "Nothing"
  just = "Just"
instance IfThenElseable Viewer where
  ifThenElse test ok ko = Viewer Fun.$ \env ->
    pairViewer env op Fun.$
    showString "if"
      Fun.. runViewer test env{viewEnv_op = (op, SideL)}
      Fun.. showString "then"
      Fun.. runViewer ok env{viewEnv_op = (op, SideL)}
      Fun.. showString "else"
      Fun.. runViewer ko env{viewEnv_op = (op, SideL)}
    where
    op = infixN 0