src/Symantic/Parser/Grammar/Production.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE StandaloneDeriving #-} -- For prodCon
   3 {-# LANGUAGE TemplateHaskell #-}
   4 {-# LANGUAGE StandaloneDeriving #-}
   5 {-# LANGUAGE DeriveLift #-}
   6 {-# LANGUAGE UndecidableInstances #-}
   7 {-# OPTIONS_GHC -fno-warn-orphans #-}
   8 module Symantic.Parser.Grammar.Production where
   9
  10 import Control.Monad (Monad(..))
  11 import Data.Functor.Identity (Identity(..))
  12 import Data.Functor.Product (Product(..))
  13 import Prelude (Num(..), undefined)
  14 import Text.Show (Show(..), showString)
  15 import Type.Reflection (Typeable)
  16 import qualified Data.Either as Either
  17 import qualified Data.Eq as Eq
  18 import qualified Data.Function as Fun
  19 import qualified Data.Maybe as Maybe
  20 import qualified Language.Haskell.TH as TH
  21 import qualified Language.Haskell.TH.Syntax as TH
  22 import qualified Language.Haskell.TH.Show as TH
  23
  24 import Symantic.Typed.Data
  25 import Symantic.Typed.Lang
  26 import Symantic.Typed.Optim
  27 import Symantic.Typed.Trans
  28
  29 type Production = Product
  30   (SomeData Identity)
  31   (SomeData TH.CodeQ)
  32
  33 {-# INLINE prodValue #-}
  34 prodValue :: Production a -> SomeData Identity a
  35 prodValue (Pair v _) = v
  36 {-# INLINE prodCode #-}
  37 prodCode :: Production a -> SomeData TH.CodeQ a
  38 prodCode (Pair _ c) = c
  39
  40 {-# INLINE production #-}
  41 production :: a -> TH.CodeQ a -> Production a
  42 production v c = Pair
  43   (SomeData (Var (Identity v)))
  44   (SomeData (Var c))
  45
  46 {-# INLINE prod #-}
  47 prod :: TH.Lift a => a -> Production a
  48 prod x = production x [||x||]
  49
  50 {-# INLINE runValue #-}
  51 runValue :: Production a -> a
  52 runValue x = runIdentity (trans x)
  53 {-# INLINE runCode #-}
  54 runCode :: Production a -> TH.CodeQ a
  55 runCode = trans
  56
  57 -- Missing instances in 'Language.Haskell.TH',
  58 -- needed for 'prodCon'.
  59 deriving instance TH.Lift TH.OccName
  60 deriving instance TH.Lift TH.NameFlavour
  61 deriving instance TH.Lift TH.ModName
  62 deriving instance TH.Lift TH.PkgName
  63 deriving instance TH.Lift TH.NameSpace
  64 deriving instance TH.Lift TH.Name
  65
  66 -- | @$(prodCon 'SomeConstructor)@ generates the 'Production' for @SomeConstructor@.
  67 prodCon :: TH.Name -> TH.Q TH.Exp
  68 prodCon name = do
  69   info <- TH.reify name
  70   case info of
  71     TH.DataConI n _ty _pn ->
  72       [| production $(return (TH.ConE n))
  73            (TH.unsafeCodeCoerce (return (TH.ConE $(TH.lift n)))) |]
  74
  75 instance Trans Production Identity where
  76   trans (Pair (SomeData v) _c) = trans v
  77 instance Trans Production TH.CodeQ where
  78   trans (Pair _v (SomeData c)) = trans c
  79
  80 instance Show (SomeData TH.CodeQ a) where
  81   -- The 'Trans' constraint contained in 'SomeData'
  82   -- is 'TH.CodeQ', hence 'Symantic.Typed.View' cannot be used here.
  83   -- Fortunately 'TH.showCode' can be implemented.
  84   showsPrec p = showString Fun.. TH.showCode p Fun.. trans
  85
  86 instance (Abstractable f, Abstractable g) => Abstractable (Product f g) where
  87   -- Those 'undefined' are not unreachables by 'f'
  88   -- but this is the cost to pay for defining this instance.
  89   -- In particular, 'f' must not define the 'TH.CodeQ' part
  90   -- using the 'Identity' part.
  91   lam f = Pair
  92     (lam (\x -> let Pair fx _ = f (Pair x undefined) in fx))
  93     (lam (\y -> let Pair _ fy = f (Pair undefined y) in fy))
  94   lam1 f = Pair
  95     (lam1 (\x -> let Pair fx _ = f (Pair x undefined) in fx))
  96     (lam1 (\y -> let Pair _ fy = f (Pair undefined y) in fy))
  97   const = Pair const const
  98   var = Fun.id
  99   id = Pair id id
 100   flip = Pair flip flip
 101   Pair f1 f2 .@ Pair x1 x2 = Pair (f1 .@x1) (f2 .@x2)
 102   (.) = Pair (.) (.)
 103   ($) = Pair ($) ($)
 104 instance (Num (f a), Num (g a)) => Num (Product f g a) where
 105   Pair x1 x2 + Pair y1 y2 = Pair (x1 + y1) (x2 + y2)
 106   Pair x1 x2 * Pair y1 y2 = Pair (x1 * y1) (x2 * y2)
 107   Pair x1 x2 - Pair y1 y2 = Pair (x1 - y1) (x2 - y2)
 108   abs (Pair x1 x2) = Pair (abs x1) (abs x2)
 109   fromInteger i = Pair (fromInteger i) (fromInteger i)
 110   negate (Pair x1 x2) = Pair (negate x1) (negate x2)
 111   signum (Pair x1 x2) = Pair (signum x1) (signum x2)
 112 instance (Eitherable f, Eitherable g) => Eitherable (Product f g) where
 113   left = Pair left left
 114   right = Pair right right
 115 instance (TH.Lift c, Typeable c) => Constantable c Production where
 116   constant c = Pair (constant c) (constant c)
 117 instance Maybeable Production where
 118   nothing = Pair nothing nothing
 119   just = Pair just just
 120 instance Listable Production where
 121   nil = Pair nil nil
 122   cons = Pair cons cons
 123 instance Equalable Production where
 124   equal = Pair equal equal
 125
 126 optimizeProduction :: Production a -> Production a
 127 optimizeProduction (Pair v c) = Pair (normalOrderReduction v) (normalOrderReduction c)
 128
 129 -- Identity
 130 instance Anythingable Identity
 131 instance Abstractable Identity where
 132   f .@ x = Identity (runIdentity f (runIdentity x))
 133   lam f = Identity (runIdentity Fun.. f Fun.. Identity)
 134   lam1 = lam
 135   var = Fun.id
 136   const = Identity Fun.const
 137   flip = Identity Fun.flip
 138   id = Identity Fun.id
 139   ($) = Identity (Fun.$)
 140   (.) = Identity (Fun..)
 141 instance Constantable c Identity where
 142   constant = Identity
 143 instance Eitherable Identity where
 144   left = Identity Either.Left
 145   right = Identity Either.Right
 146 instance Equalable Identity where
 147   equal = Identity (Eq.==)
 148 instance IfThenElseable Identity where
 149   ifThenElse test ok ko = Identity
 150     (if runIdentity test
 151     then runIdentity ok
 152     else runIdentity ko)
 153 instance Listable Identity where
 154   cons = Identity (:)
 155   nil = Identity []
 156 instance Maybeable Identity where
 157   nothing = Identity Maybe.Nothing
 158   just = Identity Maybe.Just
 159
 160 -- TH.CodeQ
 161 instance Anythingable TH.CodeQ
 162 instance Abstractable TH.CodeQ where
 163   (.@) f x = [|| $$f $$x ||]
 164   lam f = [|| \x -> $$(f [||x||]) ||]
 165   lam1 = lam
 166   var = Fun.id
 167   id = [|| \x -> x ||]
 168   const = [|| Fun.const ||]
 169   flip = [|| \f x y -> f y x ||]
 170   ($) = [|| (Fun.$) ||]
 171   (.) = [|| (Fun..) ||]
 172 instance TH.Lift c => Constantable c TH.CodeQ where
 173   constant c = [|| c ||]
 174 instance Eitherable TH.CodeQ where
 175   left = [|| Either.Left ||]
 176   right = [|| Either.Right ||]
 177 instance Equalable TH.CodeQ where
 178   equal = [|| (Eq.==) ||]
 179 instance IfThenElseable TH.CodeQ where
 180   ifThenElse test ok ko = [|| if $$test then $$ok else $$ko ||]
 181 instance Listable TH.CodeQ where
 182   cons = [|| (:) ||]
 183   nil = [|| [] ||]
 184 instance Maybeable TH.CodeQ where
 185   nothing = [|| Maybe.Nothing ||]
 186   just = [|| Maybe.Just ||]
 187 instance Num a => Num (TH.CodeQ a) where
 188   x + y = [|| $$x + $$y||]
 189   x * y = [|| $$x * $$y||]
 190   x - y = [|| $$x - $$y||]
 191   abs x = [|| abs $$x ||]
 192   fromInteger i = [|| fromInteger $$(TH.liftTyped i) ||]
 193   negate x = [|| negate $$x ||]
 194   signum x = [|| signum $$x ||]