]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Grammar/Pure.hs
machine: rename InstrPure{Haskell => }
[haskell/symantic-parser.git] / src / Symantic / Parser / Grammar / Pure.hs
1 {-# LANGUAGE PatternSynonyms #-}
2 {-# LANGUAGE TemplateHaskell #-}
3 -- | Haskell terms which are interesting
4 -- to pattern-match when optimizing.
5 module Symantic.Parser.Grammar.Pure where
6
7 import Data.Bool (Bool(..))
8 import Data.Either (Either(..))
9 import Data.Eq (Eq)
10 import Data.Maybe (Maybe(..))
11 import Data.Ord (Ord(..))
12 import Data.Kind (Type)
13 import Text.Show (Show(..), showParen, showString)
14 import qualified Data.Eq as Eq
15 import qualified Data.Function as Function
16 import qualified Language.Haskell.TH as TH
17 import qualified Language.Haskell.TH.Syntax as TH
18
19 import Symantic.Univariant.Trans
20
21 -- * Type 'ValueCode'
22 -- | Compile-time 'value' and corresponding 'code'
23 -- (that can produce that value at runtime).
24 data ValueCode a = ValueCode
25 { value :: Value a
26 , code :: TH.CodeQ a
27 }
28 getValue :: ValueCode a -> a
29 getValue = unValue Function.. value
30 getCode :: ValueCode a -> TH.CodeQ a
31 getCode = code
32
33 -- ** Type 'Value'
34 newtype Value a = Value { unValue :: a }
35
36 -- * Class 'CombPurable'
37 -- | Final encoding of 'CombPure',
38 -- extended with useful terms.
39 class CombPurable (repr :: Type -> Type) where
40 (.) :: repr ((b->c) -> (a->b) -> a -> c)
41 ($) :: repr ((a->b) -> a -> b)
42 (.@) :: repr (a->b) -> repr a -> repr b
43 bool :: Bool -> repr Bool
44 char :: TH.Lift tok => tok -> repr tok
45 cons :: repr (a -> [a] -> [a])
46 const :: repr (a -> b -> a)
47 eq :: Eq a => repr a -> repr (a -> Bool)
48 flip :: repr ((a -> b -> c) -> b -> a -> c)
49 id :: repr (a->a)
50 nil :: repr [a]
51 unit :: repr ()
52 left :: repr (l -> Either l r)
53 right :: repr (r -> Either l r)
54 nothing :: repr (Maybe a)
55 just :: repr (a -> Maybe a)
56
57 -- ** Type 'CombPurable'
58 -- | Initial encoding of 'CombPurable',
59 -- useful for some optimizations in 'optimizeComb'.
60 data CombPure a where
61 CombPure :: ValueCode a -> CombPure a
62 (:.) :: CombPure ((b->c) -> (a->b) -> a -> c)
63 (:$) :: CombPure ((a->b) -> a -> b)
64 (:@) :: CombPure (a->b) -> CombPure a -> CombPure b
65 Cons :: CombPure (a -> [a] -> [a])
66 Const :: CombPure (a -> b -> a)
67 Eq :: Eq a => CombPure a -> CombPure (a -> Bool)
68 Flip :: CombPure ((a -> b -> c) -> b -> a -> c)
69 Id :: CombPure (a->a)
70 Unit :: CombPure ()
71 infixr 0 $, :$
72 infixr 9 ., :.
73 infixl 9 .@, :@
74
75 {-
76 pattern (:.@) ::
77 -- Dummy constraint to get the following constraint
78 -- in scope when pattern-matching.
79 () =>
80 ((x -> y -> z) ~ ((b -> c) -> (a -> b) -> a -> c)) =>
81 CombPure x -> CombPure y -> CombPure z
82 pattern (:.@) f g = (:.) :@ f :@ g
83 pattern FlipApp ::
84 () =>
85 ((x -> y) ~ ((a -> b -> c) -> b -> a -> c)) =>
86 CombPure x -> CombPure y
87 pattern FlipApp f = Flip :@ f
88 pattern FlipConst ::
89 () =>
90 (x ~ (a -> b -> b)) =>
91 CombPure x
92 pattern FlipConst = FlipApp Const
93 -}
94
95 instance Show (CombPure a) where
96 showsPrec p = \case
97 CombPure{} -> showString "CombPure"
98 (:$) -> showString "($)"
99 (:.) :@ f :@ g ->
100 showParen (p >= 9)
101 Function.$ showsPrec 9 f
102 Function.. showString " . "
103 Function.. showsPrec 9 g
104 (:.) -> showString "(.)"
105 Cons :@ x :@ xs ->
106 showParen (p >= 10)
107 Function.$ showsPrec 10 x
108 Function.. showString " : "
109 Function.. showsPrec 10 xs
110 Cons -> showString "cons"
111 Const -> showString "const"
112 Eq x ->
113 showParen True
114 Function.$ showString "== "
115 Function.. showsPrec 0 x
116 Flip -> showString "flip"
117 Id -> showString "id"
118 Unit -> showString "()"
119 (:@) f x ->
120 showParen (p >= 10)
121 Function.$ showsPrec 10 f
122 Function.. showString " "
123 Function.. showsPrec 10 x
124
125 instance Trans CombPure TH.CodeQ where
126 trans = code Function.. trans
127 instance Trans CombPure Value where
128 trans = value Function.. trans
129 instance Trans CombPure ValueCode where
130 trans = \case
131 CombPure x -> x
132 (:.) -> (.)
133 (:$) -> ($)
134 (:@) f x -> (.@) (trans f) (trans x)
135 Cons -> cons
136 Const -> const
137 Eq x -> eq (trans x)
138 Flip -> flip
139 Id -> id
140 Unit -> unit
141 instance Trans ValueCode CombPure where
142 trans = CombPure
143 type instance Output CombPure = ValueCode
144
145 instance CombPurable CombPure where
146 (.) = (:.)
147 ($) = (:$)
148 -- Small optimizations, mainly to reduce dump sizes.
149 Id .@ x = x
150 (Const :@ x) .@ _y = x
151 ((Flip :@ Const) :@ _x) .@ y = y
152 --
153 f .@ x = f :@ x
154 cons = Cons
155 const = Const
156 eq = Eq
157 flip = Flip
158 id = Id
159 unit = Unit
160 bool b = CombPure (bool b)
161 char c = CombPure (char c)
162 nil = CombPure nil
163 left = CombPure left
164 right = CombPure right
165 nothing = CombPure nothing
166 just = CombPure just
167 instance CombPurable ValueCode where
168 (.) = ValueCode (.) (.)
169 ($) = ValueCode ($) ($)
170 (.@) f x = ValueCode ((.@) (value f) (value x)) ((.@) (code f) (code x))
171 bool b = ValueCode (bool b) (bool b)
172 char c = ValueCode (char c) (char c)
173 cons = ValueCode cons cons
174 const = ValueCode const const
175 eq x = ValueCode (eq (value x)) (eq (code x))
176 flip = ValueCode flip flip
177 id = ValueCode id id
178 nil = ValueCode nil nil
179 unit = ValueCode unit unit
180 left = ValueCode left left
181 right = ValueCode right right
182 nothing = ValueCode nothing nothing
183 just = ValueCode just just
184 instance CombPurable Value where
185 (.) = Value (Function..)
186 ($) = Value (Function.$)
187 (.@) f x = Value (unValue f (unValue x))
188 bool = Value
189 char = Value
190 cons = Value (:)
191 const = Value Function.const
192 eq x = Value (unValue x Eq.==)
193 flip = Value Function.flip
194 id = Value Function.id
195 nil = Value []
196 unit = Value ()
197 left = Value Left
198 right = Value Right
199 nothing = Value Nothing
200 just = Value Just
201 instance CombPurable TH.CodeQ where
202 (.) = [|| (Function..) ||]
203 ($) = [|| (Function.$) ||]
204 (.@) f x = [|| $$f $$x ||]
205 bool b = [|| b ||]
206 char c = [|| c ||]
207 cons = [|| (:) ||]
208 const = [|| Function.const ||]
209 eq x = [|| ($$x Eq.==) ||]
210 flip = [|| \f x y -> f y x ||]
211 id = [|| \x -> x ||]
212 nil = [|| [] ||]
213 unit = [|| () ||]
214 left = [|| Left ||]
215 right = [|| Right ||]
216 nothing = [|| Nothing ||]
217 just = [|| Just ||]