autoapply (empty) → 0.1.0.0

raw patch · 8 files changed

+572/−0 lines, 8 filesdep +basedep +doctestdep +logictbuild-type:Customsetup-changed

Dependencies added: base, doctest, logict, mtl, template-haskell, th-desugar, transformers, unification-fd

Files

• LICENSE +30/−0
• Setup.hs +6/−0
• autoapply.cabal +67/−0
• changelog.md +7/−0
• default.nix +40/−0
• readme.md +141/−0
• src/AutoApply.hs +274/−0
• test/Doctests.hs +7/−0

@@ -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.

@@ -0,0 +1,6 @@+module Main where++import Distribution.Extra.Doctest (defaultMainWithDoctests)++main :: IO ()+main = defaultMainWithDoctests "doctests"

@@ -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 <if.it.fits.i.sits@monoid.al>+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

@@ -0,0 +1,7 @@+# Change Log++## WIP++## [0.1.0.0] - 2020-04-26+  - Initial release+  - `autoapply` and `autoapplyDecs`

@@ -0,0 +1,40 @@+{ pkgs ? import <nixpkgs> { }, 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

@@ -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"

@@ -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

@@ -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"]