packages feed

th-letrec (empty) → 0.1

raw patch · 5 files changed

+305/−0 lines, 5 filesdep +basedep +containersdep +some

Dependencies added: base, containers, some, template-haskell, transformers

Files

+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## 0.1++* First version
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2022, Oleg Grenrus++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Oleg Grenrus nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ src/Language/Haskell/TH/LetRec.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE RecursiveDo         #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Language.Haskell.TH.LetRec (+    letrecE,+) where++import Control.Monad.Fix              (MonadFix)+import Control.Monad.Trans.Class      (lift)+import Control.Monad.Trans.State.Lazy (StateT, get, modify, runStateT)+import Language.Haskell.TH.Lib        (letE, normalB, valD, varE, varP)+import Language.Haskell.TH.Syntax     (Exp, Name, Quote (newName))++import qualified Data.Map.Lazy as Map++-- $setup+-- >>> :set -XTemplateHaskell+-- >>> import Language.Haskell.TH.Syntax as TH+-- >>> import Language.Haskell.TH.Lib    as TH+-- >>> import Language.Haskell.TH.Ppr    as TH++-- | Generate potentially recursive let expression.+--+-- The 'Monad' constraint in generators forces to sequence+-- binding generation calls, thus allowing to do lazy binding generation.+--+-- 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.lift tag) : $next |]) ($ True)+--+-- 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}+--  in goTrue_1+--+-- And when spliced it produces a list of alternative 'True' and 'False' values:+--+-- >>> take 10 $trueFalse+-- [True,False,True,False,True,False,True,False,True,False]+--+-- Another example where dynamic nature is visible is generating+-- fibonacci numbers:+--+-- >>> let fibRec rec tag = case tag of { 0 -> return [| 1 |]; 1 -> return [| 1 |]; _ -> do { minus1 <- rec (tag - 1); minus2 <- rec (tag - 2); return [| $minus1 + $minus2 |] }}+-- >>> let fib n = letrecE (\tag -> "fib" ++ show tag) fibRec ($ n)+--+-- The generated let-bindings look like:+-- >>> TH.ppr <$> 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}+--  in fib7_7+--+-- And the result is expected:+--+-- >>> $(fib 7)+-- 21+--+letrecE+    :: forall q tag. (Ord tag, Quote q, MonadFix q)+    => (tag -> String)                                                   -- ^ tag naming function+    -> (forall m. Monad m => (tag -> m (q Exp)) -> (tag -> m (q Exp)))   -- ^ bindings generator (with recursive function)+    -> (forall m. Monad m => (tag -> m (q Exp)) -> m (q Exp))            -- ^ final expression generator+    -> q Exp                                                             -- ^ generated let expression.+letrecE nameOf recf exprf = do+    (expr0, bindings) <- runStateT (exprf loop) Map.empty+    letE+        [ valD (varP name) (normalB expr) []+        | (_tag, (name, expr)) <- Map.toList bindings+        ]+        expr0+  where+    loop :: tag -> StateT (Map.Map tag (Name, q Exp)) q (q Exp)+    loop tag = do+        m <- get+        case Map.lookup tag m of+            -- if name is already generated, return it.+            Just (name, _exp) -> return (varE name)++            -- otherwise generate new name, and insert it into the loop.+            Nothing -> mdo+                name <- lift (newName (nameOf tag))+                modify (Map.insert tag (name, expr))+                expr <- recf loop tag+                return (varE name)
+ src/Language/Haskell/TTH/LetRec.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Language.Haskell.TTH.LetRec (+    letrecE,+    letrecH,+) where++import Control.Monad.Fix          (MonadFix)+import Data.GADT.Compare          (GCompare)+import Data.Some                  (Some (..))+import Language.Haskell.TH.Syntax (Code, Quote, unTypeCode, unsafeCodeCoerce)++import qualified Language.Haskell.TH.LetRec as TH.LetRec++-- $setup+-- >>> :set -XGADTs -XTypeOperators -XDataKinds -XPolyKinds -XRankNTypes+-- >>> import Control.Monad.Fix (MonadFix)+-- >>> import Data.GADT.Compare+-- >>> import Data.Type.Equality+-- >>> import Language.Haskell.TH.Syntax as TH+-- >>> import Language.Haskell.TH.Ppr    as TH++-- | Generate potentially recursive let expression.+--+-- Example of generating a list ofg alternative '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}+--  in goTrue_1+--+-- And when spliced it produces a list of alternative 'True' and 'False' values:+--+-- >>> take 10 $$trueFalse+-- [True,False,True,False,True,False,True,False,True,False]+--+letrecE+    :: forall q tag r a. (Ord tag, Quote q, MonadFix q)+    => (forall. tag -> String)                                                 -- ^ tag naming function+    -> (forall m. Monad m => (tag -> m (Code q a)) -> (tag -> m (Code q a)))   -- ^ bindings generator (with recursive function)+    -> (forall m. Monad m => (tag -> m (Code q a)) -> m (Code q r))            -- ^ final expression generator+    -> Code q r                                                                -- ^ generated let expression+letrecE nameOf bindf exprf = unsafeCodeCoerce $ TH.LetRec.letrecE+    nameOf+    (\recf tag -> unTypeCode <$> bindf (\tag' -> unsafeCodeCoerce <$> recf tag') tag)+    (\recf     -> unTypeCode <$> exprf (\tag' -> unsafeCodeCoerce <$> recf tag'))++-- | Generate potentially recursive let expression with heterogenously typed bindings.+--+-- A simple example is consider a case where you have a @NP@ (from @sop-core@) of @Code@ values+--+-- >>> :{+-- data NP f xs where+--    Nil  :: NP f '[]+--    (:*) :: f x -> NP f xs -> NP f (x : xs)+-- infixr 5 :*+-- :}+--+-- >>> :{+-- let values :: TH.Quote q => NP (Code q) '[ Bool, Char ]+--     values = [|| True ||] :* [|| 'x' ||] :* Nil+-- :}+--+-- and function from that to a single @Code@+--+-- >>> :{+-- let gen :: TH.Quote q => NP (Code q) '[ Bool, Char ] -> Code q String+--     gen (x :* y :* Nil) = [|| $$y : $$y : show $$x ||]+-- :}+--+-- 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)+--+-- But if @values@ where big, we would potentially duplicate the computations.+-- Better to first let-bind them.+--+-- We'll need a type to act as a tag:+--+-- >>> :{+-- data Idx xs x where+--    IZ :: Idx (x ': xs) x+--    IS :: Idx xs x -> Idx (y ': xs) x+-- instance GEq (Idx xs) where geq = defaultGeq+-- instance GCompare (Idx xs) where+--     gcompare IZ     IZ     = GEQ+--     gcompare (IS x) (IS y) = gcompare x y+--     gcompare IZ     (IS _) = GLT+--     gcompare (IS _) IZ     = GGT+-- :}+--+-- Using @Idx@ we can index @NP@ values:+--+-- >>> :{+-- let index :: NP f xs -> Idx xs x -> f x+--     index (x :* _)  IZ     = x+--     index (_ :* xs) (IS i) = index xs i+-- :}+--+-- And with some extra utilities+--+-- >>> mapNP :: (forall x. f x -> g x) -> NP f xs -> NP g xs; mapNP _ Nil = Nil; mapNP f (x :* xs) = f x :* mapNP f xs+-- >>> traverseNP :: Applicative m => (forall x. f x -> m (g x)) -> NP f xs -> m (NP g xs); traverseNP _ Nil = pure Nil; traverseNP f (x :* xs) = (:*) <$> f x <*> traverseNP f xs+-- >>> indices :: NP f xs -> NP (Idx xs) xs; indices Nil = Nil; indices (_ :* xs) = IZ :* mapNP IS (indices xs) -- first argument acts as list singleton+--+-- we can make a combinator for generating dynamic let-expression:+--+-- >>> :{+-- let letNP :: (Quote q, MonadFix q) => NP (Code q) xs -> (NP (Code q) xs -> Code q r) -> Code q r+--     letNP vals g = letrecH (\_ -> "x") (\_rec idx -> return (index vals idx)) (\rec -> do { vals' <- traverseNP rec (indices vals); return (g vals') })+-- :}+--+-- 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)+--+-- The result of evaluating either expression is the same:+--+-- >>> $$(gen values)+-- "xxTrue"+--+-- >>> $$(letNP values gen)+-- "xxTrue"+--+-- This example illustrates that 'letrecH' is more general than something+-- like @letNP@ and doesn't require extra data-structures+-- (Instead of having 'GCompare' constraint the function can ask for @tag x -> tag y -> Maybe (x :~: y)@ function)+--+letrecH+    :: forall q tag r. (GCompare tag, Quote q, MonadFix q)+    => (forall x. tag x -> String)                                                             -- ^ tag naming function+    -> (forall m y. Monad m => (forall x. tag x -> m (Code q x)) -> (tag y -> m (Code q y)))   -- ^ bindings generator (with recursive function)+    -> (forall m.   Monad m => (forall x. tag x -> m (Code q x)) -> m (Code q r))              -- ^ final expression generator+    -> Code q r                                                                                -- ^ generated let expression+letrecH nameOf bindf exprf = unsafeCodeCoerce $ TH.LetRec.letrecE+    (\(Some tag) -> nameOf tag)+    (\recf (Some tag) -> unTypeCode <$> bindf (\tag' -> unsafeCodeCoerce <$> recf (Some tag')) tag)+    (\recf            -> unTypeCode <$> exprf (\tag' -> unsafeCodeCoerce <$> recf (Some tag')))
+ th-letrec.cabal view
@@ -0,0 +1,34 @@+cabal-version:      2.4+name:               th-letrec+version:            0.1+synopsis:           Implicit (recursive) let insertion+description:+  Implicit (recursive) let insertion.+  .+  The package provides @letrecE@ combinator which allows dynamic and implicit+  let-expression generation. It is specially handy for Typed Template Haskell,+  as generating dynamic structures is impossible with (static) splices.++bug-reports:        https://github.com/phadej/th-letrec/issues+license:            BSD-3-Clause+license-file:       LICENSE+author:             Oleg Grenrus <oleg.grenrus@iki.fi>+maintainer:         Oleg Grenrus <oleg.grenrus@iki.fi>+category:           Template Haskell+extra-source-files: CHANGELOG.md+tested-with:        GHC ==9.0.2 || ==9.2.5 || ==9.4.4++library+  default-language: Haskell2010+  build-depends:+    , base              ^>=4.15.0.0 || ^>=4.16.0.0 || ^>=4.17.0.0+    , containers        ^>=0.6.4.1+    , some              ^>=1.0.4+    , template-haskell  ^>=2.17.0.0 || ^>=2.18.0.0 || ^>=2.19.0.0+    , transformers      ^>=0.5.6.2++  hs-source-dirs:   src+  ghc-options:      -Wall+  exposed-modules:+    Language.Haskell.TH.LetRec+    Language.Haskell.TTH.LetRec