{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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
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
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
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"