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.Class
  25 import Symantic.Data
  26 import Symantic.Derive
  27
  28 type Production = Product
  29   (SomeData Identity)
  30   (SomeData TH.CodeQ)
  31
  32 {-# INLINE prodValue #-}
  33 prodValue :: Production a -> SomeData Identity a
  34 prodValue (Pair v _) = v
  35 {-# INLINE prodCode #-}
  36 prodCode :: Production a -> SomeData TH.CodeQ a
  37 prodCode (Pair _ c) = c
  38
  39 {-# INLINE production #-}
  40 production :: a -> TH.CodeQ a -> Production a
  41 production v c = Pair
  42   (SomeData (Var (Identity v)))
  43   (SomeData (Var c))
  44
  45 {-# INLINE prod #-}
  46 prod :: TH.Lift a => a -> Production a
  47 prod x = production x [||x||]
  48
  49 {-# INLINE runValue #-}
  50 runValue :: Production a -> a
  51 runValue (Pair v _c) = runIdentity (derive v)
  52 {-# INLINE runCode #-}
  53 runCode :: Production a -> TH.CodeQ a
  54 runCode (Pair _v c) = derive c
  55
  56 -- Missing instances in 'Language.Haskell.TH',
  57 -- needed for 'prodCon'.
  58 deriving instance TH.Lift TH.OccName
  59 deriving instance TH.Lift TH.NameFlavour
  60 deriving instance TH.Lift TH.ModName
  61 deriving instance TH.Lift TH.PkgName
  62 deriving instance TH.Lift TH.NameSpace
  63 deriving instance TH.Lift TH.Name
  64
  65 -- | @$(prodCon 'SomeConstructor)@ generates the 'Production' for @SomeConstructor@.
  66 prodCon :: TH.Name -> TH.Q TH.Exp
  67 prodCon name = do
  68   info <- TH.reify name
  69   case info of
  70     TH.DataConI n _ty _pn ->
  71       [| production $(return (TH.ConE n))
  72            (TH.unsafeCodeCoerce (return (TH.ConE $(TH.lift n)))) |]
  73
  74 instance Show (SomeData TH.CodeQ a) where
  75   -- The 'Derivable' constraint contained in 'SomeData'
  76   -- is 'TH.CodeQ', hence 'Symantic.View' cannot be used here.
  77   -- Fortunately 'TH.showCode' can be implemented.
  78   showsPrec p = showString Fun.. TH.showCode p Fun.. derive
  79
  80 instance (Abstractable f, Abstractable g) => Abstractable (Product f g) where
  81   -- Those 'undefined' are not unreachables by 'f'
  82   -- but this is the cost to pay for defining this instance.
  83   -- In particular, 'f' must not define the 'TH.CodeQ' part
  84   -- using the 'Identity' part.
  85   lam f = Pair
  86     (lam (\x -> let Pair fx _ = f (Pair x undefined) in fx))
  87     (lam (\y -> let Pair _ fy = f (Pair undefined y) in fy))
  88   lam1 f = Pair
  89     (lam1 (\x -> let Pair fx _ = f (Pair x undefined) in fx))
  90     (lam1 (\y -> let Pair _ fy = f (Pair undefined y) in fy))
  91   Pair f1 f2 .@ Pair x1 x2 = Pair (f1 .@x1) (f2 .@x2)
  92   var = Fun.id
  93 instance (Callable f, Callable g) => Callable (Product f g) where
  94   const = Pair const const
  95   id = Pair id id
  96   flip = Pair flip flip
  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 -- Identity
 122 instance Anythingable Identity
 123 instance Abstractable Identity where
 124   f .@ x = Identity (runIdentity f (runIdentity x))
 125   lam f = Identity (runIdentity Fun.. f Fun.. Identity)
 126   lam1 = lam
 127   var = Fun.id
 128 instance Callable Identity where
 129   const = Identity Fun.const
 130   flip = Identity Fun.flip
 131   id = Identity Fun.id
 132   ($) = Identity (Fun.$)
 133   (.) = Identity (Fun..)
 134 instance Constantable c Identity where
 135   constant = Identity
 136 instance Eitherable Identity where
 137   left = Identity Either.Left
 138   right = Identity Either.Right
 139 instance Equalable Identity where
 140   equal = Identity (Eq.==)
 141 instance IfThenElseable Identity where
 142   ifThenElse test ok ko = Identity
 143     (if runIdentity test
 144     then runIdentity ok
 145     else runIdentity ko)
 146 instance Listable Identity where
 147   cons = Identity (:)
 148   nil = Identity []
 149 instance Maybeable Identity where
 150   nothing = Identity Maybe.Nothing
 151   just = Identity Maybe.Just
 152
 153 -- TH.CodeQ
 154 instance Anythingable TH.CodeQ
 155 instance Abstractable TH.CodeQ where
 156   (.@) f x = [|| $$f $$x ||]
 157   lam f = [|| \x -> $$(f [||x||]) ||]
 158   lam1 = lam
 159   var = Fun.id
 160 instance Callable TH.CodeQ where
 161   id = [|| \x -> x ||]
 162   const = [|| Fun.const ||]
 163   flip = [|| \f x y -> f y x ||]
 164   ($) = [|| (Fun.$) ||]
 165   (.) = [|| (Fun..) ||]
 166 instance TH.Lift c => Constantable c TH.CodeQ where
 167   constant c = [|| c ||]
 168 instance Eitherable TH.CodeQ where
 169   left = [|| Either.Left ||]
 170   right = [|| Either.Right ||]
 171 instance Equalable TH.CodeQ where
 172   equal = [|| (Eq.==) ||]
 173 instance IfThenElseable TH.CodeQ where
 174   ifThenElse test ok ko = [|| if $$test then $$ok else $$ko ||]
 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 ||]