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

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

import Symantic.Classes
import Symantic.Data
import Symantic.Derive
import Symantic.Fixity

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 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 :: 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 (repr :: * -> *) a.
Derivable repr =>
repr a -> Derived repr 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 :: Viewer a -> Viewer a
var = Viewer a -> Viewer a
forall a. a -> a
Fun.id
  lam :: (Viewer a -> Viewer b) -> Viewer (a -> b)
lam Viewer a -> Viewer b
f = String -> (Viewer a -> Viewer b) -> Viewer (a -> b)
forall a b. String -> (Viewer a -> Viewer b) -> Viewer (a -> b)
viewLam String
"x" Viewer a -> Viewer b
f
  lam1 :: (Viewer a -> Viewer b) -> Viewer (a -> b)
lam1 Viewer a -> Viewer b
f = String -> (Viewer a -> Viewer b) -> Viewer (a -> b)
forall a b. String -> (Viewer a -> Viewer b) -> Viewer (a -> b)
viewLam String
"u" Viewer a -> Viewer b
f
  ViewerInfix Infix
op String
_name String
infixName .@ :: 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
viewLam :: String -> (Viewer a -> Viewer b) -> Viewer (a -> b)
viewLam :: 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)
      }
    -- . showString ")"
  where
  op :: Infix
op = Precedence -> Infix
infixN Precedence
0
instance Anythingable Viewer
instance Bottomable Viewer where
  bottom :: 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
  left :: Viewer (l -> Either l r)
left = Viewer (l -> Either l r)
"Left"
  right :: Viewer (r -> Either l r)
right = Viewer (r -> Either l r)
"Right"
instance Equalable Viewer where
  equal :: 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 :: 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 :: Viewer [a]
nil = Viewer [a]
"[]"
instance Maybeable Viewer where
  nothing :: Viewer (Maybe a)
nothing = Viewer (Maybe a)
"Nothing"
  just :: Viewer (a -> Maybe a)
just = Viewer (a -> Maybe a)
"Just"