]> Git — Sourcephile - haskell/symantic-base.git/blob - src/Symantic/Semantics/Viewer.hs
iface: add syntax `Abstractable` to semantic `Forall`
[haskell/symantic-base.git] / src / Symantic / Semantics / Viewer.hs
1 -- For Viewer
2 {-# LANGUAGE GADTs #-}
3 -- For convenience
4 {-# LANGUAGE OverloadedStrings #-}
5 -- For Show (SomeData a)
6 {-# LANGUAGE UndecidableInstances #-}
7
8 module Symantic.Semantics.Viewer where
9
10 import Data.Function qualified as Fun
11 import Data.Int (Int)
12 import Data.String
13 import Text.Show
14 import Prelude qualified
15
16 import Symantic.Semantics.Viewer.Fixity
17 import Symantic.Syntaxes.Classes
18 import Symantic.Syntaxes.Data
19 import Symantic.Syntaxes.Derive
20
21 data Viewer a where
22 Viewer :: (ViewerEnv -> ShowS) -> Viewer a
23 ViewerUnifix :: Unifix -> String -> String -> Viewer (a -> b)
24 ViewerInfix :: Infix -> String -> String -> Viewer (a -> b -> c)
25 ViewerApp :: Viewer (b -> a) -> Viewer b -> Viewer a
26
27 runViewer :: Viewer a -> ViewerEnv -> ShowS
28 runViewer (Viewer v) env = v env
29 runViewer (ViewerInfix _op name _infixName) _env = showString name
30 runViewer (ViewerUnifix _op name _unifixName) _env = showString name
31 runViewer (ViewerApp f x) env =
32 pairViewer env op Fun.$
33 runViewer f env{viewEnv_op = (op, SideL)}
34 Fun.. showString " "
35 Fun.. runViewer x env{viewEnv_op = (op, SideR)}
36 where
37 op = infixN 10
38
39 -- | Unusual, but enables to leverage default definition of methods.
40 type instance Derived Viewer = Viewer
41
42 instance LiftDerived Viewer where
43 liftDerived = Fun.id
44
45 instance IsString (Viewer a) where
46 fromString s = Viewer Fun.$ \_env -> showString s
47 instance Show (Viewer a) where
48 showsPrec p =
49 ( `runViewer`
50 ViewerEnv
51 { viewEnv_op = (infixN p, SideL)
52 , viewEnv_pair = pairParen
53 , viewEnv_lamDepth = 1
54 }
55 )
56 instance Show (SomeData Viewer a) where
57 showsPrec p (SomeData x) = showsPrec p (derive x :: Viewer a)
58
59 data ViewerEnv = ViewerEnv
60 { viewEnv_op :: (Infix, Side)
61 , viewEnv_pair :: Pair
62 , viewEnv_lamDepth :: Int
63 }
64
65 pairViewer :: ViewerEnv -> Infix -> ShowS -> ShowS
66 pairViewer env op s =
67 if isPairNeeded (viewEnv_op env) op
68 then showString o Fun.. s Fun.. showString c
69 else s
70 where
71 (o, c) = viewEnv_pair env
72
73 instance Abstractable Viewer where
74 lam f = Viewer Fun.$ \env ->
75 pairViewer env op Fun.$
76 let x = showString "x" Fun.. shows (viewEnv_lamDepth env)
77 in showString "\\"
78 Fun.. x
79 Fun.. showString " -> "
80 Fun.. runViewer
81 (f (Viewer (\_env -> x)))
82 env
83 { viewEnv_op = (op, SideL)
84 , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)
85 }
86 where
87 op = infixN 0
88 instance Unabstractable Viewer where
89 ViewerInfix op _name infixName .@ ViewerApp x y = Viewer Fun.$ \env ->
90 pairViewer env op Fun.$
91 runViewer x env{viewEnv_op = (op, SideL)}
92 Fun.. showString " "
93 Fun.. showString infixName
94 Fun.. showString " "
95 Fun.. runViewer y env{viewEnv_op = (op, SideR)}
96 ViewerInfix op name _infixName .@ x = Viewer Fun.$ \env ->
97 showParen Prelude.True Fun.$
98 runViewer x env{viewEnv_op = (op, SideL)}
99 Fun.. showString " "
100 Fun.. showString name
101 f .@ x = ViewerApp f x
102 instance Varable Viewer where
103 var = Fun.id
104 instance Anythingable Viewer
105 instance Bottomable Viewer where
106 bottom = "<hidden>"
107 instance Show c => Constantable c Viewer where
108 constant c = Viewer Fun.$ \_env -> shows c
109 instance Eitherable Viewer where
110 either = "either"
111 left = "Left"
112 right = "Right"
113 instance Equalable Viewer where
114 equal = ViewerInfix (infixN 4) "(==)" "=="
115 instance Listable Viewer where
116 cons = ViewerInfix (infixR 5) "(:)" ":"
117 nil = "[]"
118 instance Maybeable Viewer where
119 nothing = "Nothing"
120 just = "Just"