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