-- 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.String
import Numeric.Natural (Natural)
import Prelude qualified
import Text.Show

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

view :: Viewer a -> ViewerEnv -> ShowS
view (Viewer v) env = v env
view (ViewerInfix _op name _infixName) _env = showString name
view (ViewerUnifix _op name _unifixName) _env = showString name
view (ViewerApp f x) env =
  pairViewer env op Fun.$
    view f env{viewerEnvOp = (op, SideL)}
      Fun.. showString " "
      Fun.. view x env{viewerEnvOp = (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 =
    ( `view`
        ViewerEnv
          { viewerEnvOp = (infixN p, SideL)
          , viewerEnvPair = pairParen
          , viewerEnvLamDepth = 1
          }
    )
instance Show (SomeData Viewer a) where
  showsPrec p (SomeData x) = showsPrec p (derive x :: Viewer a)

-- ** Type 'ViewerEnv'
data ViewerEnv = ViewerEnv
  { viewerEnvOp :: (Infix, Side)
  , viewerEnvPair :: Pair
  , viewerEnvLamDepth :: Natural
  }

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

instance Abstractable Viewer where
  lam f = Viewer Fun.$ \env ->
    pairViewer env op Fun.$
      let x = showString "x" Fun.. shows (viewerEnvLamDepth env)
       in showString "\\"
            Fun.. x
            Fun.. showString " -> "
            Fun.. view
              (f (Viewer (\_env -> x)))
              env
                { viewerEnvOp = (op, SideL)
                , viewerEnvLamDepth = Prelude.succ (viewerEnvLamDepth env)
                }
    where
      op = infixN 0
instance Abstractable1 Viewer where
  lam1 f = Viewer Fun.$ \env ->
    pairViewer env op Fun.$
      let x = showString "u" Fun.. shows (viewerEnvLamDepth env)
       in showString "\\"
            Fun.. x
            Fun.. showString " -> "
            Fun.. view
              (f (Viewer (\_env -> x)))
              env
                { viewerEnvOp = (op, SideL)
                , viewerEnvLamDepth = Prelude.succ (viewerEnvLamDepth env)
                }
    where
      op = infixN 0
instance Instantiable Viewer where
  ViewerInfix op _name infixName .@ ViewerApp x y = Viewer Fun.$ \env ->
    pairViewer env op Fun.$
      view x env{viewerEnvOp = (op, SideL)}
        Fun.. showString " "
        Fun.. showString infixName
        Fun.. showString " "
        Fun.. view y env{viewerEnvOp = (op, SideR)}
  ViewerInfix op name _infixName .@ x = Viewer Fun.$ \env ->
    showParen Prelude.True Fun.$
      view x env{viewerEnvOp = (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.. view test env{viewerEnvOp = (op, SideL)}
      Fun.. showString "then"
      Fun.. view ok env{viewerEnvOp = (op, SideL)}
      Fun.. showString "else"
      Fun.. view ko env{viewerEnvOp = (op, SideL)}
    where
    op = infixN 0