{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE StandaloneDeriving #-} -- For prodCon
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveLift #-}
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 Data.Functor.Product (Product(..))
+import Prelude (Num(..), undefined, error)
import Text.Show (Show(..), showString)
import Type.Reflection (Typeable)
+import qualified Control.Applicative as App
import qualified Data.Either as Either
import qualified Data.Eq as Eq
import qualified Data.Function as Fun
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
import qualified Language.Haskell.TH.Show as TH
+import Data.Kind (Type)
-import Symantic.Data
-import Symantic.Lang
-import Symantic.Derive
+import Symantic.Syntaxes.Classes
+import Symantic.Semantics.Data
+import Symantic.Semantics.Identity
+import Symantic.Syntaxes.Derive
-type Production = Product
- (SomeData Identity)
- (SomeData TH.CodeQ)
+data Production (vs :: [Type]) a where
+ -- TODO: move SomeData from Prod to here?
+ ProdE :: Prod a -> Production vs a
+ --ProdV :: Production (a ': vs) a
+ --ProdN :: Production vs (a->b) -> Production (a ': vs) b
+ --ProdW :: Production vs b -> Production (a ': vs) b
+
+data Prod a = Prod
+ { prodI :: SomeData Identity a
+ , prodQ :: SomeData TH.CodeQ a
+ }
+
+appProd ::
+ Production vs (a -> b) ->
+ Production vs a ->
+ Production vs b
+--ProdE p `appProd` ProdN e = ProdN (ProdE ((.) .@ p) `appProd` e)
+--ProdE p `appProd` ProdV = ProdN (ProdE p)
+--ProdE p `appProd` ProdW e = ProdW (ProdE p `appProd` e)
+ProdE p1 `appProd` ProdE p2 = ProdE (p1 .@ p2)
+--ProdN e `appProd` ProdE p = ProdN (ProdE (flip .@ flip .@ p) `appProd` e)
+--ProdN e `appProd` ProdV = ProdN (ProdE ap `appProd` e `appProd` ProdE id)
+--ProdN e1 `appProd` ProdN e2 = ProdN (ProdE ap `appProd` e1 `appProd` e2)
+--ProdN e1 `appProd` ProdW e2 = ProdN (ProdE flip `appProd` e1 `appProd` e2)
+--ProdV `appProd` ProdE p = ProdN (ProdE (flip .@ id .@ p))
+--ProdV `appProd` ProdN e = ProdN (ProdE (ap .@ id) `appProd` e)
+--ProdV `appProd` ProdW e = ProdN (ProdE (flip .@ id) `appProd` e)
+--ProdW e `appProd` ProdE p = ProdW (e `appProd` ProdE p)
+--ProdW e `appProd` ProdV = ProdN e
+--ProdW e1 `appProd` ProdN e2 = ProdN (ProdE (.) `appProd` e1 `appProd` e2)
+--ProdW e1 `appProd` ProdW e2 = ProdW (e1 `appProd` e2)
+
+-- data Production a where
+-- Prod :: { prodI :: SomeData Identity a
+-- , prodQ :: SomeData TH.CodeQ a
+-- } -> Production a
+-- ProdV :: Production a
+-- ProdN :: Production a -> Production a
+-- ProdW :: Production a -> Production a
{-# INLINE prodValue #-}
-prodValue :: Production a -> SomeData Identity a
-prodValue (Pair v _) = v
+prodValue :: Production '[] a -> SomeData Identity a
+prodValue (ProdE (Prod v _)) = v
{-# INLINE prodCode #-}
-prodCode :: Production a -> SomeData TH.CodeQ a
-prodCode (Pair _ c) = c
+prodCode :: Production '[] a -> SomeData TH.CodeQ a
+prodCode (ProdE (Prod _ c)) = c
{-# INLINE production #-}
-production :: a -> TH.CodeQ a -> Production a
-production v c = Pair
+production :: a -> TH.CodeQ a -> Production vs a
+production v c = ProdE (Prod
(SomeData (Var (Identity v)))
- (SomeData (Var c))
+ (SomeData (Var c)))
{-# INLINE prod #-}
-prod :: TH.Lift a => a -> Production a
+prod :: TH.Lift a => a -> Production vs a
prod x = production x [||x||]
{-# INLINE runValue #-}
-runValue :: Production a -> a
-runValue (Pair v _c) = runIdentity (derive v)
+runValue :: Production '[] a -> a
+runValue (ProdE (Prod v _c)) = runIdentity (derive v)
{-# INLINE runCode #-}
-runCode :: Production a -> TH.CodeQ a
-runCode (Pair _v c) = derive c
+runCode :: Production '[] a -> TH.CodeQ a
+runCode (ProdE (Prod _v c)) = derive c
-- Missing instances in 'Language.Haskell.TH',
-- needed for 'prodCon'.
TH.DataConI n _ty _pn ->
[| production $(return (TH.ConE n))
(TH.unsafeCodeCoerce (return (TH.ConE $(TH.lift n)))) |]
+ _ -> error "[BUG]: impossible prodCon case"
instance Show (SomeData TH.CodeQ a) where
-- The 'Derivable' constraint contained in 'SomeData'
-- 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
+unProdE :: Production '[] a -> Prod a
+unProdE t = case t of ProdE t' -> t'
+
+instance Abstractable (Production '[]) where
+ lam f = ProdE (lam (unProdE Fun.. f Fun.. ProdE))
+instance Abstractable1 (Production '[]) where
+ lam1 f = ProdE (lam1 (unProdE Fun.. f Fun.. ProdE))
+instance Abstractable Prod 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
+ lam f = Prod
+ (lam (\x -> let Prod fx _ = f (Prod x undefined) in fx))
+ (lam (\y -> let Prod _ fy = f (Prod undefined y) in fy))
+instance Abstractable1 Prod where
+ lam1 f = Prod
+ (lam1 (\x -> let Prod fx _ = f (Prod x undefined) in fx))
+ (lam1 (\y -> let Prod _ fy = f (Prod undefined y) in fy))
+instance Instantiable (Production vs) where
+ (.@) = appProd
+instance Instantiable Prod where
+ Prod f1 f2 .@ Prod x1 x2 = Prod (f1 .@ x1) (f2 .@ x2)
+instance Varable Prod where
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
+instance Unabstractable (Production vs) where
+ ap = ProdE ap
+ const = ProdE const
+ id = ProdE id
+ (.) = ProdE (.)
+ flip = ProdE flip
+ ($) = ProdE ($)
+instance Unabstractable Prod where
+ ap = Prod ap ap
+ const = Prod const const
+ id = Prod id id
+ flip = Prod flip flip
+ (.) = Prod (.) (.)
+ ($) = Prod ($) ($)
+instance (Num (SomeData Identity a), Num (SomeData TH.CodeQ a)) => Num (Prod a) where
+ Prod x1 x2 + Prod y1 y2 = Prod (x1 + y1) (x2 + y2)
+ Prod x1 x2 * Prod y1 y2 = Prod (x1 * y1) (x2 * y2)
+ Prod x1 x2 - Prod y1 y2 = Prod (x1 - y1) (x2 - y2)
+ abs (Prod x1 x2) = Prod (abs x1) (abs x2)
+ fromInteger i = Prod (fromInteger i) (fromInteger i)
+ negate (Prod x1 x2) = Prod (negate x1) (negate x2)
+ signum (Prod x1 x2) = Prod (signum x1) (signum x2)
+instance Eitherable (Production vs) where
+ either = ProdE either
+ left = ProdE left
+ right = ProdE right
+instance Eitherable Prod where
+ either = Prod either either
+ left = Prod left left
+ right = Prod right right
+instance (TH.Lift c, Typeable c) => Constantable c (Production vs) where
+ constant c = ProdE (constant c)
+instance (TH.Lift c, Typeable c) => Constantable c Prod where
+ constant c = Prod (constant c) (constant c)
+instance (Inferable a (SomeData Identity), Inferable a (SomeData TH.CodeQ)) => Inferable a (Production vs) where
+ infer = ProdE infer
+instance (Inferable a (SomeData Identity), Inferable a (SomeData TH.CodeQ)) => Inferable a Prod where
+ infer = Prod infer infer
+instance Maybeable (Production vs) where
+ nothing = ProdE nothing
+ just = ProdE just
+instance Maybeable Prod where
+ nothing = Prod nothing nothing
+ just = Prod just just
+instance Listable (Production vs) where
+ nil = ProdE nil
+ cons = ProdE cons
+instance Listable Prod where
+ nil = Prod nil nil
+ cons = Prod cons cons
+instance Equalable (Production vs) where
+ equal = ProdE equal
+instance Equalable Prod where
+ equal = Prod equal equal
+instance Inferable () (SomeData Identity) where
+ infer = constant ()
+instance Inferable () (SomeData TH.CodeQ) where
+ infer = constant ()
-- TH.CodeQ
instance Anythingable TH.CodeQ
instance Abstractable TH.CodeQ where
- (.@) f x = [|| $$f $$x ||]
lam f = [|| \x -> $$(f [||x||]) ||]
- lam1 = lam
+instance Instantiable TH.CodeQ where
+ f .@ x = [|| $$f $$x ||]
+instance Abstractable1 TH.CodeQ where
+ lam1 f = [|| \u -> $$(f [||u||]) ||]
+instance Varable TH.CodeQ where
var = Fun.id
- id = [|| \x -> x ||]
+instance Unabstractable TH.CodeQ where
+ ap = [|| (App.<*>) ||]
+ id = [|| Fun.id ||]
const = [|| Fun.const ||]
- flip = [|| \f x y -> f y x ||]
+ flip = [|| Fun.flip ||]
($) = [|| (Fun.$) ||]
(.) = [|| (Fun..) ||]
instance TH.Lift c => Constantable c TH.CodeQ where
constant c = [|| c ||]
instance Eitherable TH.CodeQ where
+ either = [|| Either.either ||]
left = [|| Either.Left ||]
right = [|| Either.Right ||]
instance Equalable TH.CodeQ where
sourcephile / git / haskell / symantic-parser.git / blobdiff