1 {-# LANGUAGE GADTs #-} -- For Viewer
2 {-# LANGUAGE OverloadedStrings #-} -- For convenience
3 {-# LANGUAGE UndecidableInstances #-} -- For Show (SomeData a)
4 module Symantic.Viewer where
9 import qualified Data.Function as Fun
10 import qualified Prelude
12 import Symantic.Classes
14 import Symantic.Derive
15 import Symantic.Fixity
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
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..
31 runViewer x env{viewEnv_op = (op, SideR) }
34 -- | Unusual, but enables to leverage default definition of methods.
35 type instance Derived Viewer = Viewer
36 instance LiftDerived Viewer where
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
47 instance Show (SomeData Viewer a) where
48 showsPrec p (SomeData x) = showsPrec p (derive x :: Viewer a)
52 { viewEnv_op :: (Infix, Side)
53 , viewEnv_pair :: Pair
54 , viewEnv_lamDepth :: Int
57 pairViewer :: ViewerEnv -> Infix -> ShowS -> ShowS
59 if isPairNeeded (viewEnv_op env) op
60 then showString o Fun.. s Fun.. showString c
62 where (o,c) = viewEnv_pair env
64 instance Abstractable Viewer where
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)
92 instance Anythingable Viewer
93 instance Bottomable Viewer where
95 instance Show c => Constantable c Viewer where
96 constant c = Viewer Fun.$ \_env -> shows c
97 instance Eitherable Viewer where
100 instance Equalable Viewer where
101 equal = ViewerInfix (infixN 4) "(==)" "=="
102 instance Listable Viewer where
103 cons = ViewerInfix (infixR 5) "(:)" ":"
105 instance Maybeable Viewer where