]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Univariant/View.hs
remove useless benchmarks
[haskell/symantic-parser.git] / src / Symantic / Univariant / 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.Univariant.View where
14 {-
15 import Data.Int (Int)
16 import Data.Semigroup (Semigroup(..))
17 import Data.String
18 import Prelude (undefined)
19 import Text.Show
20 import Type.Reflection (Typeable)
21 import qualified Data.Function as Fun
22 import qualified Prelude
23
24 import Symantic.Parser.Grammar.Fixity
25 import Symantic.Univariant.Lang
26 import Symantic.Univariant.Data
27 import Symantic.Univariant.Trans
28
29 data View a where
30 View :: (ViewEnv -> ShowS) -> View a
31 ViewUnifix :: Unifix -> String -> String -> View (a -> b)
32 ViewInfix :: Infix -> String -> String -> View (a -> b -> c)
33 ViewApp :: View (b -> a) -> View b -> View a
34
35 runView :: View a -> ViewEnv -> ShowS
36 runView (View f) env = f env
37 runView (ViewInfix _op name _infixName) env = showString name
38 runView (ViewApp f x) env =
39 pairView env op Fun.$
40 runView f env{viewEnv_op = (op, SideL) } Fun..
41 showString " " Fun..
42 runView x env{viewEnv_op = (op, SideR) }
43 where op = infixN 10
44
45 type instance Output View = View
46 instance Trans View View where
47 trans = Fun.id
48
49 instance IsString (View a) where
50 fromString s = View Fun.$ \_env -> showString s
51 instance Show (View a) where
52 showsPrec p (View v) = v ViewEnv
53 { viewEnv_op = (infixN p, SideL)
54 , viewEnv_pair = pairParen
55 , viewEnv_lamDepth = 1
56 }
57 instance Show (SomeData View a) where
58 showsPrec p (SomeData x) = showsPrec p (trans @_ @View x)
59
60 data ViewEnv
61 = ViewEnv
62 { viewEnv_op :: (Infix, Side)
63 , viewEnv_pair :: Pair
64 , viewEnv_lamDepth :: Int
65 }
66
67 pairView :: ViewEnv -> Infix -> ShowS -> ShowS
68 pairView env op s =
69 if isPairNeeded (viewEnv_op env) op
70 then showString o Fun.. s Fun.. showString c
71 else s
72 where (o,c) = viewEnv_pair env
73
74 instance Abstractable View where
75 var = Fun.id
76 lam f = viewLam "x" f
77 lam1 f = viewLam "u" f
78 ViewInfix op _name infixName .@ ViewApp x y = View Fun.$ \env ->
79 pairView env op Fun.$
80 runView x env{viewEnv_op=(op, SideL)} Fun..
81 showString " " Fun.. showString infixName Fun.. showString " " Fun..
82 runView y env{viewEnv_op=(op, SideR)}
83 ViewInfix op name _infixName .@ x = View Fun.$ \env ->
84 showParen Prelude.True Fun.$
85 runView x env{viewEnv_op=(op, SideL)} Fun..
86 showString " " Fun.. showString name
87 f .@ x = ViewApp f x
88 viewLam :: String -> (View a -> View b) -> View (a -> b)
89 viewLam varPrefix f = View Fun.$ \env ->
90 pairView env op Fun.$
91 let x = showString varPrefix Fun..
92 showsPrec 0 (viewEnv_lamDepth env) in
93 -- showString "Lam1 (" .
94 showString "\\" Fun.. x Fun.. showString " -> " Fun..
95 runView (f (View (\_env -> x))) env
96 { viewEnv_op = (op, SideL)
97 , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)
98 }
99 -- . showString ")"
100 where
101 op = infixN 0
102 instance Anythingable View
103 instance Bottomable View where
104 bottom = "<hidden>"
105 instance Show c => Constantable c View where
106 constant c = View Fun.$ \_env -> shows c
107 instance Eitherable View where
108 left = "Left"
109 right = "Right"
110 instance Equalable View where
111 equal = ViewInfix (infixN 4) "(==)" "=="
112 instance Listable View where
113 cons = ViewInfix (infixR 5) "(:)" ":"
114 nil = "[]"
115 instance Maybeable View where
116 nothing = "Nothing"
117 just = "Just"
118 -}