]> Git — Sourcephile - haskell/symantic-base.git/blob - src/Symantic/Semantics/Viewer.hs
doc: update `ChangeLog.md`
[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 var = Fun.id
75 lam = viewLam "x"
76 lam1 = viewLam "u"
77 viewLam :: String -> (Viewer a -> Viewer b) -> Viewer (a -> b)
78 viewLam varPrefix f = Viewer Fun.$ \env ->
79 pairViewer env op Fun.$
80 let x =
81 showString varPrefix
82 Fun.. showsPrec 0 (viewEnv_lamDepth env)
83 in -- showString "Lam1 (" .
84 showString "\\" Fun.. x Fun.. showString " -> "
85 Fun.. runViewer
86 (f (Viewer (\_env -> x)))
87 env
88 { viewEnv_op = (op, SideL)
89 , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)
90 }
91 where
92 -- . showString ")"
93
94 op = infixN 0
95 instance Unabstractable Viewer where
96 ViewerInfix op _name infixName .@ ViewerApp x y = Viewer Fun.$ \env ->
97 pairViewer env op Fun.$
98 runViewer x env{viewEnv_op = (op, SideL)}
99 Fun.. showString " "
100 Fun.. showString infixName
101 Fun.. showString " "
102 Fun.. runViewer y env{viewEnv_op = (op, SideR)}
103 ViewerInfix op name _infixName .@ x = Viewer Fun.$ \env ->
104 showParen Prelude.True Fun.$
105 runViewer x env{viewEnv_op = (op, SideL)}
106 Fun.. showString " "
107 Fun.. showString name
108 f .@ x = ViewerApp f x
109 instance Anythingable Viewer
110 instance Bottomable Viewer where
111 bottom = "<hidden>"
112 instance Show c => Constantable c Viewer where
113 constant c = Viewer Fun.$ \_env -> shows c
114 instance Eitherable Viewer where
115 either = "either"
116 left = "Left"
117 right = "Right"
118 instance Equalable Viewer where
119 equal = ViewerInfix (infixN 4) "(==)" "=="
120 instance Listable Viewer where
121 cons = ViewerInfix (infixR 5) "(:)" ":"
122 nil = "[]"
123 instance Maybeable Viewer where
124 nothing = "Nothing"
125 just = "Just"