{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE StandaloneDeriving #-} -- For prodCon {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE UndecidableInstances #-} module Symantic.Parser.Grammar.Production where import Control.Monad (Monad(..)) import Data.Bool (Bool(..)) import Data.Char (Char) import Data.Eq (Eq) 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 Symantic.Univariant.Data import Symantic.Univariant.Lang import Symantic.Univariant.Optim import Symantic.Univariant.Reify import Symantic.Univariant.Trans import Symantic.Univariant.View import Debug.Trace 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 x = runIdentity (trans x) {-# INLINE runCode #-} runCode :: Production a -> TH.CodeQ a runCode = trans -- Missing instances in Language.Haskell.TH 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 Trans Production Identity where trans (Pair (SomeData v) _c) = trans v instance Trans Production TH.CodeQ where trans (Pair _v (SomeData c)) = trans c 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) 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 optimizeProduction :: Production a -> Production a optimizeProduction (Pair v c) = Pair (normalOrderReduction v) (normalOrderReduction c) -- 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 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 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||]