autoapply 0.3 → 0.4

raw patch · 5 files changed

+106/−46 lines, 5 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• autoapply.cabal +3/−3
• changelog.md +5/−0
• default.nix +6/−1
• readme.md +14/−8
• src/AutoApply.hs +78/−34

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 7dfbb655fdf55d5ab82b9457125299eaba2c2a4b318c4713df711e9c1ce23937+-- hash: cd7920009bd3d4a71ca708e58f17f923dc3b5477ef30d0a7ddf6c30155ce9d13  name:           autoapply-version:        0.3+version:        0.4 synopsis:       Template Haskell to automatically pass values to functions description:    See readme.md category:       Template Haskell@@ -43,7 +43,7 @@   default-extensions: DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies FlexibleContexts KindSignatures LambdaCase PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables TemplateHaskellQuotes TupleSections TypeApplications TypeFamilies ViewPatterns   ghc-options: -Wall   build-depends:-      base >=4.9 && <5+      base >=4.12 && <5     , logict     , mtl     , template-haskell

@@ -2,6 +2,11 @@  ## WIP +## [0.4] - 2020-05-06+  - Allow specifying if the types of potential arguments should subsume or just+    unify with the function's argument types+  - Respect constraints when passing arguments (ignoring type families)+ ## [0.3] - 2020-05-06   - Check constraints on functions 

