diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## 0.1.1 + +- Add `typedLetrecE` and `typedLetrecH` + ## 0.1 * First version 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 @@ -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) 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 @@ -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'))) 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 +version: 0.1.1 synopsis: Implicit (recursive) let insertion description: Implicit (recursive) let insertion. @@ -16,16 +16,17 @@ maintainer: Oleg Grenrus 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