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
 116   -- out of a 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     -}