]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Haskell/Optimize.hs
fix: use a global polyfix for defLet and defRef
[haskell/symantic-parser.git] / src / Symantic / Parser / Haskell / Optimize.hs
1 {-# LANGUAGE NoMonomorphismRestriction #-}
2 {-# LANGUAGE TemplateHaskell #-}
3 {-# LANGUAGE ViewPatterns #-}
4 module Symantic.Parser.Haskell.Optimize where
5
6 import Data.Bool (Bool(..))
7 import Data.Functor.Identity (Identity(..))
8 import Data.String (String)
9 import Prelude (undefined)
10 import Text.Show (Show(..))
11 import qualified Data.Eq as Eq
12 import qualified Data.Function as Fun
13 import qualified Language.Haskell.TH as TH
14 import qualified Language.Haskell.TH.Syntax as TH
15
16 import Symantic.Univariant.Trans
17 import Symantic.Parser.Haskell.Term
18
19 -- * Type 'Term'
20 -- | Initial encoding of some 'Termable' symantics,
21 -- useful for some optimizations in 'optimizeTerm'.
22 data Term repr a where
23 -- | Black-box for all terms neither interpreted nor pattern-matched.
24 Term :: { unTerm :: repr a } -> Term repr a
25
26 -- Terms useful for 'optimizeTerm'.
27 (:@) :: Term repr (a->b) -> Term repr a -> Term repr b
28 Lam :: (Term repr a -> Term repr b) -> Term repr (a->b)
29 Lam1 :: (Term repr a -> Term repr b) -> Term repr (a->b)
30 Var :: String -> Term repr a
31
32 -- Terms useful for prettier dumps.
33 Char :: (TH.Lift tok, Show tok) => tok -> Term repr tok
34 Cons :: Term repr (a -> [a] -> [a])
35 Eq :: Eq.Eq a => Term repr (a -> a -> Bool)
36 {-
37 Const :: Term repr (a -> b -> a)
38 Flip :: Term repr ((a -> b -> c) -> b -> a -> c)
39 Id :: Term repr (a->a)
40 (:$) :: Term repr ((a->b) -> a -> b)
41 -- (:.) :: Term repr ((b->c) -> (a->b) -> a -> c)
42 -- infixr 0 :$
43 -- infixr 9 :.
44 -}
45 infixl 9 :@
46
47 type instance Output (Term repr) = repr
48 instance Trans repr (Term repr) where
49 trans = Term
50
51 instance Termable repr => Termable (Term repr) where
52 lam = Lam
53 lam1 = Lam1
54 (.@) = (:@)
55 cons = Cons
56 eq = Eq
57 unit = Term unit
58 bool b = Term (bool b)
59 char = Char
60 nil = Term nil
61 left = Term left
62 right = Term right
63 nothing = Term nothing
64 just = Term just
65 const = Lam1 (\x -> Lam1 (\_y -> x))
66 flip = Lam1 (\f -> Lam1 (\x -> Lam1 (\y -> f .@ y .@ x)))
67 id = Lam1 (\x -> x)
68 ($) = Lam1 (\f -> Lam1 (\x -> f .@ x))
69 (.) = Lam1 (\f -> Lam1 (\g -> Lam1 (\x -> f .@ (g .@ x))))
70
71 -- | Beta-reduce the left-most outer-most lambda abstraction (aka. normal-order reduction),
72 -- but to avoid duplication of work, only those manually marked
73 -- as using their variable at most once.
74 -- This is mainly to get prettier splices.
75 --
76 -- DOC: Demonstrating Lambda Calculus Reduction, Peter Sestoft, 2001,
77 -- https://www.itu.dk/people/sestoft/papers/sestoft-lamreduce.pdf
78 optimizeTerm :: Term repr a -> Term repr a
79 optimizeTerm = nor
80 where
81 -- | normal-order reduction
82 nor :: Term repr a -> Term repr a
83 nor = \case
84 Lam f -> Lam (nor Fun.. f)
85 Lam1 f -> Lam1 (nor Fun.. f)
86 x :@ y -> case whnf x of
87 Lam1 f -> nor (f y)
88 x' -> nor x' :@ nor y
89 x -> x
90 -- | weak-head normal-form
91 whnf :: Term repr a -> Term repr a
92 whnf = \case
93 x :@ y -> case whnf x of
94 Lam1 f -> whnf (f y)
95 x' -> x' :@ y
96 x -> x
97
98 instance Trans (Term Identity) Identity where
99 trans = \case
100 Cons -> cons
101 Char t -> char t
102 Eq -> eq
103 Term repr -> repr
104 x :@ y -> Identity (runIdentity (trans x) (runIdentity (trans y)))
105 Lam f -> Identity (runIdentity Fun.. trans Fun.. f Fun.. Term Fun.. Identity)
106 Lam1 f -> trans (Lam f)
107 Var{} -> undefined
108 {-
109 Const -> const
110 Flip -> flip
111 Id -> id
112 (:$) -> ($)
113 -}
114 instance Trans (Term TH.CodeQ) TH.CodeQ where
115 -- Superfluous pattern-matches are only here
116 -- for cosmetic concerns when reading *.dump-splices,
117 -- not for optimizing, which is done in 'optimizeTerm'.
118 trans = \case
119 Cons :@ x :@ y -> [|| $$(trans x) : $$(trans y) ||]
120 Cons :@ x -> [|| ($$(trans x) :) ||]
121 Cons -> cons
122 Char t -> char t
123 Eq :@ x :@ y -> [|| $$(trans x) Eq.== $$(trans y) ||]
124 Eq :@ x -> [|| ($$(trans x) Eq.==) ||]
125 Eq -> eq
126 Term repr -> repr
127 -- (:$) :@ x -> [|| ($$(trans x) Fun.$) ||]
128 -- (:.) :@ f :@ g -> [|| \xx -> $$(trans f) ($$(trans g) xx) ||]
129 -- (:.) :@ (:.) -> [|| \f x -> (\g y -> (f x) (g y)) ||]
130 -- (:.) :@ x :@ y -> [|| $$(trans x) Fun.. $$(trans y) ||]
131 -- (:.) :@ x -> [|| ($$(trans x) Fun..) ||]
132 -- (:.) :@ f -> [|| \g x -> $$(trans f) (g x) ||]
133 -- (:.) -> (.)
134 x :@ y -> [|| $$(trans x) $$(trans y) ||]
135 Lam f -> [|| \x -> $$(trans (f (Term [||x||]))) ||]
136 Lam1 f -> trans (Lam f)
137 Var{} -> undefined
138 {-
139 Const -> const
140 Flip -> flip
141 Id -> id
142 (:$) -> ($)
143 -}
144 instance Trans (Term ValueCode) ValueCode where
145 trans = \case
146 Term x -> x
147 Char c -> char c
148 Cons -> cons
149 Eq -> eq
150 (:@) f x -> (.@) (trans f) (trans x)
151 Lam f -> ValueCode
152 { value = value Fun.. trans Fun.. f Fun.. Term Fun.. (`ValueCode` undefined)
153 , code = [|| \x -> $$(code Fun.. trans Fun.. f Fun.. Term Fun.. (undefined `ValueCode`) Fun.$ [||x||]) ||]
154 }
155 Lam1 f -> trans (Lam f)
156 Var{} -> undefined
157 {-
158 Const -> const
159 Flip -> flip
160 Id -> id
161 (:$) -> ($)
162 -}
163 instance Trans (Term ValueCode) (Term TH.CodeQ) where
164 trans = \case
165 Term x -> Term (code x)
166 Char c -> char c
167 Cons -> cons
168 Eq -> eq
169 (:@) f x -> (.@) (trans f) (trans x)
170 Lam f -> Lam (\x -> trans (f (trans x)))
171 Lam1 f -> Lam1 (\x -> trans (f (trans x)))
172 Var v -> Var v
173 {-
174 Const -> const
175 Flip -> flip
176 Id -> id
177 (:$) -> ($)
178 -}
179 instance Trans (Term TH.CodeQ) (Term ValueCode) where
180 trans = \case
181 Term x -> Term (ValueCode undefined x)
182 Char c -> char c
183 Cons -> cons
184 Eq -> eq
185 (:@) f x -> (.@) (trans f) (trans x)
186 Lam f -> Lam (\x -> trans (f (trans x)))
187 Lam1 f -> Lam1 (\x -> trans (f (trans x)))
188 Var v -> Var v
189 {-
190 Const -> const
191 Flip -> flip
192 Id -> id
193 (:$) -> ($)
194 -}