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