diff --git a/autoapply.cabal b/autoapply.cabal --- a/autoapply.cabal +++ b/autoapply.cabal @@ -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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 diff --git a/default.nix b/default.nix --- a/default.nix +++ b/default.nix @@ -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; diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -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 diff --git a/src/AutoApply.hs b/src/AutoApply.hs --- a/src/AutoApply.hs +++ b/src/AutoApply.hs @@ -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')])