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.Optimize
  27 import Symantic.Typed.Derive
  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 (Pair v _c) = runIdentity (derive v)
  53 {-# INLINE runCode #-}
  54 runCode :: Production a -> TH.CodeQ a
  55 runCode (Pair _v c) = derive c
  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 Show (SomeData TH.CodeQ a) where
  76   -- The 'Derivable' constraint contained in 'SomeData'
  77   -- is 'TH.CodeQ', hence 'Symantic.Typed.View' cannot be used here.
  78   -- Fortunately 'TH.showCode' can be implemented.
  79   showsPrec p = showString Fun.. TH.showCode p Fun.. derive
  80
  81 instance (Abstractable f, Abstractable g) => Abstractable (Product f g) where
  82   -- Those 'undefined' are not unreachables by 'f'
  83   -- but this is the cost to pay for defining this instance.
  84   -- In particular, 'f' must not define the 'TH.CodeQ' part
  85   -- using the 'Identity' part.
  86   lam f = Pair
  87     (lam (\x -> let Pair fx _ = f (Pair x undefined) in fx))
  88     (lam (\y -> let Pair _ fy = f (Pair undefined y) in fy))
  89   lam1 f = Pair
  90     (lam1 (\x -> let Pair fx _ = f (Pair x undefined) in fx))
  91     (lam1 (\y -> let Pair _ fy = f (Pair undefined y) in fy))
  92   const = Pair const const
  93   var = Fun.id
  94   id = Pair id id
  95   flip = Pair flip flip
  96   Pair f1 f2 .@ Pair x1 x2 = Pair (f1 .@x1) (f2 .@x2)
  97   (.) = Pair (.) (.)
  98   ($) = Pair ($) ($)
  99 instance (Num (f a), Num (g a)) => Num (Product f g a) where
 100   Pair x1 x2 + Pair y1 y2 = Pair (x1 + y1) (x2 + y2)
 101   Pair x1 x2 * Pair y1 y2 = Pair (x1 * y1) (x2 * y2)
 102   Pair x1 x2 - Pair y1 y2 = Pair (x1 - y1) (x2 - y2)
 103   abs (Pair x1 x2) = Pair (abs x1) (abs x2)
 104   fromInteger i = Pair (fromInteger i) (fromInteger i)
 105   negate (Pair x1 x2) = Pair (negate x1) (negate x2)
 106   signum (Pair x1 x2) = Pair (signum x1) (signum x2)
 107 instance (Eitherable f, Eitherable g) => Eitherable (Product f g) where
 108   left = Pair left left
 109   right = Pair right right
 110 instance (TH.Lift c, Typeable c) => Constantable c Production where
 111   constant c = Pair (constant c) (constant c)
 112 instance Maybeable Production where
 113   nothing = Pair nothing nothing
 114   just = Pair just just
 115 instance Listable Production where
 116   nil = Pair nil nil
 117   cons = Pair cons cons
 118 instance Equalable Production where
 119   equal = Pair equal equal
 120
 121 optimizeProduction :: Production a -> Production a
 122 optimizeProduction (Pair v c) = Pair (normalOrderReduction v) (normalOrderReduction c)
 123
 124 -- Identity
 125 instance Anythingable Identity
 126 instance Abstractable Identity where
 127   f .@ x = Identity (runIdentity f (runIdentity x))
 128   lam f = Identity (runIdentity Fun.. f Fun.. Identity)
 129   lam1 = lam
 130   var = Fun.id
 131   const = Identity Fun.const
 132   flip = Identity Fun.flip
 133   id = Identity Fun.id
 134   ($) = Identity (Fun.$)
 135   (.) = Identity (Fun..)
 136 instance Constantable c Identity where
 137   constant = Identity
 138 instance Eitherable Identity where
 139   left = Identity Either.Left
 140   right = Identity Either.Right
 141 instance Equalable Identity where
 142   equal = Identity (Eq.==)
 143 instance IfThenElseable Identity where
 144   ifThenElse test ok ko = Identity
 145     (if runIdentity test
 146     then runIdentity ok
 147     else runIdentity ko)
 148 instance Listable Identity where
 149   cons = Identity (:)
 150   nil = Identity []
 151 instance Maybeable Identity where
 152   nothing = Identity Maybe.Nothing
 153   just = Identity Maybe.Just
 154
 155 -- TH.CodeQ
 156 instance Anythingable TH.CodeQ
 157 instance Abstractable TH.CodeQ where
 158   (.@) f x = [|| $$f $$x ||]
 159   lam f = [|| \x -> $$(f [||x||]) ||]
 160   lam1 = lam
 161   var = Fun.id
 162   id = [|| \x -> x ||]
 163   const = [|| Fun.const ||]
 164   flip = [|| \f x y -> f y x ||]
 165   ($) = [|| (Fun.$) ||]
 166   (.) = [|| (Fun..) ||]
 167 instance TH.Lift c => Constantable c TH.CodeQ where
 168   constant c = [|| c ||]
 169 instance Eitherable TH.CodeQ where
 170   left = [|| Either.Left ||]
 171   right = [|| Either.Right ||]
 172 instance Equalable TH.CodeQ where
 173   equal = [|| (Eq.==) ||]
 174 instance IfThenElseable TH.CodeQ where
 175   ifThenElse test ok ko = [|| if $$test then $$ok else $$ko ||]
 176 instance Listable TH.CodeQ where
 177   cons = [|| (:) ||]
 178   nil = [|| [] ||]
 179 instance Maybeable TH.CodeQ where
 180   nothing = [|| Maybe.Nothing ||]
 181   just = [|| Maybe.Just ||]
 182 instance Num a => Num (TH.CodeQ a) where
 183   x + y = [|| $$x + $$y||]
 184   x * y = [|| $$x * $$y||]
 185   x - y = [|| $$x - $$y||]
 186   abs x = [|| abs $$x ||]
 187   fromInteger i = [|| fromInteger $$(TH.liftTyped i) ||]
 188   negate x = [|| negate $$x ||]
 189   signum x = [|| signum $$x ||]