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: 7d16c8a0b05df49d6afc85393edc6b82c2482761dbc1c85a66ec61675dba7497 +-- hash: 0ebb847d015afb16b8a577b0a6012c39b43d5c5ac92fd9584450922c1f5d0730 name: autoapply -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Template Haskell to automatically pass values to functions description: See readme.md category: Template Haskell @@ -40,7 +40,7 @@ Paths_autoapply hs-source-dirs: src - default-extensions: DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies FlexibleContexts KindSignatures LambdaCase PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables TemplateHaskellQuotes TupleSections TypeFamilies ViewPatterns + 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.13 && <5 @@ -59,7 +59,7 @@ hs-source-dirs: test - default-extensions: DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies FlexibleContexts KindSignatures LambdaCase PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables TemplateHaskellQuotes TupleSections TypeFamilies ViewPatterns + default-extensions: DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies FlexibleContexts KindSignatures LambdaCase PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables TemplateHaskellQuotes TupleSections TypeApplications TypeFamilies ViewPatterns ghc-options: -Wall build-depends: base diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -2,6 +2,10 @@ ## WIP +## [0.2.0.0] - 2020-05-01 + - Allow instantiating a polymorphic return type as a monadic value. For + example `autoapply '[getFooIO] (bar :: Foo -> b)` will have type `IO b`. + ## [0.1.0.0] - 2020-04-26 - Initial release - `autoapply` and `autoapplyDecs` diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -3,6 +3,8 @@ A Template-Haskell program to automatically pass arguments to functions wherever the type fits. +@tomjaguarpaw noticed that this is like "Type-directed implicit parameters". + ## TL;DR You have the following values and want to stir them together and see what diff --git a/src/AutoApply.hs b/src/AutoApply.hs --- a/src/AutoApply.hs +++ b/src/AutoApply.hs @@ -9,7 +9,6 @@ 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 @@ -73,28 +72,31 @@ -- - 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) + let (fmap varBndrName -> cmdVarNames, _preds, args, ret) = + unravel (fType fun) + defaultMaybe m = (Just <$> m) <|> pure Nothing liftQ :: Q a -> IntBindingT TypeF (LogicT Q) a liftQ = T.lift . T.lift + errorToLogic go = runExceptT go >>= \case + Left (_ :: UFailure TypeF IntVar) -> empty + Right x -> pure x -- Use LogicT so we can backtrack on failure genProvs :: LogicT Q [ArgProvenance] genProvs = evalIntBindingT $ do - instArgs <- traverse (inst cmdVars . snd <=< liftQ . typeDtoF) args + cmdVars <- sequence [ (n, ) <$> freeVar | n <- cmdVarNames ] + instArgs <- traverse + (fmap (instWithVars 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 + cmdM <- UVar <$> freeVar + retInst <- fmap (instWithVars cmdVars . snd) . liftQ . typeDtoF $ ret - -- A list of (type to unify, predicate to use this match, the given - -- providing the value). + -- 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 @@ -106,7 +108,7 @@ -- 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 -> + (vars, DAppT m a) -> liftQ (isInstance ''Applicative [sweeten m]) >>= \case False -> pure Nothing True -> do @@ -121,16 +123,28 @@ 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 + defaultMaybe . asum $ instGivens <&> \(givenTy, predicate, g) -> do + _ <- errorToLogic $ do + predicate + freshGivenTy <- freshen givenTy + unify freshGivenTy argTy + pure g + + -- If we used any monadic bindings, we must have a Monad instance for + -- the return variable. If it's polymorphic then assume an instance. + when (any isMonadicBind (catMaybes as)) $ do + a <- UVar <$> freeVar + ret' <- errorToLogic $ unify retInst (UTerm (AppF cmdM a)) + retFrozen <- freeze <$> errorToLogic (applyBindings ret') + case retFrozen of + Just (Fix (AppF m _)) -> do + let typeD = typeFtoD m + liftQ (isInstance ''Applicative [sweeten typeD]) >>= \case + False -> empty + True -> pure () + Nothing -> pure () + _ -> empty + for (zip args as) $ \case (_, Just p ) -> pure p (t, Nothing) -> (`Argument` t) <$> liftQ (newName "a") @@ -175,6 +189,11 @@ -- ^ Comes from an argument to the wrapped function deriving (Show) +isMonadicBind :: ArgProvenance -> Bool +isMonadicBind = \case + Bound _ _ -> True + _ -> False + ---------------------------------------------------------------- -- Haskell types as a fixed point of TypeF ---------------------------------------------------------------- @@ -216,6 +235,14 @@ DLitT l -> pure . Fix $ LitF l DWildCardT -> fail "TODO: Wildcards" +typeFtoD :: Fix TypeF -> DType +typeFtoD = unFix >>> \case + AppF l r -> DAppT (typeFtoD l) (typeFtoD r) + VarF n -> DVarT n + ConF n -> DConT n + ArrowF -> DArrowT + LitF l -> DLitT l + varBndrName :: DTyVarBndr -> Name varBndrName = \case DPlainTV n -> n @@ -244,6 +271,11 @@ -> m (UTerm TypeF IntVar) inst ns t = do vs <- sequence [ (n, ) <$> freeVar | n <- ns ] + pure $ instWithVars vs t + +-- | Instantiate a type with unification variables +instWithVars :: [(Name, IntVar)] -> Fix TypeF -> UTerm TypeF IntVar +instWithVars vs t = 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 @@ -251,7 +283,7 @@ ConF n -> UTerm (ConF n) ArrowF -> UTerm ArrowF LitF l -> UTerm (LitF l) - pure $ go t + in go t ---------------------------------------------------------------- -- Utils