autoapply 0.1.0.0 → 0.2.0.0
raw patch · 4 files changed
+69/−31 lines, 4 filesdep ~th-desugarPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: th-desugar
API changes (from Hackage documentation)
Files
- autoapply.cabal +4/−4
- changelog.md +4/−0
- readme.md +2/−0
- src/AutoApply.hs +59/−27
autoapply.cabal view
@@ -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
changelog.md view
@@ -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`
readme.md view
@@ -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
src/AutoApply.hs view
@@ -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