diff --git a/ptera-th.cabal b/ptera-th.cabal --- a/ptera-th.cabal +++ b/ptera-th.cabal @@ -2,12 +2,12 @@ build-type: Custom name: ptera-th -version: 0.6.1.0 +version: 0.7.0.0 license: Apache-2.0 OR MPL-2.0 license-file: LICENSE copyright: (c) 2021 Mizunashi Mana author: Mizunashi Mana -maintainer: mizunashi-mana@noreply.git +maintainer: contact@mizunashi.work category: Parsing homepage: https://github.com/mizunashi-mana/ptera @@ -89,18 +89,18 @@ -dcore-lint build-depends: - base >= 4.14.0 && < 5, + base >= 4.14.0 && < 5, -- project depends - ptera-core >= 0.1.0 && < 0.2, - ptera >= 0.3.0 && < 0.4, - ghc-prim >= 0.6.1 && < 0.7, - containers >= 0.6.0 && < 0.7, - unordered-containers >= 0.2.0 && < 0.3, - array >= 0.5.4 && < 0.6, - membership >= 0.0.1 && < 0.1, - enummapset-th >= 0.6.0 && < 0.7, - template-haskell >= 2.16.0 && < 2.17, + ptera-core >= 0.2.0 && < 0.3, + ptera >= 0.4.0 && < 0.5, + ghc-prim >= 0.8.0 && < 1, + containers >= 0.6.0 && < 0.7, + unordered-containers >= 0.2.0 && < 0.3, + array >= 0.5.4 && < 0.6, + membership >= 0.0.1 && < 0.1, + enummapset >= 0.7.1 && < 1, + template-haskell >= 2.17.0 && < 3, autogen-modules: Paths_ptera_th @@ -109,9 +109,9 @@ custom-setup setup-depends: - base, - Cabal, - cabal-doctest, + base >= 4.14.0 && < 5, + Cabal >= 3.6 && < 4, + cabal-doctest >= 1.0.9 && < 2, library import: diff --git a/src/Language/Parser/Ptera/TH.hs b/src/Language/Parser/Ptera/TH.hs --- a/src/Language/Parser/Ptera/TH.hs +++ b/src/Language/Parser/Ptera/TH.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskellQuotes #-} module Language.Parser.Ptera.TH ( module Language.Parser.Ptera.TH.Syntax, diff --git a/src/Language/Parser/Ptera/TH/ParserLib.hs b/src/Language/Parser/Ptera/TH/ParserLib.hs --- a/src/Language/Parser/Ptera/TH/ParserLib.hs +++ b/src/Language/Parser/Ptera/TH/ParserLib.hs @@ -54,9 +54,9 @@ ST.runST do ST.ST \s0# -> do let !(# s1#, r# #) = Prim.readWord8OffAddr# table# i# s0# - case r# of - 255## -> (# s1#, -1 #) - _ -> (# s1#, Types.I# do Prim.word2Int# r# #) + case Prim.word2Int# do Prim.word8ToWord# r# of + 255# -> (# s1#, -1 #) + ri# -> (# s1#, Types.I# ri# #) pteraTHLookupTable16 :: Int -> Prim.Addr# -> Int -> Int -> Int pteraTHLookupTable16 offset table# s c = do @@ -64,9 +64,9 @@ ST.runST do ST.ST \s0# -> do let !(# s1#, r# #) = Prim.readWord16OffAddr# table# i# s0# - case r# of - 65535## -> (# s1#, -1 #) - _ -> (# s1#, Types.I# do Prim.word2Int# r# #) + case Prim.word2Int# do Prim.word16ToWord# r# of + 65535# -> (# s1#, -1 #) + ri# -> (# s1#, Types.I# ri# #) pteraTHLookupTable32 :: Int -> Prim.Addr# -> Int -> Int -> Int pteraTHLookupTable32 offset table# s c = do @@ -74,10 +74,11 @@ ST.runST do ST.ST \s0# -> do let !(# s1#, r# #) = Prim.readInt32OffAddr# table# i# s0# - (# s1#, Types.I# r# #) + (# s1#, Types.I# do Prim.int32ToInt# r# #) pteraTHUnsafeExtractReduceArgument :: ReduceArgument -> a -pteraTHUnsafeExtractReduceArgument (ReduceArgument x) = Unsafe.unsafeCoerce x +pteraTHUnsafeExtractReduceArgument = \case + ReduceArgument x -> Unsafe.unsafeCoerce x pteraTHUnsafeRunner :: RunnerParser ctx elem () -> Parser ctx rules elem initials pteraTHUnsafeRunner p = Runner.UnsafeRunnerM p diff --git a/src/Language/Parser/Ptera/TH/Pipeline/SRB2ParserDec.hs b/src/Language/Parser/Ptera/TH/Pipeline/SRB2ParserDec.hs --- a/src/Language/Parser/Ptera/TH/Pipeline/SRB2ParserDec.hs +++ b/src/Language/Parser/Ptera/TH/Pipeline/SRB2ParserDec.hs @@ -253,11 +253,11 @@ | n == -1 = replicate unitSize 0xFF | otherwise = error "unsupported" where - mod8bit = case Bits.bitSizeMaybe n of - Nothing -> \x -> x Bits..&. 0xFF + mod8bit x = case Bits.bitSizeMaybe n of + Nothing -> x Bits..&. 0xFF Just bs - | bs <= 8 -> \x -> x - | otherwise -> \x -> x Bits..&. 0xFF + | bs <= 8 -> x + | otherwise -> x Bits..&. 0xFF toTransOpsExp :: OutTransOpsRepr -> TH.Q TH.Exp toTransOpsExp = \case @@ -387,15 +387,16 @@ outputRunnerFn :: TH.Name -> TH.Name -> TH.Name -> TH.Name -> TH.Name -> TH.Name -> TH.Name -> TH.Name -> TH.Q TH.Dec -outputRunnerFn runnerFnName = \ - parserInitialFnName - parserGetTokenNumFnName - parserTransFnName - parserAltKindFnName - parserStateHelpFnName - parserAltHelpFnName - parserActionFnName - -> TH.ValD do TH.VarP runnerFnName +outputRunnerFn + runnerFnName + parserInitialFnName + parserGetTokenNumFnName + parserTransFnName + parserAltKindFnName + parserStateHelpFnName + parserAltHelpFnName + parserActionFnName + = TH.ValD do TH.VarP runnerFnName <$> fmap TH.NormalB [e|pteraTHUnsafeRunner parser|] <*> [d| parser = RunnerParser diff --git a/src/Language/Parser/Ptera/TH/Syntax.hs b/src/Language/Parser/Ptera/TH/Syntax.hs --- a/src/Language/Parser/Ptera/TH/Syntax.hs +++ b/src/Language/Parser/Ptera/TH/Syntax.hs @@ -23,7 +23,6 @@ HTExpList, pattern HNil, pattern (:*), - TExpQ (..), Syntax.ActionTask (..), Syntax.ActionTaskResult (..), Syntax.getAction, @@ -107,7 +106,7 @@ :: LiftType.T ctx => LiftType.T a => TypedExpr rules tokens elem us - -> (HTExpList us -> TH.Q (TH.TExp a)) + -> (HTExpList us -> TH.Code TH.Q a) -> AltM ctx rules tokens elem a e <:> act = unTypedExpr e SafeGrammar.<:> semAct act do getTypesOfExpr e @@ -117,7 +116,7 @@ :: LiftType.T ctx => LiftType.T a => TypedExpr rules tokens elem us - -> (HTExpList us -> TH.Q (TH.TExp (ActionTask ctx a))) + -> (HTExpList us -> TH.Code TH.Q (ActionTask ctx a)) -> AltM ctx rules tokens elem a e <::> act = unTypedExpr e SafeGrammar.<:> semActM act do getTypesOfExpr e @@ -160,19 +159,15 @@ do SafeGrammar.tokensMembership do proxy# @'(tokens, t) -type HTExpList = HFList.T TExpQ - -newtype TExpQ a = TExpQ - { unTExpQ :: TH.Q (TH.TExp a) - } +type HTExpList = HFList.T (TH.Code TH.Q) pattern HNil :: HTExpList '[] pattern HNil = HFList.HFNil {-# COMPLETE HNil #-} -pattern (:*) :: TH.Q (TH.TExp u) -> HTExpList us -> HTExpList (u ': us) -pattern e :* es = HFList.HFCons (TExpQ e) es +pattern (:*) :: TH.Code TH.Q u -> HTExpList us -> HTExpList (u ': us) +pattern e :* es = HFList.HFCons e es infixr 6 :* @@ -189,7 +184,7 @@ semActM :: forall ctx us a . LiftType.T ctx => LiftType.T a - => (HTExpList us -> TH.Q (TH.TExp (ActionTask ctx a))) + => (HTExpList us -> TH.Code TH.Q (ActionTask ctx a)) -> HFList.T TTypeQ us -> SemActM ctx us a semActM f xs0 = UnsafeSemActM go where go = do @@ -202,7 +197,7 @@ let lp0 = pure do TH.ListP [TH.VarP n | n <- ns] [e|\ $(lp) -> case $(le) of $(lp0) -> - $(TH.unType <$> f args) :: ActionTask $(tqCtx) $(tqA) + $(TH.unTypeCode do f args) :: ActionTask $(tqCtx) $(tqA) _ -> error "unreachable: unexpected arguments" |] @@ -214,7 +209,7 @@ HFList.HFCons (TTypeQ t) xs -> do n <- TH.newName "pteraTHSemActArg" let e = pure do TH.VarE n - let arg = TH.unsafeTExpCoerce + let arg = TH.unsafeCodeCoerce [|pteraTHUnsafeExtractReduceArgument $(e) :: $(t)|] (ns, args) <- actArgs xs pure (n:ns, arg :* args) @@ -222,6 +217,6 @@ semAct :: LiftType.T ctx => LiftType.T a - => (HTExpList us -> TH.Q (TH.TExp a)) + => (HTExpList us -> TH.Code TH.Q a) -> HFList.T TTypeQ us -> SemActM ctx us a semAct f = semActM do \us -> [||pteraTHActionTaskPure $$(f us)||]