]> Git — Sourcephile - haskell/symantic-base.git/blob - src/Symantic/View.hs
iface: add class `SumFunctor`
[haskell/symantic-base.git] / src / Symantic / View.hs
1 {-# LANGUAGE GADTs #-} -- For View
2 {-# LANGUAGE OverloadedStrings #-} -- For convenience
3 {-# LANGUAGE UndecidableInstances #-} -- For Show (SomeData a)
4 module Symantic.View 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.Fixity
13 import Symantic.Lang
14 import Symantic.Data
15 import Symantic.Derive
16
17 data View a where
18 View :: (ViewEnv -> ShowS) -> View a
19 ViewUnifix :: Unifix -> String -> String -> View (a -> b)
20 ViewInfix :: Infix -> String -> String -> View (a -> b -> c)
21 ViewApp :: View (b -> a) -> View b -> View a
22
23 runView :: View a -> ViewEnv -> ShowS
24 runView (View v) env = v env
25 runView (ViewInfix _op name _infixName) _env = showString name
26 runView (ViewUnifix _op name _unifixName) _env = showString name
27 runView (ViewApp f x) env =
28 pairView env op Fun.$
29 runView f env{viewEnv_op = (op, SideL) } Fun..
30 showString " " Fun..
31 runView 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 View = View
36 instance LiftDerived View where
37 liftDerived = Fun.id
38
39 instance IsString (View a) where
40 fromString s = View Fun.$ \_env -> showString s
41 instance Show (View a) where
42 showsPrec p = (`runView` ViewEnv
43 { viewEnv_op = (infixN p, SideL)
44 , viewEnv_pair = pairParen
45 , viewEnv_lamDepth = 1
46 })
47 instance Show (SomeData View a) where
48 showsPrec p (SomeData x) = showsPrec p (derive x :: View a)
49
50 data ViewEnv
51 = ViewEnv
52 { viewEnv_op :: (Infix, Side)
53 , viewEnv_pair :: Pair
54 , viewEnv_lamDepth :: Int
55 }
56
57 pairView :: ViewEnv -> Infix -> ShowS -> ShowS
58 pairView 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 View where
65 var = Fun.id
66 lam f = viewLam "x" f
67 lam1 f = viewLam "u" f
68 ViewInfix op _name infixName .@ ViewApp x y = View Fun.$ \env ->
69 pairView env op Fun.$
70 runView x env{viewEnv_op=(op, SideL)} Fun..
71 showString " " Fun.. showString infixName Fun.. showString " " Fun..
72 runView y env{viewEnv_op=(op, SideR)}
73 ViewInfix op name _infixName .@ x = View Fun.$ \env ->
74 showParen Prelude.True Fun.$
75 runView x env{viewEnv_op=(op, SideL)} Fun..
76 showString " " Fun.. showString name
77 f .@ x = ViewApp f x
78 viewLam :: String -> (View a -> View b) -> View (a -> b)
79 viewLam varPrefix f = View Fun.$ \env ->
80 pairView 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 runView (f (View (\_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 View
93 instance Bottomable View where
94 bottom = "<hidden>"
95 instance Show c => Constantable c View where
96 constant c = View Fun.$ \_env -> shows c
97 instance Eitherable View where
98 left = "Left"
99 right = "Right"
100 instance Equalable View where
101 equal = ViewInfix (infixN 4) "(==)" "=="
102 instance Listable View where
103 cons = ViewInfix (infixR 5) "(:)" ":"
104 nil = "[]"
105 instance Maybeable View where
106 nothing = "Nothing"
107 just = "Just"