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 module Symantic.Parser.Grammar.Production where
   8
   9 import Control.Monad (Monad(..))
  10 import Data.Bool (Bool(..))
  11 import Data.Char (Char)
  12 import Data.Eq (Eq)
  13 import Data.Functor.Identity (Identity(..))
  14 import Data.Functor.Product (Product(..))
  15 import Prelude (Num(..), undefined)
  16 import Text.Show (Show(..), showString)
  17 import Type.Reflection (Typeable)
  18 import qualified Data.Either as Either
  19 import qualified Data.Eq as Eq
  20 import qualified Data.Function as Fun
  21 import qualified Data.Maybe as Maybe
  22 import qualified Language.Haskell.TH as TH
  23 import qualified Language.Haskell.TH.Syntax as TH
  24
  25 import Symantic.Typed.Data
  26 import Symantic.Typed.Lang
  27 import Symantic.Typed.Optim
  28 import Symantic.Typed.Reify
  29 import Symantic.Typed.Trans
  30 import Symantic.Typed.View
  31
  32 import Debug.Trace
  33
  34 type Production = Product
  35   (SomeData Identity)
  36   (SomeData TH.CodeQ)
  37
  38 {-# INLINE prodValue #-}
  39 prodValue :: Production a -> SomeData Identity a
  40 prodValue (Pair v _) = v
  41 {-# INLINE prodCode #-}
  42 prodCode :: Production a -> SomeData TH.CodeQ a
  43 prodCode (Pair _ c) = c
  44
  45 {-# INLINE production #-}
  46 production :: a -> TH.CodeQ a -> Production a
  47 production v c = Pair
  48   (SomeData (Var (Identity v)))
  49   (SomeData (Var c))
  50
  51 {-# INLINE prod #-}
  52 prod :: TH.Lift a => a -> Production a
  53 prod x = production x [||x||]
  54
  55 {-# INLINE runValue #-}
  56 runValue :: Production a -> a
  57 runValue x = runIdentity (trans x)
  58 {-# INLINE runCode #-}
  59 runCode :: Production a -> TH.CodeQ a
  60 runCode = trans
  61
  62 -- Missing instances in Language.Haskell.TH
  63 deriving instance TH.Lift TH.OccName
  64 deriving instance TH.Lift TH.NameFlavour
  65 deriving instance TH.Lift TH.ModName
  66 deriving instance TH.Lift TH.PkgName
  67 deriving instance TH.Lift TH.NameSpace
  68 deriving instance TH.Lift TH.Name
  69
  70 -- | @$(prodCon 'SomeConstructor)@ generates the 'Production' for @SomeConstructor@.
  71 prodCon :: TH.Name -> TH.Q TH.Exp
  72 prodCon name = do
  73   info <- TH.reify name
  74   case info of
  75     TH.DataConI n ty _pn ->
  76       [| production $(return (TH.ConE n))
  77            (TH.unsafeCodeCoerce (return (TH.ConE $(TH.lift n)))) |]
  78
  79 instance Trans Production Identity where
  80   trans (Pair (SomeData v) _c) = trans v
  81 instance Trans Production TH.CodeQ where
  82   trans (Pair _v (SomeData c)) = trans c
  83
  84 instance (Abstractable f, Abstractable g) => Abstractable (Product f g) where
  85   -- Those 'undefined' are not unreachables by 'f'
  86   -- but this is the cost to pay for defining this instance.
  87   -- In particular, 'f' must not define the 'TH.CodeQ' part
  88   -- using the 'Identity' part.
  89   lam f = Pair
  90     (lam (\x -> let Pair fx _ = f (Pair x undefined) in fx))
  91     (lam (\y -> let Pair _ fy = f (Pair undefined y) in fy))
  92   lam1 f = Pair
  93     (lam1 (\x -> let Pair fx _ = f (Pair x undefined) in fx))
  94     (lam1 (\y -> let Pair _ fy = f (Pair undefined y) in fy))
  95   const = Pair const const
  96   var = Fun.id
  97   id = Pair id id
  98   flip = Pair flip flip
  99   Pair f1 f2 .@ Pair x1 x2 = Pair (f1 .@x1) (f2 .@x2)
 100   (.) = Pair (.) (.)
 101   ($) = Pair ($) ($)
 102 instance (Num (f a), Num (g a)) => Num (Product f g a) where
 103   Pair x1 x2 + Pair y1 y2 = Pair (x1 + y1) (x2 + y2)
 104 instance (Eitherable f, Eitherable g) => Eitherable (Product f g) where
 105   left = Pair left left
 106   right = Pair right right
 107 instance (TH.Lift c, Typeable c) => Constantable c Production where
 108   constant c = Pair (constant c) (constant c)
 109 instance Maybeable Production where
 110   nothing = Pair nothing nothing
 111   just = Pair just just
 112 instance Listable Production where
 113   nil = Pair nil nil
 114   cons = Pair cons cons
 115 instance Equalable Production where
 116   equal = Pair equal equal
 117
 118 optimizeProduction :: Production a -> Production a
 119 optimizeProduction (Pair v c) = Pair (normalOrderReduction v) (normalOrderReduction c)
 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   const = Identity Fun.const
 129   flip = Identity Fun.flip
 130   id = Identity Fun.id
 131   ($) = Identity (Fun.$)
 132   (.) = Identity (Fun..)
 133 instance Constantable c Identity where
 134   constant = Identity
 135 instance Eitherable Identity where
 136   left = Identity Either.Left
 137   right = Identity Either.Right
 138 instance Equalable Identity where
 139   equal = Identity (Eq.==)
 140 instance Listable Identity where
 141   cons = Identity (:)
 142   nil = Identity []
 143 instance Maybeable Identity where
 144   nothing = Identity Maybe.Nothing
 145   just = Identity Maybe.Just
 146
 147 -- TH.CodeQ
 148 instance Anythingable TH.CodeQ
 149 instance Abstractable TH.CodeQ where
 150   (.@) f x = [|| $$f $$x ||]
 151   lam f = [|| \x -> $$(f [||x||]) ||]
 152   lam1 = lam
 153   var = Fun.id
 154   id = [|| \x -> x ||]
 155   const = [|| Fun.const ||]
 156   flip = [|| \f x y -> f y x ||]
 157   ($) = [|| (Fun.$) ||]
 158   (.) = [|| (Fun..) ||]
 159 instance TH.Lift c => Constantable c TH.CodeQ where
 160   constant c = [|| c ||]
 161 instance Eitherable TH.CodeQ where
 162   left = [|| Either.Left ||]
 163   right = [|| Either.Right ||]
 164 instance Equalable TH.CodeQ where
 165   equal = [|| (Eq.==) ||]
 166 instance Listable TH.CodeQ where
 167   cons = [|| (:) ||]
 168   nil = [|| [] ||]
 169 instance Maybeable TH.CodeQ where
 170   nothing = [|| Maybe.Nothing ||]
 171   just = [|| Maybe.Just ||]
 172 instance Num a => Num (TH.CodeQ a) where
 173   x + y = [|| $$x + $$y||]