src/Symantic/Parser/Grammar/Production.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE TemplateHaskell #-}
   3 {-# LANGUAGE StandaloneDeriving #-}
   4 {-# LANGUAGE DeriveLift #-}
   5 {-# LANGUAGE UndecidableInstances #-}
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 module Symantic.Parser.Grammar.Production where
   8
   9 import Control.Monad (Monad(..))
  10 --import Data.Functor.Product (Product(..))
  11 import Prelude (Num(..), undefined, error)
  12 import Text.Show (Show(..), showString)
  13 import Type.Reflection (Typeable)
  14 import qualified Control.Applicative as App
  15 import qualified Data.Either as Either
  16 import qualified Data.Eq as Eq
  17 import qualified Data.Function as Fun
  18 import qualified Data.Maybe as Maybe
  19 import qualified Language.Haskell.TH as TH
  20 import qualified Language.Haskell.TH.Syntax as TH
  21 import qualified Language.Haskell.TH.Show as TH
  22 import Data.Kind (Type)
  23
  24 import Symantic.Syntaxes.Classes
  25 import Symantic.Semantics.Data
  26 import Symantic.Semantics.Identity
  27 import Symantic.Syntaxes.Derive
  28
  29 data Production (vs :: [Type]) a where
  30   -- TODO: move SomeData from Prod to here?
  31   ProdE :: Prod a -> Production vs a
  32   --ProdV :: Production (a ': vs) a
  33   --ProdN :: Production vs (a->b) -> Production (a ': vs) b
  34   --ProdW :: Production vs b -> Production (a ': vs) b
  35
  36 instance Show (Production '[] a) where
  37   showsPrec p x = showsPrec p (normalOrderReduction (prodCode x))
  38 instance Show (SomeData TH.CodeQ a) where
  39   -- The 'Derivable' constraint contained in 'SomeData'
  40   -- is 'TH.CodeQ', hence 'Symantic.View' cannot be used here.
  41   -- Fortunately 'TH.showCode' can be implemented.
  42   showsPrec p = showString Fun.. TH.showCode p Fun.. derive
  43
  44
  45
  46 data Prod a = Prod
  47   { prodI :: SomeData Identity a
  48   , prodQ :: SomeData TH.CodeQ a
  49   }
  50
  51 appProd ::
  52   Production vs (a -> b) ->
  53   Production vs a ->
  54   Production vs b
  55 --ProdE p `appProd` ProdN e = ProdN (ProdE ((.) .@ p) `appProd` e)
  56 --ProdE p `appProd` ProdV = ProdN (ProdE p)
  57 --ProdE p `appProd` ProdW e = ProdW (ProdE p `appProd` e)
  58 ProdE p1 `appProd` ProdE p2 = ProdE (p1 .@ p2)
  59 --ProdN e `appProd` ProdE p = ProdN (ProdE (flip .@ flip .@ p) `appProd` e)
  60 --ProdN e `appProd` ProdV = ProdN (ProdE ap `appProd` e `appProd` ProdE id)
  61 --ProdN e1 `appProd` ProdN e2 = ProdN (ProdE ap `appProd` e1 `appProd` e2)
  62 --ProdN e1 `appProd` ProdW e2 = ProdN (ProdE flip `appProd` e1 `appProd` e2)
  63 --ProdV `appProd` ProdE p = ProdN (ProdE (flip .@ id .@ p))
  64 --ProdV `appProd` ProdN e = ProdN (ProdE (ap .@ id) `appProd` e)
  65 --ProdV `appProd` ProdW e = ProdN (ProdE (flip .@ id) `appProd` e)
  66 --ProdW e `appProd` ProdE p = ProdW (e `appProd` ProdE p)
  67 --ProdW e `appProd` ProdV = ProdN e
  68 --ProdW e1 `appProd` ProdN e2 = ProdN (ProdE (.) `appProd` e1 `appProd` e2)
  69 --ProdW e1 `appProd` ProdW e2 = ProdW (e1 `appProd` e2)
  70
  71 -- data Production a where
  72 --   Prod :: { prodI :: SomeData Identity a
  73 --           , prodQ :: SomeData TH.CodeQ a
  74 --           } -> Production a
  75 --   ProdV :: Production a
  76 --   ProdN :: Production a -> Production a
  77 --   ProdW :: Production a -> Production a
  78
  79 {-# INLINE prodValue #-}
  80 prodValue :: Production '[] a -> SomeData Identity a
  81 prodValue (ProdE (Prod v _)) = v
  82 {-# INLINE prodCode #-}
  83 prodCode :: Production '[] a -> SomeData TH.CodeQ a
  84 prodCode (ProdE (Prod _ c)) = c
  85
  86 {-# INLINE production #-}
  87 production :: a -> TH.CodeQ a -> Production vs a
  88 production v c = ProdE (Prod
  89   (SomeData (Var (Identity v)))
  90   (SomeData (Var c)))
  91
  92 {-# INLINE prod #-}
  93 prod :: TH.Lift a => a -> Production vs a
  94 prod x = production x [||x||]
  95
  96 {-# INLINE runValue #-}
  97 runValue :: Production '[] a -> a
  98 runValue (ProdE (Prod v _c)) = runIdentity (derive v)
  99 {-# INLINE runCode #-}
 100 runCode :: Production '[] a -> TH.CodeQ a
 101 runCode (ProdE (Prod _v c)) = derive c
 102
 103 -- Missing instances in 'Language.Haskell.TH',
 104 -- needed for 'prodCon'.
 105 deriving instance TH.Lift TH.OccName
 106 deriving instance TH.Lift TH.NameFlavour
 107 deriving instance TH.Lift TH.ModName
 108 deriving instance TH.Lift TH.PkgName
 109 deriving instance TH.Lift TH.NameSpace
 110 deriving instance TH.Lift TH.Name
 111
 112 -- | @$(prodCon 'SomeConstructor)@ generates the 'Production' for @SomeConstructor@.
 113 prodCon :: TH.Name -> TH.Q TH.Exp
 114 prodCon name = do
 115   info <- TH.reify name
 116   case info of
 117     TH.DataConI n _ty _pn ->
 118       [| production $(return (TH.ConE n))
 119            (TH.unsafeCodeCoerce (return (TH.ConE $(TH.lift n)))) |]
 120     _ -> error "[BUG]: impossible prodCon case"
 121
 122 unProdE :: Production '[] a -> Prod a
 123 unProdE t = case t of ProdE t' -> t'
 124
 125 instance Abstractable (Production '[]) where
 126   lam f = ProdE (lam (unProdE Fun.. f Fun.. ProdE))
 127 instance Abstractable1 (Production '[]) where
 128   lam1 f = ProdE (lam1 (unProdE Fun.. f Fun.. ProdE))
 129 instance Abstractable Prod where
 130   -- Those 'undefined' are not unreachables by 'f'
 131   -- but this is the cost to pay for defining this instance.
 132   -- In particular, 'f' must not define the 'TH.CodeQ' part
 133   -- using the 'Identity' part.
 134   lam f = Prod
 135     (lam (\x -> let Prod fx _ = f (Prod x undefined) in fx))
 136     (lam (\y -> let Prod _ fy = f (Prod undefined y) in fy))
 137 instance Abstractable1 Prod where
 138   lam1 f = Prod
 139     (lam1 (\x -> let Prod fx _ = f (Prod x undefined) in fx))
 140     (lam1 (\y -> let Prod _ fy = f (Prod undefined y) in fy))
 141 instance Instantiable (Production vs) where
 142   (.@) = appProd
 143 instance Instantiable Prod where
 144   Prod f1 f2 .@ Prod x1 x2 = Prod (f1 .@ x1) (f2 .@ x2)
 145 instance Varable Prod where
 146   var = Fun.id
 147 instance Unabstractable (Production vs) where
 148   ap = ProdE ap
 149   const = ProdE const
 150   id = ProdE id
 151   (.) = ProdE (.)
 152   flip = ProdE flip
 153   ($) = ProdE ($)
 154 instance Unabstractable Prod where
 155   ap = Prod ap ap
 156   const = Prod const const
 157   id = Prod id id
 158   flip = Prod flip flip
 159   (.) = Prod (.) (.)
 160   ($) = Prod ($) ($)
 161 instance (Num (SomeData Identity a), Num (SomeData TH.CodeQ a)) => Num (Prod a) where
 162   Prod x1 x2 + Prod y1 y2 = Prod (x1 + y1) (x2 + y2)
 163   Prod x1 x2 * Prod y1 y2 = Prod (x1 * y1) (x2 * y2)
 164   Prod x1 x2 - Prod y1 y2 = Prod (x1 - y1) (x2 - y2)
 165   abs (Prod x1 x2) = Prod (abs x1) (abs x2)
 166   fromInteger i = Prod (fromInteger i) (fromInteger i)
 167   negate (Prod x1 x2) = Prod (negate x1) (negate x2)
 168   signum (Prod x1 x2) = Prod (signum x1) (signum x2)
 169 instance Eitherable (Production vs) where
 170   either = ProdE either
 171   left = ProdE left
 172   right = ProdE right
 173 instance Eitherable Prod where
 174   either = Prod either either
 175   left = Prod left left
 176   right = Prod right right
 177 instance (TH.Lift c, Typeable c) => Constantable c (Production vs) where
 178   constant c = ProdE (constant c)
 179 instance (TH.Lift c, Typeable c) => Constantable c Prod where
 180   constant c = Prod (constant c) (constant c)
 181 instance (Inferable a (SomeData Identity), Inferable a (SomeData TH.CodeQ)) => Inferable a (Production vs) where
 182   infer = ProdE infer
 183 instance (Inferable a (SomeData Identity), Inferable a (SomeData TH.CodeQ)) => Inferable a Prod where
 184   infer = Prod infer infer
 185 instance Maybeable (Production vs) where
 186   nothing = ProdE nothing
 187   just = ProdE just
 188 instance Maybeable Prod where
 189   nothing = Prod nothing nothing
 190   just = Prod just just
 191 instance Listable (Production vs) where
 192   nil = ProdE nil
 193   cons = ProdE cons
 194 instance Listable Prod where
 195   nil = Prod nil nil
 196   cons = Prod cons cons
 197 instance Equalable (Production vs) where
 198   equal = ProdE equal
 199 instance Equalable Prod where
 200   equal = Prod equal equal
 201 instance Inferable () (SomeData Identity) where
 202   infer = constant ()
 203 instance Inferable () (SomeData TH.CodeQ) where
 204   infer = constant ()
 205
 206 -- TH.CodeQ
 207 instance Anythingable TH.CodeQ
 208 instance Abstractable TH.CodeQ where
 209   lam f = [|| \x -> $$(f [||x||]) ||]
 210 instance Instantiable TH.CodeQ where
 211   f .@ x = [|| $$f $$x ||]
 212 instance Abstractable1 TH.CodeQ where
 213   lam1 f = [|| \u -> $$(f [||u||]) ||]
 214 instance Varable TH.CodeQ where
 215   var = Fun.id
 216 instance Unabstractable TH.CodeQ where
 217   ap = [|| (App.<*>) ||]
 218   id = [|| Fun.id ||]
 219   const = [|| Fun.const ||]
 220   flip = [|| Fun.flip ||]
 221   ($) = [|| (Fun.$) ||]
 222   (.) = [|| (Fun..) ||]
 223 instance TH.Lift c => Constantable c TH.CodeQ where
 224   constant c = [|| c ||]
 225 instance Eitherable TH.CodeQ where
 226   either = [|| Either.either ||]
 227   left = [|| Either.Left ||]
 228   right = [|| Either.Right ||]
 229 instance Equalable TH.CodeQ where
 230   equal = [|| (Eq.==) ||]
 231 instance IfThenElseable TH.CodeQ where
 232   ifThenElse test ok ko = [|| if $$test then $$ok else $$ko ||]
 233 instance Listable TH.CodeQ where
 234   cons = [|| (:) ||]
 235   nil = [|| [] ||]
 236 instance Maybeable TH.CodeQ where
 237   nothing = [|| Maybe.Nothing ||]
 238   just = [|| Maybe.Just ||]
 239 instance Num a => Num (TH.CodeQ a) where
 240   x + y = [|| $$x + $$y||]
 241   x * y = [|| $$x * $$y||]
 242   x - y = [|| $$x - $$y||]
 243   abs x = [|| abs $$x ||]
 244   fromInteger i = [|| fromInteger $$(TH.liftTyped i) ||]
 245   negate x = [|| negate $$x ||]
 246   signum x = [|| signum $$x ||]