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 IfThenElseable Identity where
 150   ifThenElse test ok ko = Identity
 151     (if runIdentity test
 152     then runIdentity ok
 153     else runIdentity ko)
 154 instance Listable Identity where
 155   cons = Identity (:)
 156   nil = Identity []
 157 instance Maybeable Identity where
 158   nothing = Identity Maybe.Nothing
 159   just = Identity Maybe.Just
 160
 161 -- TH.CodeQ
 162 instance Anythingable TH.CodeQ
 163 instance Abstractable TH.CodeQ where
 164   (.@) f x = [|| $$f $$x ||]
 165   lam f = [|| \x -> $$(f [||x||]) ||]
 166   lam1 = lam
 167   var = Fun.id
 168   id = [|| \x -> x ||]
 169   const = [|| Fun.const ||]
 170   flip = [|| \f x y -> f y x ||]
 171   ($) = [|| (Fun.$) ||]
 172   (.) = [|| (Fun..) ||]
 173 instance TH.Lift c => Constantable c TH.CodeQ where
 174   constant c = [|| c ||]
 175 instance Eitherable TH.CodeQ where
 176   left = [|| Either.Left ||]
 177   right = [|| Either.Right ||]
 178 instance Equalable TH.CodeQ where
 179   equal = [|| (Eq.==) ||]
 180 instance IfThenElseable TH.CodeQ where
 181   ifThenElse test ok ko = [|| if $$test then $$ok else $$ko ||]
 182 instance Listable TH.CodeQ where
 183   cons = [|| (:) ||]
 184   nil = [|| [] ||]
 185 instance Maybeable TH.CodeQ where
 186   nothing = [|| Maybe.Nothing ||]
 187   just = [|| Maybe.Just ||]
 188 instance Num a => Num (TH.CodeQ a) where
 189   x + y = [|| $$x + $$y||]
 190   x * y = [|| $$x * $$y||]
 191   x - y = [|| $$x - $$y||]
 192   abs x = [|| abs $$x ||]
 193   fromInteger i = [|| fromInteger $$(TH.liftTyped i) ||]
 194   negate x = [|| negate $$x ||]
 195   signum x = [|| signum $$x ||]