diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Joe Hermaszewski (c) 2016 + +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 Joe Hermaszewski 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main where + +import Distribution.Extra.Doctest (defaultMainWithDoctests) + +main :: IO () +main = defaultMainWithDoctests "doctests" diff --git a/autoapply.cabal b/autoapply.cabal new file mode 100644 --- /dev/null +++ b/autoapply.cabal @@ -0,0 +1,67 @@ +cabal-version: 1.24 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 7d16c8a0b05df49d6afc85393edc6b82c2482761dbc1c85a66ec61675dba7497 + +name: autoapply +version: 0.1.0.0 +synopsis: Template Haskell to automatically pass values to functions +description: See readme.md +category: Template Haskell +homepage: https://github.com/expipiplus1/autoapply#readme +bug-reports: https://github.com/expipiplus1/autoapply/issues +maintainer: Joe Hermaszewski +copyright: (c) 2020 Joe Hermaszewski +license: BSD3 +license-file: LICENSE +build-type: Custom +extra-source-files: + readme.md + default.nix + changelog.md + +source-repository head + type: git + location: https://github.com/expipiplus1/autoapply + +custom-setup + setup-depends: + Cabal + , base + , cabal-doctest >=1 && <1.1 + +library + exposed-modules: + AutoApply + other-modules: + Paths_autoapply + hs-source-dirs: + src + default-extensions: DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies FlexibleContexts KindSignatures LambdaCase PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables TemplateHaskellQuotes TupleSections TypeFamilies ViewPatterns + ghc-options: -Wall + build-depends: + base >=4.13 && <5 + , logict + , mtl + , template-haskell + , th-desugar >=1.10 + , transformers + , unification-fd + default-language: Haskell2010 + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: Doctests.hs + other-modules: + + hs-source-dirs: + test + default-extensions: DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies FlexibleContexts KindSignatures LambdaCase PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables TemplateHaskellQuotes TupleSections TypeFamilies ViewPatterns + ghc-options: -Wall + build-depends: + base + , doctest + default-language: Haskell2010 diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,7 @@ +# Change Log + +## WIP + +## [0.1.0.0] - 2020-04-26 + - Initial release + - `autoapply` and `autoapplyDecs` diff --git a/default.nix b/default.nix new file mode 100644 --- /dev/null +++ b/default.nix @@ -0,0 +1,40 @@ +{ pkgs ? import { }, compiler ? "ghc882", hoogle ? true }: + +let + src = pkgs.nix-gitignore.gitignoreSource [ ] ./.; + + compiler' = if compiler != null then + compiler + else + "ghc" + pkgs.lib.concatStrings + (pkgs.lib.splitVersion pkgs.haskellPackages.ghc.version); + + # Any overrides we require to the specified haskell package set + haskellPackages = with pkgs.haskell.lib; + pkgs.haskell.packages.${compiler'}.override { + overrides = self: super: + { } // pkgs.lib.optionalAttrs hoogle { + ghc = super.ghc // { withPackages = super.ghc.withHoogle; }; + ghcWithPackages = self.ghc.withPackages; + }; + }; + + # Any packages to appear in the environment provisioned by nix-shell + extraEnvPackages = with haskellPackages; [ ]; + + # Generate a haskell derivation using the cabal2nix tool on `package.yaml` + drv = let old = haskellPackages.callCabal2nix "" src { }; + in old // { + # Insert the extra environment packages into the environment generated by + # cabal2nix + env = pkgs.lib.overrideDerivation old.env (attrs: + { + buildInputs = attrs.buildInputs ++ extraEnvPackages; + } // pkgs.lib.optionalAttrs hoogle { + shellHook = attrs.shellHook + '' + export HIE_HOOGLE_DATABASE="$(cat $(${pkgs.which}/bin/which hoogle) | sed -n -e 's|.*--database \(.*\.hoo\).*|\1|p')" + ''; + }); + }; + +in if pkgs.lib.inNixShell then drv.env else drv diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,141 @@ +# autoapply + +A Template-Haskell program to automatically pass arguments to functions +wherever the type fits. + +## TL;DR + +You have the following values and want to stir them together and see what +sticks. + +- `foo :: Monad m => A -> B -> C -> m D` +- `getA :: App A` +- `myC :: C` + +`$(autoApply ['getA, 'myC] 'foo)` will create +`\b -> getA >>= \a -> foo a b myC` which has type `B -> App D` + +or + +`autoApplyDecs reverse ['getA, 'myC] ['foo]` will create +`oof :: B -> App D; oof b = do { a <- getA; foo a b myC }` + +## Why to use it + +One nice use-case is to avoiding writing boilerplate wrappers for using an API +in your Monad stack. For instance imagine the following API. + +```haskell +data Instance; data ExtraOpenInfo; data Foo; data Bar; data Handle +openHandle :: MonadIO m => Instance -> Maybe ExtraOpenInfo -> m Handle +closeHandle :: MonadIO m => Instance -> Handle -> m () +useHandle :: MonadIO m => Instance -> Handle -> Foo -> m Bar +``` + +You'd like to use this in your `polysemy` application, using the `Input` effect +to pass the `Instance` handle around, and always passing `Nothing` for +`ExtraOpenInfo` because you don't use that functionality and getting a `Foo` +from some other constraint `MyConstraint`. You define the following values. + +```haskell +myExtraOpenInfo :: Maybe ExtraOpenInfo +myExtraOpenInfo = Nothing +getInstance :: Member (Input Instance) r => Sem r Instance +getInstance = input +getFoo :: MyConstraint m => m Foo +getFoo = ... +``` + +You then create the wrapped API thusly: + +```haskell +autoapplyDecs + (<> "'") -- Function to transform the names of the wrapped functions + ['myExtraOpenInfo, 'getInstance, 'getFoo] -- Potential arguments to pass + ['openHandle, 'closeHandle, 'useHandle] -- Functions to wrap +``` + +Which creates the following declarations: + +```haskell +openHandle' + :: (Member (Input Instance) r, MonadIO (Sem r)) => Sem r Handle +closeHandle' + :: (Member (Input Instance) r, MonadIO (Sem r)) => Handle -> Sem r () +useHandle' + :: (Member (Input Instance) r, MyConstraint (Sem r), MonadIO (Sem r)) + => Handle -> Sem r Bar +``` + +Notice: +- `Instance` is supplied with the `Member (Input Instance) r` constraint +- `Foo` is supplied by `MyConstraint (Sem r)` +- `ExtraOpenInfo` is not present at all, being supplied internally by `myExtraOpenInfo` + +To see the generated code (it's exactly what you'd expect) compile +`test/Types.hs` with `-ddump-splices`. + +## How to use this + +To generate a new top-level declaration you'll need: + +- The `Name` of a function to apply to some arguments. +- The `Name`s of some values to try and pass as arguments. +- A way of generating a name for this declaration given the wrapped name + `:: String -> String`. + +The new declaration will be generated, equal to the wrapped one but using the +supplied arguments wherever possible. + +Arguments can be used in two ways: + +- As regular parameters + - If the type of the argument matches directly + - An example is applying `takeWhile` to `not`; `not` is passed as the `a -> Bool` + argument to `takeWhile`. `$(autoapply ['not] 'takeWhile) :: [Bool] -> [Bool]` + +- Using a monadic bind + - If the wrapped function returns a value of type `m a` and there exists an instance `Monad m` + - If the argument is of type `n a` and there exists an instance `Monad m` + - If `m` unifies with `n` + - An example is applying `putStrLn` to `getLine`. The `String` result of `getLine` is passed to `putStrLn` + `$(autoapply ['getLine] 'putStrLn) :: IO ()` + +It's important to note that `Monad` instance checking only goes as far as +`template-haskell`'s `reifyInstances`. i.e. only the instance heads are +checked. + +Aside for checking for a `Monad` instance, no constraints are checked. So `autoapply` +will happily pass `reverse` to `(+)` yielding a value of type `Num ([a] -> [a]) => [a] -> [a]`. + +Monadic binds are performed in the order of arguments passed to the wrapped +function, and will be performed more than once if the argument is used multiple +times. + +You may want to either type your generated declarations manually (putting the +type after the splice) or turn on `-XNoMonomorphismRestriction` if your +arguments have polymorphic constraints. + +## Where to use it + +- In an expression context: + - `$(autoApply ['my, 'arguments] 'myFunction)` + +- At the top level to generate several declarations + - `$(autoApplyDecs (funNameToNewFunName :: String -> String) ['my, 'arguments] ['myFunction, 'anotherFunction])` + +## See also + +This has a similar feel to some other programs which also generate Haskell +expressions based on types. + +- [djinn](https://hackage.haskell.org/package/djinn) +- [exference](http://hackage.haskell.org/package/exference) ([github](https://github.com/lspitzner/exference)) +- [JustDoIt](https://www.joachim-breitner.de/blog/735-The_magic_%E2%80%9CJust_do_it%E2%80%9D_type_class) + +There are a couple of differences here: + +- One doesn't need to specify the desired type up front, this tool will just go + as far as it can. +- This tool isn't doing any interesting proof search instead it's just "if it + fits, I sits" diff --git a/src/AutoApply.hs b/src/AutoApply.hs new file mode 100644 --- /dev/null +++ b/src/AutoApply.hs @@ -0,0 +1,274 @@ +module AutoApply + ( autoapply + , autoapplyDecs + ) where + +import Control.Applicative +import Control.Arrow ( (>>>) ) +import Control.Monad +import Control.Monad.Logic ( LogicT + , observeManyT + ) +import Control.Monad.Logic.Class ( ifte ) +import Control.Monad.Trans as T +import Control.Monad.Trans.Except +import Control.Unification +import Control.Unification.IntVar +import Control.Unification.Types +import Data.Foldable +import Data.Functor +import Data.Functor.Fixedpoint +import Data.Maybe +import Data.Traversable +import Language.Haskell.TH +import Language.Haskell.TH.Desugar + +-- | @autoapply args fun@ creates an expression which is equal to @fun@ applied +-- to as many of the values in @args@ as possible. +autoapply :: [Name] -> Name -> Q Exp +autoapply givens fun = do + givenInfos <- for givens $ fmap (uncurry Given) . reifyVal "Argument" + funInfo <- uncurry Function <$> reifyVal "Function" fun + autoapply1 givenInfos funInfo + +-- | @autoapplyDecs mkName args funs@ will wrap every function in @funs@ by +-- applying it to as many of the values in @args@ as possible. The new function +-- name will be @mkName@ applied to the wrapped function name. +-- +-- Type signatures are not generated, so you may want to add these yourself or +-- turn on @NoMonomorphismRestriction@ if you have polymorphic constraints. +autoapplyDecs :: (String -> String) -> [Name] -> [Name] -> Q [Dec] +autoapplyDecs getNewName givens funs = do + givenInfos <- for givens $ fmap (uncurry Given) . reifyVal "Argument" + funInfos <- for funs $ fmap (uncurry Function) . reifyVal "Function" + let mkFun fun = do + exp' <- autoapply1 givenInfos fun + pure $ FunD (mkName . getNewName . nameBase . fName $ fun) + [Clause [] (NormalB exp') []] + traverse mkFun funInfos + +-- | A given is something we can try to pass as an argument +data Given = Given + { gName :: Name + , gType :: DType + } + deriving (Show) + +-- | A function we are wrapping +data Function = Function + { fName :: Name + , fType :: DType + } + deriving (Show) + +autoapply1 :: [Given] -> Function -> Q Exp +autoapply1 givens fun = do + -- In this function we: + -- + -- - Instantiate the command type with new unification variables + -- - Split it into arguments and return type + -- - Try to unify it with every 'Given' at every argument + -- - If we can unify the monad of the 'Given' with that of the functions and + -- unify the argument type, use that. + -- - If nothing matches we just use an 'Argument' + -- - Take the first result of all these tries + + let (fmap varBndrName -> cmdVars, _preds, args, ret) = unravel (fType fun) + defaultMaybe m = ifte m (pure . Just) (pure Nothing) + liftQ :: Q a -> IntBindingT TypeF (LogicT Q) a + liftQ = T.lift . T.lift + + -- Use LogicT so we can backtrack on failure + genProvs :: LogicT Q [ArgProvenance] + genProvs = evalIntBindingT $ do + instArgs <- traverse (inst cmdVars . snd <=< liftQ . typeDtoF) args + + -- This is @Just (m, a)@ when m is Applicative + retMonad <- case ret of + DAppT m a -> liftQ (isInstance ''Applicative [sweeten m]) >>= \case + False -> pure Nothing + True -> do + m' <- inst cmdVars . snd <=< liftQ . typeDtoF $ m + a' <- inst cmdVars . snd <=< liftQ . typeDtoF $ a + pure $ Just (m', a') + _ -> pure Nothing + + -- A list of (type to unify, predicate to use this match, the given + -- providing the value). + -- + -- The predicate is there to make sure we only match unifiable monads + instGivens <- fmap concat . for givens $ \g@Given {..} -> do + -- The Given applied as is + nonApp <- do + instTy <- uncurry inst <=< liftQ . typeDtoF $ gType + v <- liftQ $ newName "g" + pure (instTy, pure (), BoundPure v g) + -- The given, but in an applicative context, only possible if we can + -- unify the monad and there is a Monad instance + app <- case stripForall gType of + (vars, DAppT m a) | Just (cmdM, _) <- retMonad -> + liftQ (isInstance ''Applicative [sweeten m]) >>= \case + False -> pure Nothing + True -> do + m' <- inst vars . snd <=< liftQ . typeDtoF $ m + a' <- inst vars . snd <=< liftQ . typeDtoF $ a + v <- liftQ $ newName "g" + let predicate = do + _ <- unify m' cmdM + pure () + pure $ Just (a', predicate, Bound v g) + _ -> pure Nothing + pure ([nonApp] <> toList app) + + as <- for instArgs $ \argTy -> + defaultMaybe . asum $ instGivens <&> \(givenTy, predicate, g) -> + runExceptT + (do + predicate + freshGivenTy <- freshen givenTy + unify freshGivenTy argTy + ) + >>= \case + Left (_ :: UFailure TypeF IntVar) -> empty + Right _ -> pure g + for (zip args as) $ \case + (_, Just p ) -> pure p + (t, Nothing) -> (`Argument` t) <$> liftQ (newName "a") + + argProvenances <- + note "\"Impossible\" Finding argument provenances failed" + . listToMaybe + =<< observeManyT 1 genProvs + unless (length argProvenances == length args) $ fail + "\"Impossible\", incorrect number of argument provenances were found" + + let bindGiven = \case + BoundPure _ _ -> Nothing + Bound n g -> Just $ BindS (VarP n) (VarE (gName g)) + Argument _ _ -> Nothing + bs = catMaybes (bindGiven <$> argProvenances) + ret' = applyDExp + (DVarE (fName fun)) + (argProvenances <&> \case + Bound n _ -> DVarE n + BoundPure _ (Given n _) -> DVarE n + Argument n _ -> DVarE n + ) + exp' <- dsDoStmts (bs <> [NoBindS (sweeten ret')]) + + -- Typing the arguments here is important, if we don't then some skolems + -- might escape! + -- + -- Consider wrapping @f :: (forall a. a) -> ()@ (and supplying no arguments). + -- We end up with the splice @myF x = f x@, and the @a@ in the argument to + -- @f@ escapes. We can fix this by typing the pattern explicitly, thusly @myF + -- (x :: forall a. a) = f x@ + pure $ LamE [ SigP (VarP n) (sweeten t) | Argument n t <- argProvenances ] + (sweeten exp') + +data ArgProvenance + = Bound Name Given + -- ^ Comes from a monadic binding + | BoundPure Name Given + -- ^ Comes from a pure binding, i.e. let ... in + | Argument Name DType + -- ^ Comes from an argument to the wrapped function + deriving (Show) + +---------------------------------------------------------------- +-- Haskell types as a fixed point of TypeF +---------------------------------------------------------------- + +data TypeF a + = AppF a a + | VarF Name + | ConF Name + | ArrowF + | LitF TyLit + deriving (Show, Functor, Foldable, Traversable) + +-- TODO: Derive this with generics +instance Unifiable TypeF where + zipMatch (AppF l1 r1) (AppF l2 r2) = + Just (AppF (Right (l1, l2)) (Right (r1, r2))) + zipMatch (VarF n1) (VarF n2) | n1 == n2 = Just (VarF n1) + zipMatch (ConF n1) (ConF n2) | n1 == n2 = Just (ConF n1) + zipMatch ArrowF ArrowF = Just ArrowF + zipMatch (LitF l1) (LitF l2) | l1 == l2 = Just (LitF l1) + zipMatch _ _ = Nothing + +-- | Returns the type as a @Fix TypeF@ along with any quantified names. Drops +-- any context. +typeDtoF :: MonadFail m => DType -> m ([Name], Fix TypeF) +typeDtoF = traverse go . stripForall + where + go = \case + DForallT{} -> fail "TODO: Higher ranked types" + DAppT l r -> do + l' <- go l + r' <- go r + pure $ Fix (AppF l' r') + DAppKindT t _ -> go t + DSigT t _ -> go t + DVarT n -> pure . Fix $ VarF n + DConT n -> pure . Fix $ ConF n + DArrowT -> pure . Fix $ ArrowF + DLitT l -> pure . Fix $ LitF l + DWildCardT -> fail "TODO: Wildcards" + +varBndrName :: DTyVarBndr -> Name +varBndrName = \case + DPlainTV n -> n + DKindedTV n _ -> n + +-- | Raise foralls on the spine of the function type to the top +-- +-- For example @forall a. a -> forall b. b@ becomes @forall a b. a -> b@ +raiseForalls :: DType -> DType +raiseForalls = uncurry3 DForallT . go + where + go = \case + DForallT vs ctx t -> + let (vs', ctx', t') = go t in (vs <> vs', ctx <> ctx', t') + l :~> r -> let (vs, ctx, r') = go r in (vs, ctx, l :~> r') + t -> ([], [], t) + +pattern (:~>) :: DType -> DType -> DType +pattern l :~> r = DArrowT `DAppT` l `DAppT` r + +-- | Instantiate a type with unification variables +inst + :: BindingMonad TypeF IntVar m + => [Name] + -> Fix TypeF + -> m (UTerm TypeF IntVar) +inst ns t = do + vs <- sequence [ (n, ) <$> freeVar | n <- ns ] + let go (Fix f) = case f of + AppF l r -> UTerm (AppF (go l) (go r)) + VarF n | Just v <- lookup n vs -> UVar v + VarF n -> UTerm (VarF n) + ConF n -> UTerm (ConF n) + ArrowF -> UTerm ArrowF + LitF l -> UTerm (LitF l) + pure $ go t + +---------------------------------------------------------------- +-- Utils +---------------------------------------------------------------- + +reifyVal :: String -> Name -> Q (Name, DType) +reifyVal d n = dsReify n >>= \case + Just (DVarI name ty _) -> pure (name, ty) + _ -> fail $ d <> " " <> show n <> " isn't a value" + +stripForall :: DType -> ([Name], DType) +stripForall = raiseForalls >>> \case + DForallT vs _ ty -> (varBndrName <$> vs, ty) + ty -> ([], ty) + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f (a, b, c) = f a b c + +note :: MonadFail m => String -> Maybe a -> m a +note s = maybe (fail s) pure diff --git a/test/Doctests.hs b/test/Doctests.hs new file mode 100644 --- /dev/null +++ b/test/Doctests.hs @@ -0,0 +1,7 @@ +module Main where + +import Build_doctests (flags, pkgs) +import Test.DocTest + +main :: IO () +main = doctest $ flags <> pkgs <> ["-fno-print-bind-result", "test/Types.hs"]