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.Data
  25 import Symantic.Lang
  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   const = Pair const const
  92   var = Fun.id
  93   id = Pair id id
  94   flip = Pair flip flip
  95   Pair f1 f2 .@ Pair x1 x2 = Pair (f1 .@x1) (f2 .@x2)
  96   (.) = Pair (.) (.)
  97   ($) = Pair ($) ($)
  98 instance (Num (f a), Num (g a)) => Num (Product f g a) where
  99   Pair x1 x2 + Pair y1 y2 = Pair (x1 + y1) (x2 + y2)
 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   abs (Pair x1 x2) = Pair (abs x1) (abs x2)
 103   fromInteger i = Pair (fromInteger i) (fromInteger i)
 104   negate (Pair x1 x2) = Pair (negate x1) (negate x2)
 105   signum (Pair x1 x2) = Pair (signum x1) (signum x2)
 106 instance (Eitherable f, Eitherable g) => Eitherable (Product f g) where
 107   left = Pair left left
 108   right = Pair right right
 109 instance (TH.Lift c, Typeable c) => Constantable c Production where
 110   constant c = Pair (constant c) (constant c)
 111 instance Maybeable Production where
 112   nothing = Pair nothing nothing
 113   just = Pair just just
 114 instance Listable Production where
 115   nil = Pair nil nil
 116   cons = Pair cons cons
 117 instance Equalable Production where
 118   equal = Pair equal equal
 119
 120 -- Identity
 121 instance Anythingable Identity
 122 instance Abstractable Identity where
 123   f .@ x = Identity (runIdentity f (runIdentity x))
 124   lam f = Identity (runIdentity Fun.. f Fun.. Identity)
 125   lam1 = lam
 126   var = Fun.id
 127   const = Identity Fun.const
 128   flip = Identity Fun.flip
 129   id = Identity Fun.id
 130   ($) = Identity (Fun.$)
 131   (.) = Identity (Fun..)
 132 instance Constantable c Identity where
 133   constant = Identity
 134 instance Eitherable Identity where
 135   left = Identity Either.Left
 136   right = Identity Either.Right
 137 instance Equalable Identity where
 138   equal = Identity (Eq.==)
 139 instance IfThenElseable Identity where
 140   ifThenElse test ok ko = Identity
 141     (if runIdentity test
 142     then runIdentity ok
 143     else runIdentity ko)
 144 instance Listable Identity where
 145   cons = Identity (:)
 146   nil = Identity []
 147 instance Maybeable Identity where
 148   nothing = Identity Maybe.Nothing
 149   just = Identity Maybe.Just
 150
 151 -- TH.CodeQ
 152 instance Anythingable TH.CodeQ
 153 instance Abstractable TH.CodeQ where
 154   (.@) f x = [|| $$f $$x ||]
 155   lam f = [|| \x -> $$(f [||x||]) ||]
 156   lam1 = lam
 157   var = Fun.id
 158   id = [|| \x -> x ||]
 159   const = [|| Fun.const ||]
 160   flip = [|| \f x y -> f y x ||]
 161   ($) = [|| (Fun.$) ||]
 162   (.) = [|| (Fun..) ||]
 163 instance TH.Lift c => Constantable c TH.CodeQ where
 164   constant c = [|| c ||]
 165 instance Eitherable TH.CodeQ where
 166   left = [|| Either.Left ||]
 167   right = [|| Either.Right ||]
 168 instance Equalable TH.CodeQ where
 169   equal = [|| (Eq.==) ||]
 170 instance IfThenElseable TH.CodeQ where
 171   ifThenElse test ok ko = [|| if $$test then $$ok else $$ko ||]
 172 instance Listable TH.CodeQ where
 173   cons = [|| (:) ||]
 174   nil = [|| [] ||]
 175 instance Maybeable TH.CodeQ where
 176   nothing = [|| Maybe.Nothing ||]
 177   just = [|| Maybe.Just ||]
 178 instance Num a => Num (TH.CodeQ a) where
 179   x + y = [|| $$x + $$y||]
 180   x * y = [|| $$x * $$y||]
 181   x - y = [|| $$x - $$y||]
 182   abs x = [|| abs $$x ||]
 183   fromInteger i = [|| fromInteger $$(TH.liftTyped i) ||]
 184   negate x = [|| negate $$x ||]
 185   signum x = [|| signum $$x ||]