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