]> Git — Sourcephile - haskell/symantic-base.git/blob - src/Symantic/Semantics/Viewer.hs
impl: add more reductions to `normalOrderReduction`
[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 -- | This module provides the 'Viewer' semantic
9 -- which interprets combinators as human-readable text.
10 module Symantic.Semantics.Viewer where
11
12 import Data.Function qualified as Fun
13 import Data.Int (Int)
14 import Data.String
15 import Text.Show
16 import Prelude qualified
17
18 import Symantic.Semantics.Data
19 import Symantic.Semantics.Viewer.Fixity
20 import Symantic.Syntaxes.Classes
21 import Symantic.Syntaxes.Derive
22
23 -- * Type 'Viewer'
24 data Viewer a where
25 Viewer :: (ViewerEnv -> ShowS) -> Viewer a
26 ViewerUnifix :: Unifix -> String -> String -> Viewer (a -> b)
27 ViewerInfix :: Infix -> String -> String -> Viewer (a -> b -> c)
28 ViewerApp :: Viewer (b -> a) -> Viewer b -> Viewer a
29
30 runViewer :: Viewer a -> ViewerEnv -> ShowS
31 runViewer (Viewer v) env = v env
32 runViewer (ViewerInfix _op name _infixName) _env = showString name
33 runViewer (ViewerUnifix _op name _unifixName) _env = showString name
34 runViewer (ViewerApp f x) env =
35 pairViewer env op Fun.$
36 runViewer f env{viewEnv_op = (op, SideL)}
37 Fun.. showString " "
38 Fun.. runViewer x env{viewEnv_op = (op, SideR)}
39 where
40 op = infixN 10
41
42 -- | Unusual, but enables to leverage default definition of methods.
43 type instance Derived Viewer = Viewer
44
45 instance LiftDerived Viewer where
46 liftDerived = Fun.id
47
48 instance IsString (Viewer a) where
49 fromString s = Viewer Fun.$ \_env -> showString s
50 instance Show (Viewer a) where
51 showsPrec p =
52 ( `runViewer`
53 ViewerEnv
54 { viewEnv_op = (infixN p, SideL)
55 , viewEnv_pair = pairParen
56 , viewEnv_lamDepth = 1
57 }
58 )
59 instance Show (SomeData Viewer a) where
60 showsPrec p (SomeData x) = showsPrec p (derive x :: Viewer a)
61
62 data ViewerEnv = ViewerEnv
63 { viewEnv_op :: (Infix, Side)
64 , viewEnv_pair :: Pair
65 , viewEnv_lamDepth :: Int
66 }
67
68 pairViewer :: ViewerEnv -> Infix -> ShowS -> ShowS
69 pairViewer env op s =
70 if isPairNeeded (viewEnv_op env) op
71 then showString o Fun.. s Fun.. showString c
72 else s
73 where
74 (o, c) = viewEnv_pair env
75
76 instance Abstractable Viewer where
77 lam f = Viewer Fun.$ \env ->
78 pairViewer env op Fun.$
79 let x = showString "x" Fun.. shows (viewEnv_lamDepth env)
80 in showString "\\"
81 Fun.. x
82 Fun.. showString " -> "
83 Fun.. runViewer
84 (f (Viewer (\_env -> x)))
85 env
86 { viewEnv_op = (op, SideL)
87 , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)
88 }
89 where
90 op = infixN 0
91 instance Abstractable1 Viewer where
92 lam1 f = Viewer Fun.$ \env ->
93 pairViewer env op Fun.$
94 let x = showString "u" Fun.. shows (viewEnv_lamDepth env)
95 in showString "\\"
96 Fun.. x
97 Fun.. showString " -> "
98 Fun.. runViewer
99 (f (Viewer (\_env -> x)))
100 env
101 { viewEnv_op = (op, SideL)
102 , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)
103 }
104 where
105 op = infixN 0
106 instance Instantiable Viewer where
107 ViewerInfix op _name infixName .@ ViewerApp x y = Viewer Fun.$ \env ->
108 pairViewer env op Fun.$
109 runViewer x env{viewEnv_op = (op, SideL)}
110 Fun.. showString " "
111 Fun.. showString infixName
112 Fun.. showString " "
113 Fun.. runViewer y env{viewEnv_op = (op, SideR)}
114 ViewerInfix op name _infixName .@ x = Viewer Fun.$ \env ->
115 showParen Prelude.True Fun.$
116 runViewer x env{viewEnv_op = (op, SideL)}
117 Fun.. showString " "
118 Fun.. showString name
119 f .@ x = ViewerApp f x
120 instance Unabstractable Viewer where
121 ap = ViewerInfix (infixL 4) "(<*>)" "<*>"
122 const = "const"
123 id = "id"
124 (.) = ViewerInfix (infixR 9) "(.)" "."
125 flip = flip
126 ($) = ViewerInfix (infixR 0) "($)" "$"
127 instance Varable Viewer where
128 var = Fun.id
129 instance Anythingable Viewer
130 instance Bottomable Viewer where
131 bottom = "<hidden>"
132 instance Show c => Constantable c Viewer where
133 constant c = Viewer Fun.$ \_env -> shows c
134 instance Eitherable Viewer where
135 either = "either"
136 left = "Left"
137 right = "Right"
138 instance Equalable Viewer where
139 equal = ViewerInfix (infixN 4) "(==)" "=="
140 instance Listable Viewer where
141 cons = ViewerInfix (infixR 5) "(:)" ":"
142 nil = "[]"
143 instance Maybeable Viewer where
144 nothing = "Nothing"
145 just = "Just"
146 instance IfThenElseable Viewer where
147 ifThenElse test ok ko =
148 "if" .@ test .@ "then" .@ ok .@ "else" .@ ko