-- 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 :: forall a. Viewer a -> ViewerEnv -> ShowS
runViewer (Viewer ViewerEnv -> ShowS
v) ViewerEnv
env = ViewerEnv -> ShowS
v ViewerEnv
env
runViewer (ViewerInfix Infix
_op String
name String
_infixName) ViewerEnv
_env = String -> ShowS
showString String
name
runViewer (ViewerUnifix Unifix
_op String
name String
_unifixName) ViewerEnv
_env = String -> ShowS
showString String
name
runViewer (ViewerApp Viewer (b -> a)
f Viewer b
x) ViewerEnv
env =
  ViewerEnv -> Infix -> ShowS -> ShowS
pairViewer ViewerEnv
env Infix
op (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
Fun.$
    Viewer (b -> a) -> ViewerEnv -> ShowS
forall a. Viewer a -> ViewerEnv -> ShowS
runViewer Viewer (b -> a)
f ViewerEnv
env{viewEnv_op :: (Infix, Side)
viewEnv_op = (Infix
op, Side
SideL)}
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. String -> ShowS
showString String
" "
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. Viewer b -> ViewerEnv -> ShowS
forall a. Viewer a -> ViewerEnv -> ShowS
runViewer Viewer b
x ViewerEnv
env{viewEnv_op :: (Infix, Side)
viewEnv_op = (Infix
op, Side
SideR)}
  where
    op :: Infix
op = Precedence -> Infix
infixN Precedence
10

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

instance LiftDerived Viewer where
  liftDerived :: forall a. Derived Viewer a -> Viewer a
liftDerived = Derived Viewer a -> Viewer a
forall a. a -> a
Fun.id

instance IsString (Viewer a) where
  fromString :: String -> Viewer a
fromString String
s = (ViewerEnv -> ShowS) -> Viewer a
forall a. (ViewerEnv -> ShowS) -> Viewer a
Viewer ((ViewerEnv -> ShowS) -> Viewer a)
-> (ViewerEnv -> ShowS) -> Viewer a
forall a b. (a -> b) -> a -> b
Fun.$ \ViewerEnv
_env -> String -> ShowS
showString String
s
instance Show (Viewer a) where
  showsPrec :: Precedence -> Viewer a -> ShowS
showsPrec Precedence
p =
    ( Viewer a -> ViewerEnv -> ShowS
forall a. Viewer a -> ViewerEnv -> ShowS
`runViewer`
        ViewerEnv :: (Infix, Side) -> Pair -> Precedence -> ViewerEnv
ViewerEnv
          { viewEnv_op :: (Infix, Side)
viewEnv_op = (Precedence -> Infix
infixN Precedence
p, Side
SideL)
          , viewEnv_pair :: Pair
viewEnv_pair = Pair
pairParen
          , viewEnv_lamDepth :: Precedence
viewEnv_lamDepth = Precedence
1
          }
    )
instance Show (SomeData Viewer a) where
  showsPrec :: Precedence -> SomeData Viewer a -> ShowS
showsPrec Precedence
p (SomeData Data able Viewer a
x) = Precedence -> Viewer a -> ShowS
forall a. Show a => Precedence -> a -> ShowS
showsPrec Precedence
p (Data able Viewer a -> Derived (Data able Viewer) a
forall (sem :: Semantic) a. Derivable sem => sem a -> Derived sem a
derive Data able Viewer a
x :: Viewer a)

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

pairViewer :: ViewerEnv -> Infix -> ShowS -> ShowS
pairViewer :: ViewerEnv -> Infix -> ShowS -> ShowS
pairViewer ViewerEnv
env Infix
op ShowS
s =
  if (Infix, Side) -> Infix -> Bool
isPairNeeded (ViewerEnv -> (Infix, Side)
viewEnv_op ViewerEnv
env) Infix
op
    then String -> ShowS
showString String
o ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. ShowS
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. String -> ShowS
showString String
c
    else ShowS
s
  where
    (String
o, String
c) = ViewerEnv -> Pair
viewEnv_pair ViewerEnv
env

instance Abstractable Viewer where
  var :: forall a. Viewer a -> Viewer a
var = Viewer a -> Viewer a
forall a. a -> a
Fun.id
  lam :: forall a b. (Viewer a -> Viewer b) -> Viewer (a -> b)
lam = String -> (Viewer a -> Viewer b) -> Viewer (a -> b)
forall a b. String -> (Viewer a -> Viewer b) -> Viewer (a -> b)
viewLam String
"x"
  lam1 :: forall a b. (Viewer a -> Viewer b) -> Viewer (a -> b)
lam1 = String -> (Viewer a -> Viewer b) -> Viewer (a -> b)
forall a b. String -> (Viewer a -> Viewer b) -> Viewer (a -> b)
viewLam String
"u"
viewLam :: String -> (Viewer a -> Viewer b) -> Viewer (a -> b)
viewLam :: forall a b. String -> (Viewer a -> Viewer b) -> Viewer (a -> b)
viewLam String
varPrefix Viewer a -> Viewer b
f = (ViewerEnv -> ShowS) -> Viewer (a -> b)
forall a. (ViewerEnv -> ShowS) -> Viewer a
Viewer ((ViewerEnv -> ShowS) -> Viewer (a -> b))
-> (ViewerEnv -> ShowS) -> Viewer (a -> b)
forall a b. (a -> b) -> a -> b
Fun.$ \ViewerEnv
env ->
  ViewerEnv -> Infix -> ShowS -> ShowS
pairViewer ViewerEnv
env Infix
op (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
Fun.$
    let x :: ShowS
x =
          String -> ShowS
showString String
varPrefix
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. Precedence -> Precedence -> ShowS
forall a. Show a => Precedence -> a -> ShowS
showsPrec Precedence
0 (ViewerEnv -> Precedence
viewEnv_lamDepth ViewerEnv
env)
     in -- showString "Lam1 (" .
        String -> ShowS
showString String
"\\" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. ShowS
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. String -> ShowS
showString String
" -> "
          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. Viewer b -> ViewerEnv -> ShowS
forall a. Viewer a -> ViewerEnv -> ShowS
runViewer
            (Viewer a -> Viewer b
f ((ViewerEnv -> ShowS) -> Viewer a
forall a. (ViewerEnv -> ShowS) -> Viewer a
Viewer (\ViewerEnv
_env -> ShowS
x)))
            ViewerEnv
env
              { viewEnv_op :: (Infix, Side)
viewEnv_op = (Infix
op, Side
SideL)
              , viewEnv_lamDepth :: Precedence
viewEnv_lamDepth = Precedence -> Precedence
forall a. Enum a => a -> a
Prelude.succ (ViewerEnv -> Precedence
viewEnv_lamDepth ViewerEnv
env)
              }
  where
    -- . showString ")"

    op :: Infix
op = Precedence -> Infix
infixN Precedence
0
instance Unabstractable Viewer where
  ViewerInfix Infix
op String
_name String
infixName .@ :: forall a b. Viewer (a -> b) -> Viewer a -> Viewer b
.@ ViewerApp Viewer (b -> a)
x Viewer b
y = (ViewerEnv -> ShowS) -> Viewer b
forall a. (ViewerEnv -> ShowS) -> Viewer a
Viewer ((ViewerEnv -> ShowS) -> Viewer b)
-> (ViewerEnv -> ShowS) -> Viewer b
forall a b. (a -> b) -> a -> b
Fun.$ \ViewerEnv
env ->
    ViewerEnv -> Infix -> ShowS -> ShowS
pairViewer ViewerEnv
env Infix
op (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
Fun.$
      Viewer (b -> a) -> ViewerEnv -> ShowS
forall a. Viewer a -> ViewerEnv -> ShowS
runViewer Viewer (b -> a)
x ViewerEnv
env{viewEnv_op :: (Infix, Side)
viewEnv_op = (Infix
op, Side
SideL)}
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. String -> ShowS
showString String
" "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. String -> ShowS
showString String
infixName
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. String -> ShowS
showString String
" "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. Viewer b -> ViewerEnv -> ShowS
forall a. Viewer a -> ViewerEnv -> ShowS
runViewer Viewer b
y ViewerEnv
env{viewEnv_op :: (Infix, Side)
viewEnv_op = (Infix
op, Side
SideR)}
  ViewerInfix Infix
op String
name String
_infixName .@ Viewer a
x = (ViewerEnv -> ShowS) -> Viewer b
forall a. (ViewerEnv -> ShowS) -> Viewer a
Viewer ((ViewerEnv -> ShowS) -> Viewer b)
-> (ViewerEnv -> ShowS) -> Viewer b
forall a b. (a -> b) -> a -> b
Fun.$ \ViewerEnv
env ->
    Bool -> ShowS -> ShowS
showParen Bool
Prelude.True (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
Fun.$
      Viewer a -> ViewerEnv -> ShowS
forall a. Viewer a -> ViewerEnv -> ShowS
runViewer Viewer a
x ViewerEnv
env{viewEnv_op :: (Infix, Side)
viewEnv_op = (Infix
op, Side
SideL)}
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. String -> ShowS
showString String
" "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. String -> ShowS
showString String
name
  Viewer (a -> b)
f .@ Viewer a
x = Viewer (a -> b) -> Viewer a -> Viewer b
forall a b. Viewer (a -> b) -> Viewer a -> Viewer b
ViewerApp Viewer (a -> b)
f Viewer a
x
instance Anythingable Viewer
instance Bottomable Viewer where
  bottom :: forall a. Viewer a
bottom = Viewer a
"<hidden>"
instance Show c => Constantable c Viewer where
  constant :: c -> Viewer c
constant c
c = (ViewerEnv -> ShowS) -> Viewer c
forall a. (ViewerEnv -> ShowS) -> Viewer a
Viewer ((ViewerEnv -> ShowS) -> Viewer c)
-> (ViewerEnv -> ShowS) -> Viewer c
forall a b. (a -> b) -> a -> b
Fun.$ \ViewerEnv
_env -> c -> ShowS
forall a. Show a => a -> ShowS
shows c
c
instance Eitherable Viewer where
  either :: forall l a r. Viewer ((l -> a) -> (r -> a) -> Either l r -> a)
either = Viewer ((l -> a) -> (r -> a) -> Either l r -> a)
"either"
  left :: forall l r. Viewer (l -> Either l r)
left = Viewer (l -> Either l r)
"Left"
  right :: forall r l. Viewer (r -> Either l r)
right = Viewer (r -> Either l r)
"Right"
instance Equalable Viewer where
  equal :: forall a. Eq a => Viewer (a -> a -> Bool)
equal = Infix -> String -> String -> Viewer (a -> a -> Bool)
forall a b c. Infix -> String -> String -> Viewer (a -> b -> c)
ViewerInfix (Precedence -> Infix
infixN Precedence
4) String
"(==)" String
"=="
instance Listable Viewer where
  cons :: forall a. Viewer (a -> [a] -> [a])
cons = Infix -> String -> String -> Viewer (a -> [a] -> [a])
forall a b c. Infix -> String -> String -> Viewer (a -> b -> c)
ViewerInfix (Precedence -> Infix
infixR Precedence
5) String
"(:)" String
":"
  nil :: forall a. Viewer [a]
nil = Viewer [a]
"[]"
instance Maybeable Viewer where
  nothing :: forall a. Viewer (Maybe a)
nothing = Viewer (Maybe a)
"Nothing"
  just :: forall a. Viewer (a -> Maybe a)
just = Viewer (a -> Maybe a)
"Just"