diff --git a/src/Language/Haskell/TH/LetRec.hs b/src/Language/Haskell/TH/LetRec.hs --- a/src/Language/Haskell/TH/LetRec.hs +++ b/src/Language/Haskell/TH/LetRec.hs @@ -15,10 +15,14 @@ import qualified Data.Map.Lazy as Map -- $setup --- >>> :set -XTemplateHaskell +-- >>> :set -XTemplateHaskell -XRankNTypes -XScopedTypeVariables -- >>> import Language.Haskell.TH.Syntax as TH -- >>> import Language.Haskell.TH.Lib as TH -- >>> import Language.Haskell.TH.Ppr as TH +-- >>> let mangleName :: TH.Name -> TH.Name; mangleName n | n == ''() = TH.Name (TH.OccName "Unit") TH.NameS; mangleName (TH.Name occ TH.NameG {}) = TH.Name occ TH.NameS; mangleName n = n +-- >>> import Data.Data (Data, Typeable, cast, gmapT) +-- >>> mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a; mkT f x = maybe x (maybe x id . cast . f) (cast x) +-- >>> let everywhere :: (forall a. Data a => a -> a) -> (forall b. Data b => b -> b); everywhere f = go where go :: forall c. Data c => c -> c; go = f . gmapT go -- | Generate potentially recursive let expression. -- @@ -31,9 +35,8 @@ -- -- The generated let-bindings look like: -- --- >>> TH.ppr <$> trueFalse --- let {goFalse_0 = GHC.Types.False GHC.Types.: goTrue_1; --- goTrue_1 = GHC.Types.True GHC.Types.: goFalse_0} +-- >>> TH.ppr . everywhere (mkT mangleName) <$> trueFalse +-- let {goFalse_0 = False : goTrue_1; goTrue_1 = True : goFalse_0} -- in goTrue_1 -- -- And when spliced it produces a list of alternative 'True' and 'False' values: @@ -48,15 +51,15 @@ -- >>> let fib n = letrecE (\tag -> "fib" ++ show tag) fibRec ($ n) -- -- The generated let-bindings look like: --- >>> TH.ppr <$> fib 7 +-- >>> TH.ppr . everywhere (mkT mangleName) <$> fib 7 -- let {fib0_0 = 1; -- fib1_1 = 1; --- fib2_2 = fib1_1 GHC.Num.+ fib0_0; --- fib3_3 = fib2_2 GHC.Num.+ fib1_1; --- fib4_4 = fib3_3 GHC.Num.+ fib2_2; --- fib5_5 = fib4_4 GHC.Num.+ fib3_3; --- fib6_6 = fib5_5 GHC.Num.+ fib4_4; --- fib7_7 = fib6_6 GHC.Num.+ fib5_5} +-- fib2_2 = fib1_1 + fib0_0; +-- fib3_3 = fib2_2 + fib1_1; +-- fib4_4 = fib3_3 + fib2_2; +-- fib5_5 = fib4_4 + fib3_3; +-- fib6_6 = fib5_5 + fib4_4; +-- fib7_7 = fib6_6 + fib5_5} -- in fib7_7 -- -- And the result is expected: @@ -79,23 +82,23 @@ -- >>> let fib n = typedLetrecE (\tag -> "fib" ++ show tag) (\_ -> Just [t| Int |]) fibRec ($ n) -- -- The generated let-bindings look like: --- >>> TH.ppr <$> fib 7 --- let {fib0_0 :: GHC.Types.Int; +-- >>> TH.ppr . everywhere (mkT mangleName) <$> fib 7 +-- let {fib0_0 :: Int; -- fib0_0 = 1; --- fib1_1 :: GHC.Types.Int; +-- fib1_1 :: Int; -- fib1_1 = 1; --- fib2_2 :: GHC.Types.Int; --- fib2_2 = fib1_1 GHC.Num.+ fib0_0; --- fib3_3 :: GHC.Types.Int; --- fib3_3 = fib2_2 GHC.Num.+ fib1_1; --- fib4_4 :: GHC.Types.Int; --- fib4_4 = fib3_3 GHC.Num.+ fib2_2; --- fib5_5 :: GHC.Types.Int; --- fib5_5 = fib4_4 GHC.Num.+ fib3_3; --- fib6_6 :: GHC.Types.Int; --- fib6_6 = fib5_5 GHC.Num.+ fib4_4; --- fib7_7 :: GHC.Types.Int; --- fib7_7 = fib6_6 GHC.Num.+ fib5_5} +-- fib2_2 :: Int; +-- fib2_2 = fib1_1 + fib0_0; +-- fib3_3 :: Int; +-- fib3_3 = fib2_2 + fib1_1; +-- fib4_4 :: Int; +-- fib4_4 = fib3_3 + fib2_2; +-- fib5_5 :: Int; +-- fib5_5 = fib4_4 + fib3_3; +-- fib6_6 :: Int; +-- fib6_6 = fib5_5 + fib4_4; +-- fib7_7 :: Int; +-- fib7_7 = fib6_6 + fib5_5} -- in fib7_7 -- -- >>> $(fib 7) diff --git a/src/Language/Haskell/TTH/LetRec.hs b/src/Language/Haskell/TTH/LetRec.hs --- a/src/Language/Haskell/TTH/LetRec.hs +++ b/src/Language/Haskell/TTH/LetRec.hs @@ -19,11 +19,17 @@ -- $setup -- >>> :set -XGADTs -XTypeOperators -XDataKinds -XPolyKinds -XRankNTypes -XTypeApplications -- >>> import Control.Monad.Fix (MonadFix) +-- >>> import Data.EqP +-- >>> import Data.OrdP -- >>> import Data.GADT.Compare -- >>> import Data.Type.Equality -- >>> import Language.Haskell.TH.Syntax as TH -- >>> import Language.Haskell.TH.CodeT as TH.CodeT -- >>> import Language.Haskell.TH.Ppr as TH +-- >>> let mangleName :: TH.Name -> TH.Name; mangleName n | n == ''() = TH.Name (TH.OccName "Unit") TH.NameS; mangleName (TH.Name occ TH.NameG {}) = TH.Name occ TH.NameS; mangleName n = n +-- >>> import Data.Data (Data, Typeable, cast, gmapT) +-- >>> mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a; mkT f x = maybe x (maybe x id . cast . f) (cast x) +-- >>> let everywhere :: (forall a. Data a => a -> a) -> (forall b. Data b => b -> b); everywhere f = go where go :: forall c. Data c => c -> c; go = f . gmapT go -- -- >>> :{ -- data NP f xs where @@ -37,7 +43,11 @@ -- data Idx xs x where -- IZ :: Idx (x ': xs) x -- IS :: Idx xs x -> Idx (y ': xs) x +-- instance Eq (Idx xs x) where (==) = defaultEq +-- instance EqP (Idx xs) where eqp = defaultEq -- instance GEq (Idx xs) where geq = defaultGeq +-- instance Ord (Idx xs x) where compare = defaultCompare +-- instance OrdP (Idx xs) where comparep = defaultCompare -- instance GCompare (Idx xs) where -- gcompare IZ IZ = GEQ -- gcompare (IS x) (IS y) = gcompare x y @@ -58,15 +68,14 @@ -- | Generate potentially recursive let expression. -- --- Example of generating a list ofg alternative 'True' and 'False' values. +-- Example of generating a list of alternating 'True' and 'False' values. -- -- >>> let trueFalse = letrecE (\tag -> "go" ++ show tag) (\rec tag -> rec (not tag) >>= \next -> return [|| $$(TH.liftTyped tag) : $$next ||]) (\rec -> rec True) -- -- The generated let-bindings looks like: -- --- >>> TH.ppr <$> TH.unTypeCode trueFalse --- let {goFalse_0 = GHC.Types.False GHC.Types.: goTrue_1; --- goTrue_1 = GHC.Types.True GHC.Types.: goFalse_0} +-- >>> TH.ppr . everywhere (mkT mangleName) <$> TH.unTypeCode trueFalse +-- let {goFalse_0 = False : goTrue_1; goTrue_1 = True : goFalse_0} -- in goTrue_1 -- -- And when spliced it produces a list of alternative 'True' and 'False' values: @@ -93,23 +102,23 @@ -- >>> let fib n = typedLetrecE (\tag -> "fib" ++ show tag) (codeT @Int) fibRec ($ n) -- -- The generated let-bindings look like: --- >>> TH.ppr <$> unTypeCode (fib 7) --- let {fib0_0 :: GHC.Types.Int; +-- >>> TH.ppr . everywhere (mkT mangleName) <$> unTypeCode (fib 7) +-- let {fib0_0 :: Int; -- fib0_0 = 1; --- fib1_1 :: GHC.Types.Int; +-- fib1_1 :: Int; -- fib1_1 = 1; --- fib2_2 :: GHC.Types.Int; --- fib2_2 = fib1_1 GHC.Num.+ fib0_0; --- fib3_3 :: GHC.Types.Int; --- fib3_3 = fib2_2 GHC.Num.+ fib1_1; --- fib4_4 :: GHC.Types.Int; --- fib4_4 = fib3_3 GHC.Num.+ fib2_2; --- fib5_5 :: GHC.Types.Int; --- fib5_5 = fib4_4 GHC.Num.+ fib3_3; --- fib6_6 :: GHC.Types.Int; --- fib6_6 = fib5_5 GHC.Num.+ fib4_4; --- fib7_7 :: GHC.Types.Int; --- fib7_7 = fib6_6 GHC.Num.+ fib5_5} +-- fib2_2 :: Int; +-- fib2_2 = fib1_1 + fib0_0; +-- fib3_3 :: Int; +-- fib3_3 = fib2_2 + fib1_1; +-- fib4_4 :: Int; +-- fib4_4 = fib3_3 + fib2_2; +-- fib5_5 :: Int; +-- fib5_5 = fib4_4 + fib3_3; +-- fib6_6 :: Int; +-- fib6_6 = fib5_5 + fib4_4; +-- fib7_7 :: Int; +-- fib7_7 = fib6_6 + fib5_5} -- in fib7_7 -- -- >>> $$(fib 7) @@ -154,8 +163,8 @@ -- -- We can apply @gen@ to @values@ to get a code expression: -- --- >>> TH.ppr <$> TH.unTypeCode (gen values) --- 'x' GHC.Types.: ('x' GHC.Types.: GHC.Show.show GHC.Types.True) +-- >>> TH.ppr . everywhere (mkT mangleName) <$> TH.unTypeCode (gen values) +-- 'x' : ('x' : show True) -- -- But if @values@ where big, we would potentially duplicate the computations. -- Better to first let-bind them. @@ -166,7 +175,11 @@ -- data Idx xs x where -- IZ :: Idx (x ': xs) x -- IS :: Idx xs x -> Idx (y ': xs) x +-- instance Eq (Idx xs x) where (==) = defaultEq +-- instance EqP (Idx xs) where eqp = defaultEq -- instance GEq (Idx xs) where geq = defaultGeq +-- instance Ord (Idx xs x) where compare = defaultCompare +-- instance OrdP (Idx xs) where comparep = defaultCompare -- instance GCompare (Idx xs) where -- gcompare IZ IZ = GEQ -- gcompare (IS x) (IS y) = gcompare x y @@ -197,9 +210,9 @@ -- -- and use it to bind 'values' before using them in 'gen': -- --- >>> TH.ppr <$> TH.unTypeCode (letNP values gen) --- let {x_0 = GHC.Types.True; x_1 = 'x'} --- in x_1 GHC.Types.: (x_1 GHC.Types.: GHC.Show.show x_0) +-- >>> TH.ppr . everywhere (mkT mangleName) <$> TH.unTypeCode (letNP values gen) +-- let {x_0 = True; x_1 = 'x'} +-- in x_1 : (x_1 : show x_0) -- -- The result of evaluating either expression is the same: -- @@ -252,12 +265,9 @@ -- -- The generated let expression will have type annotations: -- --- >>> TH.ppr <$> TH.unTypeCode (typedLetNP types values gen) --- let {x_0 :: GHC.Types.Bool; --- x_0 = GHC.Types.True; --- x_1 :: GHC.Types.Char; --- x_1 = 'x'} --- in x_1 GHC.Types.: (x_1 GHC.Types.: GHC.Show.show x_0) +-- >>> TH.ppr . everywhere (mkT mangleName) <$> TH.unTypeCode (typedLetNP types values gen) +-- let {x_0 :: Bool; x_0 = True; x_1 :: Char; x_1 = 'x'} +-- in x_1 : (x_1 : show x_0) -- -- The result of evaluating either expression is the same: -- diff --git a/th-letrec.cabal b/th-letrec.cabal --- a/th-letrec.cabal +++ b/th-letrec.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: th-letrec -version: 0.1.1 +version: 0.1.1.1 synopsis: Implicit (recursive) let insertion description: Implicit (recursive) let insertion. @@ -16,16 +16,24 @@ maintainer: Oleg Grenrus category: Template Haskell extra-source-files: CHANGELOG.md -tested-with: GHC ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.3 || ==9.8.1 +tested-with: + GHC ==9.0.2 + || ==9.2.8 + || ==9.4.8 + || ==9.6.7 + || ==9.8.4 + || ==9.10.3 + || ==9.12.4 + || ==9.14.1 library default-language: Haskell2010 build-depends: - , base ^>=4.15.0.0 || ^>=4.16.0.0 || ^>=4.17.0.0 || ^>=4.18.0.0 || ^>=4.19.0.0 + , base ^>=4.15.0.0 || ^>=4.16.0.0 || ^>=4.17.0.0 || ^>=4.18.0.0 || ^>=4.19.0.0 || ^>=4.20.0.0 || ^>=4.21.0.0 || ^>=4.22.0.0 , codet ^>=0.1 - , containers ^>=0.6.4.1 - , some ^>=1.0.4 - , template-haskell ^>=2.17.0.0 || ^>=2.18.0.0 || ^>=2.19.0.0 || ^>=2.20.0.0 || ^>=2.21.0.0 + , containers ^>=0.6.4.1 || ^>=0.7 || ^>=0.8 + , some ^>=1.0.4 || ^>=1.1 + , template-haskell ^>=2.17.0.0 || ^>=2.18.0.0 || ^>=2.19.0.0 || ^>=2.20.0.0 || ^>=2.21.0.0 || ^>=2.22.0.0 || ^>=2.23.0.0 || ^>=2.24.0.0 , transformers ^>=0.5.6.2 || ^>=0.6.1.0 hs-source-dirs: src