ptera-th 0.2.0.0 → 0.3.0.0
raw patch · 5 files changed
+148/−21 lines, 5 files
Files
- ptera-th.cabal +2/−1
- src/Language/Parser/Ptera/TH.hs +2/−0
- src/Language/Parser/Ptera/TH/Class/LiftType.hs +54/−0
- src/Language/Parser/Ptera/TH/Syntax.hs +88/−18
- src/Language/Parser/Ptera/TH/Util.hs +2/−2
ptera-th.cabal view
@@ -2,7 +2,7 @@ build-type: Custom name: ptera-th-version: 0.2.0.0+version: 0.3.0.0 license: Apache-2.0 OR MPL-2.0 license-file: LICENSE copyright: (c) 2021 Mizunashi Mana@@ -123,6 +123,7 @@ Language.Parser.Ptera.TH.ParserLib Language.Parser.Ptera.TH.Data.Bits.MaxBit+ Language.Parser.Ptera.TH.Class.LiftType Language.Parser.Ptera.TH.Syntax Language.Parser.Ptera.TH.Util
src/Language/Parser/Ptera/TH.hs view
@@ -6,6 +6,7 @@ module Language.Parser.Ptera.Runner, module Language.Parser.Ptera.TH.ParserLib, module Language.Parser.Ptera.TH.Util,+ module Language.Parser.Ptera.TH.Class.LiftType, genRunner, GenParam (..), defaultCustomCtxTy,@@ -30,6 +31,7 @@ genGrammarToken, genParsePoints, genRules)+import Language.Parser.Ptera.TH.Class.LiftType (LiftType (..)) import qualified Type.Membership as Membership genRunner :: forall initials rules tokens ctx elem
+ src/Language/Parser/Ptera/TH/Class/LiftType.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE TemplateHaskell #-}++module Language.Parser.Ptera.TH.Class.LiftType (+ T,+ LiftType (..),+ typeOf,+) where++import Language.Parser.Ptera.Prelude++import qualified Language.Haskell.TH as TH+import Data.Sequence+import GHC.Real+++type T = LiftType++class LiftType a where+ liftType :: proxy a -> TH.Q TH.Type++typeOf :: LiftType a => a -> TH.Q TH.Type+typeOf x = liftType do Identity x+++instance LiftType () where+ liftType _ = [t|()|]++instance LiftType Int where+ liftType _ = [t|Int|]++instance LiftType Char where+ liftType _ = [t|Char|]++instance LiftType Integer where+ liftType _ = [t|Integer|]++instance LiftType a => LiftType (Ratio a) where+ liftType _ = [t|Ratio $(liftType do Proxy @a)|]++instance LiftType a => LiftType [a] where+ liftType _ = [t|[] $(liftType do Proxy @a)|]++instance LiftType a => LiftType (Maybe a) where+ liftType _ = [t|Maybe $(liftType do Proxy @a)|]++instance (LiftType a, LiftType b) => LiftType (a, b) where+ liftType _ = [t|(,) $(liftType do Proxy @a) $(liftType do Proxy @b)|]++instance (LiftType a, LiftType b, LiftType c) => LiftType (a, b, c) where+ liftType _ =+ [t|(,,) $(liftType do Proxy @a) $(liftType do Proxy @b) $(liftType do Proxy @c)|]++instance LiftType a => LiftType (Seq a) where+ liftType _ = [t|Seq $(liftType do Proxy @a)|]
src/Language/Parser/Ptera/TH/Syntax.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE AllowAmbiguousTypes #-} module Language.Parser.Ptera.TH.Syntax ( T, - HasField (..), SafeGrammar.HasRuleExprField (..), SafeGrammar.TokensTag, SafeGrammar.RulesTag,@@ -15,7 +15,7 @@ SafeGrammar.GrammarToken (..), RuleExprM, AltM,- SafeGrammar.Expr,+ TypedExpr, SemActM (..), semActM, HFList.HFList (..),@@ -38,15 +38,15 @@ SafeGrammar.fixGrammar, SafeGrammar.ruleExpr,- (SafeGrammar.<^>),- SafeGrammar.eps,+ (<^>),+ eps, (<:>), (<::>),- SafeGrammar.var,- SafeGrammar.varA,- SafeGrammar.tok,+ var,+ varA,+ tok, SafeGrammar.TokensMember (..),- SafeGrammar.tokA,+ tokA, ) where import Language.Parser.Ptera.Prelude@@ -55,8 +55,12 @@ import qualified Language.Haskell.TH.Syntax as TH import qualified Language.Parser.Ptera.Data.HFList as HFList import qualified Language.Parser.Ptera.Syntax as Syntax+import qualified Language.Parser.Ptera.Syntax.Grammar as SyntaxGrammar import qualified Language.Parser.Ptera.Syntax.SafeGrammar as SafeGrammar import Language.Parser.Ptera.TH.ParserLib+import qualified Language.Parser.Ptera.TH.Class.LiftType as LiftType+import qualified Language.Parser.Ptera.Data.HEnum as HEnum+import qualified Type.Membership as Membership type T ctx = GrammarM ctx@@ -69,23 +73,88 @@ type RuleExpr = RuleExprM () type Alt = AltM () +data TypedExpr rules tokens elem us = TypedExpr+ { unTypedExpr :: SafeGrammar.Expr rules tokens elem us+ , getTypesOfExpr :: HFList.T TTypeQ us+ } +newtype TTypeQ a = TTypeQ (TH.Q TH.Type)+++eps :: TypedExpr rules tokens elem '[]+eps = TypedExpr+ { unTypedExpr = SafeGrammar.UnsafeExpr HFList.HFNil+ , getTypesOfExpr = HFList.HFNil+ }++(<^>)+ :: TypedExpr rules tokens elem us1 -> TypedExpr rules tokens elem us2+ -> TypedExpr rules tokens elem (HFList.Concat us1 us2)+e1 <^> e2 = TypedExpr+ { unTypedExpr = SafeGrammar.UnsafeExpr+ do HFList.hconcat+ do SafeGrammar.unsafeExpr do unTypedExpr e1+ do SafeGrammar.unsafeExpr do unTypedExpr e2+ , getTypesOfExpr = HFList.hconcat+ do getTypesOfExpr e1+ do getTypesOfExpr e2+ }++infixr 5 <^>++ (<:>)- :: SafeGrammar.Expr rules tokens elem us -> (HTExpList us -> TH.Q (TH.TExp a))+ :: TypedExpr rules tokens elem us -> (HTExpList us -> TH.Q (TH.TExp a)) -> AltM ctx rules tokens elem a-e@(SafeGrammar.UnsafeExpr ue) <:> act = e SafeGrammar.<:> semAct act ue+e <:> act = unTypedExpr e SafeGrammar.<:> semAct act do getTypesOfExpr e infixl 4 <:> (<::>)- :: SafeGrammar.Expr rules tokens elem us+ :: TypedExpr rules tokens elem us -> (HTExpList us -> TH.Q (TH.TExp (ActionTask ctx a))) -> AltM ctx rules tokens elem a-e@(SafeGrammar.UnsafeExpr ue) <::> act = e SafeGrammar.<:> semActM act ue+e <::> act = unTypedExpr e SafeGrammar.<:> semActM act do getTypesOfExpr e infixl 4 <::> +var :: forall v rules tokens elem proxy1 proxy2 a.+ KnownSymbol v => a ~ SafeGrammar.RuleExprReturnType rules v => LiftType.T a =>+ proxy1 rules -> proxy2 v -> TypedExpr rules tokens elem '[a]+var _ pv = TypedExpr+ { unTypedExpr = SafeGrammar.UnsafeExpr do HFList.HFCons u HFList.HFNil+ , getTypesOfExpr = HFList.HFCons tq HFList.HFNil+ } where+ u = SyntaxGrammar.UnitVar do symbolVal pv+ tq = TTypeQ do LiftType.liftType do Proxy @a++varA :: forall v rules tokens elem a.+ KnownSymbol v => a ~ SafeGrammar.RuleExprReturnType rules v => LiftType.T a =>+ TypedExpr rules tokens elem '[a]+varA = var+ do Proxy @rules+ do Proxy @v++tok :: forall t rules tokens elem proxy. LiftType.T elem+ => proxy elem -> Membership.Membership (SafeGrammar.TokensTag tokens) t+ -> TypedExpr rules tokens elem '[elem]+tok pe pm = TypedExpr+ { unTypedExpr = SafeGrammar.UnsafeExpr do HFList.HFCons u HFList.HFNil+ , getTypesOfExpr = HFList.HFCons tq HFList.HFNil+ } where+ u = SyntaxGrammar.UnitToken+ do HEnum.unsafeHEnum do HEnum.henum pm+ tq = TTypeQ do LiftType.liftType pe++tokA :: forall t rules tokens elem.+ LiftType.T elem => SafeGrammar.TokensMember tokens t =>+ TypedExpr rules tokens elem '[elem]+tokA = tok+ do Proxy @elem+ do SafeGrammar.tokensMembership do proxy# @'(tokens, t)++ type HTExpList = HFList.T TExpQ newtype TExpQ a = TExpQ@@ -110,7 +179,7 @@ semActM :: (HTExpList us -> TH.Q (TH.TExp (Syntax.ActionTask ctx a)))- -> HFList.T f us -> SemActM ctx us a+ -> HFList.T TTypeQ us -> SemActM ctx us a semActM f xs0 = UnsafeSemActM go where go = do (ns, args) <- actArgs xs0@@ -125,18 +194,19 @@ error "unreachable: unexpected arguments" |] - actArgs :: HFList.T f us -> TH.Q ([TH.Name], HTExpList us)+ actArgs :: HFList.T TTypeQ us -> TH.Q ([TH.Name], HTExpList us) actArgs = \case HFList.HFNil -> pure ([], HNil)- HFList.HFCons _ xs -> do+ HFList.HFCons (TTypeQ t) xs -> do n <- TH.newName "pteraTHSemActArg"- let ne = TH.unsafeTExpCoerce do pure do TH.VarE n- let arg = [||pteraTHUnsafeExtractReduceArgument $$(ne)||]+ let e = pure do TH.VarE n+ let arg = TH.unsafeTExpCoerce+ [|pteraTHUnsafeExtractReduceArgument $(e) :: $(t)|] (ns, args) <- actArgs xs pure (n:ns, arg :* args) semAct :: (HTExpList us -> TH.Q (TH.TExp a))- -> HFList.T f us -> SemActM ctx us a+ -> HFList.T TTypeQ us -> SemActM ctx us a semAct f = semActM do \us -> [||pteraTHActionTaskPure $$(f us)||]
src/Language/Parser/Ptera/TH/Util.hs view
@@ -163,10 +163,10 @@ let nameTy = pure do TH.LitT do TH.StrTyLit name insts <- [d|- instance HasField $(nameTy) $(rulesTy) ($(ruleExprTy) $(ty)) where- getField x = $(pure do TH.VarE fieldName) x instance HasRuleExprField $(rulesTy) $(nameTy) where type RuleExprReturnType $(rulesTy) $(nameTy) = $(ty)++ getExprField x _ = $(pure do TH.VarE fieldName) x |] buildHasFieldInstances do insts ++ acc