Production.hs

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE StandaloneDeriving #-} -- For prodCon
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Parser.Grammar.Production where

import Control.Monad (Monad(..))
import Data.Functor.Identity (Identity(..))
import Data.Functor.Product (Product(..))
import Prelude (Num(..), undefined)
import Text.Show (Show(..), showString)
import Type.Reflection (Typeable)
import qualified Data.Either as Either
import qualified Data.Eq as Eq
import qualified Data.Function as Fun
import qualified Data.Maybe as Maybe
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
import qualified Language.Haskell.TH.Show as TH

import Symantic.Data
import Symantic.Lang
import Symantic.Derive

type Production = Product
  (SomeData Identity)
  (SomeData TH.CodeQ)

{-# INLINE prodValue #-}
prodValue :: Production a -> SomeData Identity a
prodValue (Pair v _) = v
{-# INLINE prodCode #-}
prodCode :: Production a -> SomeData TH.CodeQ a
prodCode (Pair _ c) = c

{-# INLINE production #-}
production :: a -> TH.CodeQ a -> Production a
production v c = Pair
  (SomeData (Var (Identity v)))
  (SomeData (Var c))

{-# INLINE prod #-}
prod :: TH.Lift a => a -> Production a
prod x = production x [||x||]

{-# INLINE runValue #-}
runValue :: Production a -> a
runValue (Pair v _c) = runIdentity (derive v)
{-# INLINE runCode #-}
runCode :: Production a -> TH.CodeQ a
runCode (Pair _v c) = derive c

-- Missing instances in 'Language.Haskell.TH',
-- needed for 'prodCon'.
deriving instance TH.Lift TH.OccName
deriving instance TH.Lift TH.NameFlavour
deriving instance TH.Lift TH.ModName
deriving instance TH.Lift TH.PkgName
deriving instance TH.Lift TH.NameSpace
deriving instance TH.Lift TH.Name

-- | @$(prodCon 'SomeConstructor)@ generates the 'Production' for @SomeConstructor@.
prodCon :: TH.Name -> TH.Q TH.Exp
prodCon name = do
  info <- TH.reify name
  case info of
    TH.DataConI n _ty _pn ->
      [| production $(return (TH.ConE n))
           (TH.unsafeCodeCoerce (return (TH.ConE $(TH.lift n)))) |]

instance Show (SomeData TH.CodeQ a) where
  -- The 'Derivable' constraint contained in 'SomeData'
  -- is 'TH.CodeQ', hence 'Symantic.View' cannot be used here.
  -- Fortunately 'TH.showCode' can be implemented.
  showsPrec p = showString Fun.. TH.showCode p Fun.. derive

instance (Abstractable f, Abstractable g) => Abstractable (Product f g) where
  -- Those 'undefined' are not unreachables by 'f'
  -- but this is the cost to pay for defining this instance.
  -- In particular, 'f' must not define the 'TH.CodeQ' part
  -- using the 'Identity' part.
  lam f = Pair
    (lam (\x -> let Pair fx _ = f (Pair x undefined) in fx))
    (lam (\y -> let Pair _ fy = f (Pair undefined y) in fy))
  lam1 f = Pair
    (lam1 (\x -> let Pair fx _ = f (Pair x undefined) in fx))
    (lam1 (\y -> let Pair _ fy = f (Pair undefined y) in fy))
  const = Pair const const
  var = Fun.id
  id = Pair id id
  flip = Pair flip flip
  Pair f1 f2 .@ Pair x1 x2 = Pair (f1 .@x1) (f2 .@x2)
  (.) = Pair (.) (.)
  ($) = Pair ($) ($)
instance (Num (f a), Num (g a)) => Num (Product f g a) where
  Pair x1 x2 + Pair y1 y2 = Pair (x1 + y1) (x2 + y2)
  Pair x1 x2 * Pair y1 y2 = Pair (x1 * y1) (x2 * y2)
  Pair x1 x2 - Pair y1 y2 = Pair (x1 - y1) (x2 - y2)
  abs (Pair x1 x2) = Pair (abs x1) (abs x2)
  fromInteger i = Pair (fromInteger i) (fromInteger i)
  negate (Pair x1 x2) = Pair (negate x1) (negate x2)
  signum (Pair x1 x2) = Pair (signum x1) (signum x2)
instance (Eitherable f, Eitherable g) => Eitherable (Product f g) where
  left = Pair left left
  right = Pair right right
instance (TH.Lift c, Typeable c) => Constantable c Production where
  constant c = Pair (constant c) (constant c)
instance Maybeable Production where
  nothing = Pair nothing nothing
  just = Pair just just
instance Listable Production where
  nil = Pair nil nil
  cons = Pair cons cons
instance Equalable Production where
  equal = Pair equal equal

-- Identity
instance Anythingable Identity
instance Abstractable Identity where
  f .@ x = Identity (runIdentity f (runIdentity x))
  lam f = Identity (runIdentity Fun.. f Fun.. Identity)
  lam1 = lam
  var = Fun.id
  const = Identity Fun.const
  flip = Identity Fun.flip
  id = Identity Fun.id
  ($) = Identity (Fun.$)
  (.) = Identity (Fun..)
instance Constantable c Identity where
  constant = Identity
instance Eitherable Identity where
  left = Identity Either.Left
  right = Identity Either.Right
instance Equalable Identity where
  equal = Identity (Eq.==)
instance IfThenElseable Identity where
  ifThenElse test ok ko = Identity
    (if runIdentity test
    then runIdentity ok
    else runIdentity ko)
instance Listable Identity where
  cons = Identity (:)
  nil = Identity []
instance Maybeable Identity where
  nothing = Identity Maybe.Nothing
  just = Identity Maybe.Just

-- TH.CodeQ
instance Anythingable TH.CodeQ
instance Abstractable TH.CodeQ where
  (.@) f x = [|| $$f $$x ||]
  lam f = [|| \x -> $$(f [||x||]) ||]
  lam1 = lam
  var = Fun.id
  id = [|| \x -> x ||]
  const = [|| Fun.const ||]
  flip = [|| \f x y -> f y x ||]
  ($) = [|| (Fun.$) ||]
  (.) = [|| (Fun..) ||]
instance TH.Lift c => Constantable c TH.CodeQ where
  constant c = [|| c ||]
instance Eitherable TH.CodeQ where
  left = [|| Either.Left ||]
  right = [|| Either.Right ||]
instance Equalable TH.CodeQ where
  equal = [|| (Eq.==) ||]
instance IfThenElseable TH.CodeQ where
  ifThenElse test ok ko = [|| if $$test then $$ok else $$ko ||]
instance Listable TH.CodeQ where
  cons = [|| (:) ||]
  nil = [|| [] ||]
instance Maybeable TH.CodeQ where
  nothing = [|| Maybe.Nothing ||]
  just = [|| Maybe.Just ||]
instance Num a => Num (TH.CodeQ a) where
  x + y = [|| $$x + $$y||]
  x * y = [|| $$x * $$y||]
  x - y = [|| $$x - $$y||]
  abs x = [|| abs $$x ||]
  fromInteger i = [|| fromInteger $$(TH.liftTyped i) ||]
  negate x = [|| negate $$x ||]
  signum x = [|| signum $$x ||]