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 (Functionable f, Functionable g) => Functionable (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 (Inferable a (SomeData Identity), Inferable a (SomeData TH.CodeQ)) => Inferable a Production where
 113   infer = Pair infer infer
 114 instance Inferable () (SomeData Identity) where
 115   infer = constant ()
 116 instance Inferable () (SomeData TH.CodeQ) where
 117   infer = constant ()
 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 -- Identity
 128 instance Anythingable Identity
 129 instance Abstractable Identity where
 130   f .@ x = Identity (runIdentity f (runIdentity x))
 131   lam f = Identity (runIdentity Fun.. f Fun.. Identity)
 132   lam1 = lam
 133   var = Fun.id
 134 instance Functionable Identity where
 135   const = Identity Fun.const
 136   flip = Identity Fun.flip
 137   id = Identity Fun.id
 138   ($) = Identity (Fun.$)
 139   (.) = Identity (Fun..)
 140 instance Constantable c Identity where
 141   constant = Identity
 142 instance Eitherable Identity where
 143   left = Identity Either.Left
 144   right = Identity Either.Right
 145 instance Equalable Identity where
 146   equal = Identity (Eq.==)
 147 instance IfThenElseable Identity where
 148   ifThenElse test ok ko = Identity
 149     (if runIdentity test
 150     then runIdentity ok
 151     else runIdentity ko)
 152 instance Listable Identity where
 153   cons = Identity (:)
 154   nil = Identity []
 155 instance Maybeable Identity where
 156   nothing = Identity Maybe.Nothing
 157   just = Identity Maybe.Just
 158
 159 -- TH.CodeQ
 160 instance Anythingable TH.CodeQ
 161 instance Abstractable TH.CodeQ where
 162   (.@) f x = [|| $$f $$x ||]
 163   lam f = [|| \x -> $$(f [||x||]) ||]
 164   lam1 = lam
 165   var = Fun.id
 166 instance Functionable TH.CodeQ where
 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 ||]