@@ -14,7 +14,12 @@     pkgs.haskell.packages.${compiler'}.override {       overrides = self: super:         {-          th-desugar = self.callHackage "th-desugar" "1.11" { };+          th-desugar = self.callCabal2nix "" (pkgs.fetchFromGitHub {+            owner = "goldfirere";+            repo = "th-desugar";+            rev = "f075206882ce4e554c37537e624b4be7409d74a3";+            sha256 = "0747xggx2q8yphag2wv06dj0pgi9zvadi069c2d6lckg26chhnlk";+          }) { };         } // pkgs.lib.optionalAttrs hoogle {           ghc = super.ghc // { withPackages = super.ghc.withHoogle; };           ghcWithPackages = self.ghc.withPackages;

@@ -14,12 +14,12 @@ - `getA :: App A` - `myC :: C` -`$(autoApply ['getA, 'myC] 'foo)` will create+`$(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+`autoApplyDecs reverse [] ['getA, 'myC] ['foo]` will create `oof :: B -> App D; oof b = do { a <- getA; foo a b myC }`  ## Why to use it@@ -53,7 +53,10 @@ ```haskell autoapplyDecs   (<> "'") -- Function to transform the names of the wrapped functions-  ['myExtraOpenInfo, 'getInstance, 'getFoo] -- Potential arguments to pass+  ['myExtraOpenInfo, 'getInstance, 'getFoo]+    -- Potential arguments to pass which must subsume the argument type of the+    -- function.+  [] -- Potential arguments to pass which must unify with the argument type   ['openHandle, 'closeHandle, 'useHandle] -- Functions to wrap ``` @@ -82,7 +85,10 @@ 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.+- The `Name`s of some values to try and pass as arguments+  - values whose type must subsume the argument type (if you're unsure, you+    probably want this one)+  - values whose type must merely unify with the argument type - A way of generating a name for this declaration given the wrapped name   `:: String -> String`. @@ -94,14 +100,14 @@ - 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]`+    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 ()`+    `$(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@@ -121,10 +127,10 @@ ## Where to use it  - In an expression context:-  - `$(autoApply ['my, 'arguments] 'myFunction)`+  - `$(autoApply ['my, 'arguments] [] 'myFunction)`  - At the top level to generate several declarations-  - `$(autoApplyDecs (funNameToNewFunName :: String -> String) ['my, 'arguments] ['myFunction, 'anotherFunction])`+  - `$(autoApplyDecs (funNameToNewFunName :: String -> String) ['my] ['arguments] ['myFunction, 'anotherFunction])`  ## See also 

@@ -1,4 +1,3 @@-{-# language CPP #-} module AutoApply   ( autoapply   , autoapplyDecs@@ -7,11 +6,6 @@ import           Control.Applicative import           Control.Arrow                  ( (>>>) ) import           Control.Monad-#if __GLASGOW_HASKELL__ < 808--- Control.Monad.Fail import is redundant since GHC 8.8.1-import           Control.Monad.Fail             ( MonadFail-                                                )-#endif import           Control.Monad.Logic            ( LogicT                                                 , observeManyT                                                 )@@ -29,37 +23,71 @@ import           Language.Haskell.TH.Desugar import           Prelude                 hiding ( pred ) --- | @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+-- | @autoapply argsSubsuming argsUnifying fun@ creates an expression which is+-- equal to @fun@ applied to as many of the values in @argsSubsuming@ and+-- @argsUnifying@ as possible.+--+-- The types of first list of args must subsume the type of the argument+-- they're passed to. The types of the second list must merely unify.+autoapply+  :: [Name]+  -- ^ Values which will be used if their type subsumes the argument type+  -> [Name]+  -- ^ Values which will be used if their type unifies with the argument type+  -> Name+  -- ^ A function to apply to some values+  -> Q Exp+autoapply subsuming unifying fun = do+  unifyingInfos <- for unifying $ fmap (uncurry (Given Unifying)) . reifyVal+    "Argument"+  subsumingInfos <- for subsuming $ fmap (uncurry (Given Subsuming)) . reifyVal+    "Argument"+  funInfo <- uncurry Function <$> reifyVal "Function" fun+  autoapply1 (unifyingInfos <> subsumingInfos) 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.+-- | @autoapplyDecs mkName argsSubsuming argsUnifying funs@ will wrap every+-- function in @funs@ by applying it to as many of the values in+-- @argsSubsuming@ and @argsUnifying@ as possible. The new function name will+-- be @mkName@ applied to the wrapped function name. --+-- The types of first list of args must subsume the type of the argument+-- they're passed to. The types of the second list must merely unify.+-- -- 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"+autoapplyDecs+  :: (String -> String)+  -- ^ A function to generate a new name for the wrapping function+  -> [Name]+  -- ^ A list of values which will be passed to any arguments their type subsumes+  -> [Name]+  -- ^ A list of values which will be passed to any arguments their type unify with+  -> [Name]+  -- ^ A list of function to wrap with the above parameters+  -> Q [Dec]+autoapplyDecs getNewName subsuming unifying funs = do+  unifyingInfos <- for unifying $ fmap (uncurry (Given Unifying)) . reifyVal+    "Argument"+  subsumingInfos <- for subsuming $ fmap (uncurry (Given Subsuming)) . reifyVal+    "Argument"+  funInfos <- for funs $ fmap (uncurry Function) . reifyVal "Function"   let mkFun fun = do-        exp' <- autoapply1 givenInfos fun+        exp' <- autoapply1 (unifyingInfos <> subsumingInfos) 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+  { gUnificationType :: UnificationType+  , gName            :: Name+  , gType            :: DType   }-  deriving (Show)+  deriving Show +data UnificationType = Unifying | Subsuming+  deriving Show+ -- | A function we are wrapping data Function = Function   { fName :: Name@@ -73,7 +101,7 @@   --   -- - 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+  -- - Try to unify or subsume 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'@@ -137,10 +165,18 @@        as <- for instArgs $ \argTy ->         defaultMaybe . asum $ instGivens <&> \(givenTy, predicate, g) -> do-          _ <- errorToLogic $ do+          errorToLogic $ do             predicate             freshGivenTy <- freshen givenTy-            unify freshGivenTy argTy+            let u = case g of+                  Bound     _ Given {..} -> gUnificationType+                  BoundPure _ Given {..} -> gUnificationType+                  Argument  _ _          -> Unifying+            case u of+              Unifying  -> void $ unify freshGivenTy argTy+              Subsuming -> do+                s <- subsumes freshGivenTy argTy+                lift $ guard s           pure g        -- If we used any monadic bindings, we must have a Monad instance for@@ -184,9 +220,16 @@             className <- case class' of               DConT n -> pure n               _ -> liftQ $ fail "unfolded predicate didn't begin with a ConT"-            liftQ (isInstance className (sweeten <$> typeArgs)) >>= \case-              False -> empty-              True  -> pure ()++            -- Ignore when the name is a type family because of+            -- https://gitlab.haskell.org/ghc/ghc/issues/18153+            liftQ (reifyWithWarning className) >>= \case+              ClassI _ _ ->+                liftQ (isInstance className (sweeten <$> typeArgs)) >>= \case+                  False -> empty+                  True  -> pure ()+              FamilyI _ _ -> pure ()+              _ -> liftQ $ fail "Predicate name isn't a class or a type family"           Nothing ->             liftQ               $ fail@@ -198,7 +241,8 @@         (t, Nothing) -> (`Argument` t) <$> liftQ (newName "a")    argProvenances <--    note "\"Impossible\" Finding argument provenances failed"+    note+      "\"Impossible\" Finding argument provenances failed (unless the function context containts a class with no instances)"     .   listToMaybe     =<< observeManyT 1 genProvs   unless (length argProvenances == length args) $ fail@@ -212,9 +256,9 @@       ret' = applyDExp         (DVarE (fName fun))         (argProvenances <&> \case-          Bound     n _           -> DVarE n-          BoundPure _ (Given n _) -> DVarE n-          Argument  n _           -> DVarE n+          Bound     n _             -> DVarE n+          BoundPure _ (Given _ n _) -> DVarE n+          Argument  n _             -> DVarE n         )   exp' <- dsDoStmts (bs <> [NoBindS (sweeten ret')])