th-letrec 0.1 → 0.1.1
raw patch · 4 files changed
+199/−16 lines, 4 filesdep +codetdep ~basedep ~containersdep ~template-haskell
Dependencies added: codet
Dependency ranges changed: base, containers, template-haskell
Files
- CHANGELOG.md +4/−0
- src/Language/Haskell/TH/LetRec.hs +52/−10
- src/Language/Haskell/TTH/LetRec.hs +137/−1
- th-letrec.cabal +6/−5
CHANGELOG.md view
@@ -1,3 +1,7 @@+## 0.1.1++- Add `typedLetrecE` and `typedLetrecH`+ ## 0.1 * First version
src/Language/Haskell/TH/LetRec.hs view
@@ -3,13 +3,14 @@ {-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.TH.LetRec ( letrecE,+ typedLetrecE, ) 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 Language.Haskell.TH.Lib (letE, normalB, sigD, valD, varE, varP)+import Language.Haskell.TH.Syntax (Exp, Name, Quote (newName), Type) import qualified Data.Map.Lazy as Map @@ -69,24 +70,65 @@ -> (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+letrecE nameOf = typedLetrecE nameOf (const Nothing)++-- | Generate potentially recursive let expression, with optional type annotations.+--+-- A fibonacci example:+-- >>> 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 = 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;+-- fib0_0 = 1;+-- fib1_1 :: GHC.Types.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}+-- in fib7_7+--+-- >>> $(fib 7)+-- 21+--+-- @since 0.1.1+--+typedLetrecE+ :: forall q tag. (Ord tag, Quote q, MonadFix q)+ => (tag -> String) -- ^ tag naming function+ -> (tag -> Maybe (q Type)) -- ^ binding type+ -> (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.+typedLetrecE nameOf typeOf recf exprf = do (expr0, bindings) <- runStateT (exprf loop) Map.empty- letE- [ valD (varP name) (normalB expr) []- | (_tag, (name, expr)) <- Map.toList bindings- ]+ letE (concat+ [ [ sigD name ty' | Just ty' <- [ty] ] +++ [ valD (varP name) (normalB expr) [] ]+ | (_tag, (name, ty, expr)) <- Map.toList bindings+ ]) expr0 where- loop :: tag -> StateT (Map.Map tag (Name, q Exp)) q (q Exp)+ loop :: tag -> StateT (Map.Map tag (Name, Maybe (q Type), 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)+ Just (name, _ty, _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))+ modify (Map.insert tag (name, typeOf tag, expr)) expr <- recf loop tag return (varE name)
src/Language/Haskell/TTH/LetRec.hs view
@@ -4,22 +4,57 @@ module Language.Haskell.TTH.LetRec ( letrecE, letrecH,+ typedLetrecE,+ typedLetrecH, ) where import Control.Monad.Fix (MonadFix) import Data.GADT.Compare (GCompare) import Data.Some (Some (..))+import Language.Haskell.TH.CodeT (CodeT, unTypeCodeT) 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+-- >>> :set -XGADTs -XTypeOperators -XDataKinds -XPolyKinds -XRankNTypes -XTypeApplications -- >>> import Control.Monad.Fix (MonadFix) -- >>> 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+--+-- >>> :{+-- data NP f xs where+-- Nil :: NP f '[]+-- (:*) :: f x -> NP f xs -> NP f (x : xs)+-- infixr 5 :*+-- :}+--+--+-- >>> :{+-- 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+-- :}+--+-- >>> :{+-- let index :: NP f xs -> Idx xs x -> f x+-- index (x :* _) IZ = x+-- index (_ :* xs) (IS i) = index xs i+-- :}+--+-- >>> 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+-- -- | Generate potentially recursive let expression. --@@ -50,6 +85,50 @@ (\recf tag -> unTypeCode <$> bindf (\tag' -> unsafeCodeCoerce <$> recf tag') tag) (\recf -> unTypeCode <$> exprf (\tag' -> unsafeCodeCoerce <$> recf tag')) +-- | Generate potentially recursive let expression with type annotations.+--+-- >>> import Language.Haskell.TH.CodeT (codeT)+--+-- >>> 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 = 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;+-- fib0_0 = 1;+-- fib1_1 :: GHC.Types.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}+-- in fib7_7+--+-- >>> $$(fib 7)+-- 21+--+-- @since 0.1.1+typedLetrecE+ :: forall q tag r a. (Ord tag, Quote q, MonadFix q)+ => (forall. tag -> String) -- ^ tag naming function+ -> CodeT q a+ -> (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+typedLetrecE nameOf typeOf bindf exprf = unsafeCodeCoerce $ TH.LetRec.typedLetrecE+ nameOf+ (\_ -> Just (unTypeCodeT typeOf))+ (\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@@ -142,5 +221,62 @@ -> 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')))++-- | Generate potentially recursive let expression with heterogenously typed bindings with type annotations.+--+-- Using the same example as in 'letrecH', we can make a combinator for generating dynamic let-expression with typed annotations:+--+-- >>> :{+-- let typedLetNP :: (Quote q, MonadFix q) => NP (CodeT q) xs -> NP (Code q) xs -> (NP (Code q) xs -> Code q r) -> Code q r+-- typedLetNP typs vals g = typedLetrecH (\_ -> "x") (index typs) (\_rec idx -> return (index vals idx)) (\rec -> do { vals' <- traverseNP rec (indices vals); return (g vals') })+-- :}+--+-- Now we not only need values, but also types:+--+-- >>> :{+-- let values :: TH.Quote q => NP (Code q) '[ Bool, Char ]+-- values = [|| True ||] :* [|| 'x' ||] :* Nil+-- :}+--+-- >>> :{+-- let types :: TH.Quote q => NP (CodeT q) '[ Bool, Char ]+-- types = codeT :* codeT :* Nil+-- :}+--+-- >>> :{+-- let gen :: TH.Quote q => NP (Code q) '[ Bool, Char ] -> Code q String+-- gen (x :* y :* Nil) = [|| $$y : $$y : show $$x ||]+-- :}+--+-- 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)+--+-- The result of evaluating either expression is the same:+--+-- >>> $$(gen values)+-- "xxTrue"+--+-- >>> $$(typedLetNP types values gen)+-- "xxTrue"++-- @since 0.1.1+typedLetrecH+ :: forall q tag r. (GCompare tag, Quote q, MonadFix q)+ => (forall x. tag x -> String) -- ^ tag naming function+ -> (forall x. tag x -> CodeT q x) -- ^ binding type+ -> (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+typedLetrecH nameOf typeOf bindf exprf = unsafeCodeCoerce $ TH.LetRec.typedLetrecE+ (\(Some tag) -> nameOf tag)+ (\(Some tag) -> Just (unTypeCodeT (typeOf tag))) (\recf (Some tag) -> unTypeCode <$> bindf (\tag' -> unsafeCodeCoerce <$> recf (Some tag')) tag) (\recf -> unTypeCode <$> exprf (\tag' -> unsafeCodeCoerce <$> recf (Some tag')))
th-letrec.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: th-letrec-version: 0.1+version: 0.1.1 synopsis: Implicit (recursive) let insertion description: Implicit (recursive) let insertion.@@ -16,16 +16,17 @@ 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+tested-with: GHC ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.3 || ==9.8.1 library default-language: Haskell2010 build-depends:- , base ^>=4.15.0.0 || ^>=4.16.0.0 || ^>=4.17.0.0+ , base ^>=4.15.0.0 || ^>=4.16.0.0 || ^>=4.17.0.0 || ^>=4.18.0.0 || ^>=4.19.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- , transformers ^>=0.5.6.2+ , template-haskell ^>=2.17.0.0 || ^>=2.18.0.0 || ^>=2.19.0.0 || ^>=2.20.0.0 || ^>=2.21.0.0+ , transformers ^>=0.5.6.2 || ^>=0.6.1.0 hs-source-dirs: src ghc-options: -Wall