Viewer.hs

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

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.Viewer.Fixity
import Symantic.Syntaxes.Classes
import Symantic.Syntaxes.Data
import Symantic.Syntaxes.Derive

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
  var = Fun.id
  lam = viewLam "x"
  lam1 = viewLam "u"
viewLam :: String -> (Viewer a -> Viewer b) -> Viewer (a -> b)
viewLam varPrefix f = Viewer Fun.$ \env ->
  pairViewer env op Fun.$
    let x =
          showString varPrefix
            Fun.. showsPrec 0 (viewEnv_lamDepth env)
     in -- showString "Lam1 (" .
        showString "\\" Fun.. x Fun.. showString " -> "
          Fun.. runViewer
            (f (Viewer (\_env -> x)))
            env
              { viewEnv_op = (op, SideL)
              , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)
              }
  where
    -- . showString ")"

    op = infixN 0
instance Unabstractable 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 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"