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