src/Symantic/Parser/Grammar/Production.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE TemplateHaskell #-}
   3 {-# LANGUAGE UndecidableInstances #-}
   4 module Symantic.Parser.Grammar.Production where
   5
   6 import Data.Bool (Bool(..))
   7 import Data.Char (Char)
   8 import Data.Eq (Eq)
   9 import Data.Functor.Identity (Identity(..))
  10 import Prelude (undefined)
  11 import Text.Show (Show(..), showString)
  12 import qualified Data.Either as Either
  13 import qualified Data.Eq as Eq
  14 import qualified Data.Function as Fun
  15 import qualified Data.Maybe as Maybe
  16 import qualified Language.Haskell.TH as TH
  17 import qualified Language.Haskell.TH.Syntax as TH
  18 import Type.Reflection (Typeable)
  19
  20 import Symantic.Univariant.Data
  21 import Symantic.Univariant.Lang
  22 import Symantic.Univariant.Optim
  23 import Symantic.Univariant.Trans
  24 import Symantic.Univariant.View
  25
  26 import Debug.Trace
  27
  28 -- * Type 'Production'
  29 data Production a
  30   = Production
  31   { prodValue :: SomeData Identity a
  32   , prodCode :: SomeData TH.CodeQ a
  33   --, prodView :: SomeData View a
  34   }
  35
  36 production :: a -> TH.CodeQ a -> Production a
  37 production v c = Production
  38   { prodValue = SomeData (Var (Identity v))
  39   , prodCode = SomeData (Var c)
  40   }
  41
  42 prod :: TH.Lift a => a -> Production a
  43 prod x = production x [||x||]
  44
  45 runValue :: Production a -> a
  46 runValue x = runIdentity (trans x)
  47 runCode :: Production a -> TH.CodeQ a
  48 runCode = trans
  49
  50 instance Trans Production Identity where
  51   trans Production{prodValue = SomeData x} = trans x
  52 instance Trans Production TH.CodeQ where
  53   trans Production{prodCode = SomeData x} = trans x
  54
  55 instance Abstractable Production where
  56   var = Fun.id
  57   f .@ x = Production
  58     { prodValue = prodValue f .@ prodValue x
  59     , prodCode = prodCode f .@ prodCode x
  60     }
  61   lam f = Production
  62     { prodValue = lam (\x -> prodValue (f Production{prodValue = x}))
  63     , prodCode = lam (\x -> prodCode (f Production{prodCode = x}))
  64     }
  65   lam1 f = Production
  66     { prodValue = lam1 (\x -> prodValue (f Production{prodValue = x}))
  67     , prodCode = lam1 (\x -> prodCode (f Production{prodCode = x}))
  68     }
  69   const = Production const const
  70   ($) = Production ($) ($)
  71   (.) = Production (.) (.)
  72   flip = Production flip flip
  73   id = Production id id
  74 instance Eitherable Production where
  75   left = Production left left
  76   right = Production right right
  77 instance (TH.Lift c, Typeable c) => Constantable c Production where
  78   constant c = Production (constant c) (constant c)
  79 instance Maybeable Production where
  80   nothing = Production nothing nothing
  81   just = Production just just
  82 instance Listable Production where
  83   nil = Production nil nil
  84   cons = Production cons cons
  85 instance Equalable Production where
  86   equal = Production equal equal
  87
  88 optimizeProduction :: Production a -> Production a
  89 optimizeProduction p = Production
  90   { prodValue = normalOrderReduction (prodValue p)
  91   , prodCode = normalOrderReduction (prodCode p)
  92   }
  93
  94 {-
  95 class Tokenable repr where
  96   token :: tok -> repr tok
  97   default token ::
  98     Liftable repr => Tokenable (Output repr) =>
  99     tok -> repr tok
 100   token = lift Fun.. token
 101
 102 instance Show (SomeData ValueCode a) where
 103   showsPrec p (SomeData x) = showsPrec p (trans @_ @View x)
 104 -}
 105
 106 {-
 107 -- * Type 'ValueCode'
 108 data ValueCode a = ValueCode
 109   { value :: a
 110   , code :: TH.CodeQ a
 111   }
 112 instance Trans ValueCode ValueCode where
 113   trans = Fun.id
 114 instance Abstractable ValueCode where
 115   f .@ x = ValueCode
 116     { value = runIdentity (Identity (value f) .@ (Identity (value x)))
 117     , code = code f .@ code x
 118     }
 119   lam f = ValueCode
 120     { value = runIdentity (lam (Identity Fun.. value Fun.. f Fun.. (`ValueCode` undefined) Fun.. runIdentity))
 121     , code = lam (code Fun.. f Fun.. ValueCode undefined)
 122     }
 123   lam1 = lam
 124   const = ValueCode (runIdentity const) const
 125   flip = ValueCode (runIdentity flip) flip
 126   id = ValueCode (runIdentity id) id
 127   ($) = ValueCode (runIdentity ($)) ($)
 128   (.) = ValueCode (runIdentity (.)) (.)
 129 instance Anythingable ValueCode
 130 instance TH.Lift c => Constantable c ValueCode where
 131   constant c = ValueCode (runIdentity (constant c)) (constant c)
 132 instance Listable ValueCode where
 133   cons = ValueCode (runIdentity cons) cons
 134   nil = ValueCode (runIdentity nil) nil
 135 instance Equalable ValueCode where
 136   equal = ValueCode (runIdentity equal) equal
 137 instance Eitherable ValueCode where
 138   left = ValueCode (runIdentity left) left
 139   right = ValueCode (runIdentity right) right
 140 instance Maybeable ValueCode where
 141   nothing = ValueCode (runIdentity nothing) nothing
 142   just = ValueCode (runIdentity just) just
 143 -}
 144
 145 -- Identity
 146 instance Anythingable Identity
 147 instance Abstractable Identity where
 148   f .@ x = Identity (runIdentity f (runIdentity x))
 149   lam f = Identity (runIdentity Fun.. f Fun.. Identity)
 150   lam1 = lam
 151   var = Fun.id
 152   const = Identity Fun.const
 153   flip = Identity Fun.flip
 154   id = Identity Fun.id
 155   ($) = Identity (Fun.$)
 156   (.) = Identity (Fun..)
 157 instance Constantable c Identity where
 158   constant = Identity
 159 instance Eitherable Identity where
 160   left = Identity Either.Left
 161   right = Identity Either.Right
 162 instance Equalable Identity where
 163   equal = Identity (Eq.==)
 164 instance Listable Identity where
 165   cons = Identity (:)
 166   nil = Identity []
 167 instance Maybeable Identity where
 168   nothing = Identity Maybe.Nothing
 169   just = Identity Maybe.Just
 170
 171 -- TH.CodeQ
 172 instance Anythingable TH.CodeQ
 173 instance Abstractable TH.CodeQ where
 174   (.@) f x = [|| $$f $$x ||]
 175   lam f = [|| \x -> $$(f [||x||]) ||]
 176   lam1 = lam
 177   var = Fun.id
 178   id = [|| \x -> x ||]
 179   const = [|| Fun.const ||]
 180   flip = [|| \f x y -> f y x ||]
 181   ($) = [|| (Fun.$) ||]
 182   (.) = [|| (Fun..) ||]
 183 instance TH.Lift c => Constantable c TH.CodeQ where
 184   constant c = [|| c ||]
 185 instance Eitherable TH.CodeQ where
 186   left = [|| Either.Left ||]
 187   right = [|| Either.Right ||]
 188 instance Equalable TH.CodeQ where
 189   equal = [|| (Eq.==) ||]
 190 instance Listable TH.CodeQ where
 191   cons = [|| (:) ||]
 192   nil = [|| [] ||]
 193 instance Maybeable TH.CodeQ where
 194   nothing = [|| Maybe.Nothing ||]
 195   just = [|| Maybe.Just ||]