prospect (empty) → 0.1.0.0
raw patch · 8 files changed
+557/−0 lines, 8 filesdep +basedep +deepseqdep +freesetup-changed
Dependencies added: base, deepseq, free, hspec, inspection-testing, kan-extensions, mtl, prospect, transformers
Files
- ChangeLog.md +7/−0
- LICENSE +30/−0
- README.md +82/−0
- Setup.hs +2/−0
- prospect.cabal +64/−0
- src/Control/Monad/Prospect.hs +186/−0
- src/Lib.hs +6/−0
- test/Spec.hs +180/−0
+ ChangeLog.md view
@@ -0,0 +1,7 @@+# Changelog for prospect++## 0.1 -- 2018-07-10++* First version. Released on an unsuspecting world.++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2018++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 Author name here 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.
+ README.md view
@@ -0,0 +1,82 @@+# prospect++[](https://travis-ci.org/isovector/prospect) | [Hackage][hackage]++[hackage]: https://hackage.haskell.org/package/prospect+++## Dedication++> It is absolutely necessary, for the peace and safety of mankind, that some of+> earth's dark, dead corners and unplumbed depths be let alone; lest sleeping+> abnormalities wake to resurgent life, and blasphemously surviving nightmares+> squirm and splash out of their black lairs to newer and wider conquests.+>+> H.P. Lovecraft+++## Overview++`prospect` is a library that provides primitives for exploring functions, and by+extension, monads. As such, it allows for a best-attempt static analysis of free+monads. Such power, however, does not come for free; using `prospect` is an+implicit promise with the Eldrich horrors that you'll tread lightly. Feckless+wanderers into these depths will be rewarded with naught but terror, madness,+and runtime crashes.+++## Usage++The library provides a function, `prospect :: Free f a -> (Maybe a, [f ()])`,+which can probe the depths of a free monad, finding as many `f` constructors as+it can before the monad branches dynamically.++Be careful when inspecting the `f ()`s, if any of them depend on variables bound+in the monad, they will leak exceptions when you are least expecting them. It's+a good idea to run your `f ()`s through `ensure :: Alternative m => a -> m a`+after you've scrutinized their constructors.+++## Example++`prospect` can be used to perform a best-effort static analysis of a free monad:++```haskell+data Pattern a+ = Cont (Bool -> a)+ | Action Int a+ deriving (Functor, Generic1)+++cont :: MonadFree Pattern m => m Bool+cont = liftF $ Cont id+++action :: MonadFree Pattern m => Int -> m ()+action i = liftF $ Action i ()+++success :: (Maybe String, [Pattern ()]+success = prospect $ do+ a <- cont+ action 1+ pure "success"+-- success = (Just "success", [Cont (const ()), Action 1 ()])+++failure :: (Maybe String, [Pattern ()]+failure = prospect $ do+ a <- cont+ action 1+ if a -- static analysis ends here, as it would require branching on the+ -- result of a monadic action+ then action 2+ else action 3+ action 4+ pure "failure"+-- failure = (Nothing, [Cont (const ()), Action 1 ()])+```++In these examples, we can continue analyzing a `Free Pattern` monad until+the result of its `Cont` continuation is forced.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ prospect.cabal view
@@ -0,0 +1,64 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 60eb5636909f1e5d8ffa88c6dd5b649b6bf724ae3d1e7438cc9dd6f99eda53f1++name: prospect+version: 0.1.0.0+synopsis: Explore continuations with trepidation+description: Please see the README on GitHub at <https://github.com/isovector/prospect#readme>+category: Control+homepage: https://github.com/isovector/prospect#readme+bug-reports: https://github.com/isovector/prospect/issues+author: Sandy Maguire+maintainer: sandy@sandymaguire.me+copyright: 2018 Sandy Maguire+license: BSD3+license-file: LICENSE+tested-with: GHC == 8.0.2, GHC == 8.2.1+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/isovector/prospect++library+ exposed-modules:+ Control.Monad.Prospect+ Lib+ other-modules:+ Paths_prospect+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <5+ , deepseq+ , free+ , kan-extensions+ , mtl+ , transformers+ default-language: Haskell2010++test-suite prospect-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_prospect+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , deepseq+ , free+ , hspec+ , inspection-testing >=0.3+ , kan-extensions+ , prospect+ default-language: Haskell2010
+ src/Control/Monad/Prospect.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Control.Monad.Prospect+ ( -- * Prospecting of free monads+ prospect+ , survey+ , explore++ -- * Guesswork+ , guess+ , given+ , verify+ , ensure+ , proceed+ , Guess (..)+ ) where++import Control.Applicative (Alternative (..))+import Control.DeepSeq (NFData, force)+import Control.Exception (Exception, throw, catch)+import Control.Monad.Free+import Control.Monad.Trans.Maybe (runMaybeT)+import Control.Monad.Writer.Strict (runWriter, tell)+import GHC.Generics+import GHC.TypeLits+import System.IO.Unsafe (unsafePerformIO)++++------------------------------------------------------------------------------+-- | Perform a best-effort analysis of a free monad.+survey+ :: Functor f+ => (forall b. f (Free f b) -> Free f b)+ -- ^ The following function. Consider using 'explore' to get an+ -- automatic implementation for this.+ -> Free f a+ -> (Maybe a, [f ()])+survey c = runWriter . runMaybeT . go+ where+ go (Pure a) = verify a+ go (Free f) = do+ tell . pure $ () <$ f+ given go $ c f+ {-# INLINE go #-}+++------------------------------------------------------------------------------+-- | Perform a best-effort analysis of a free monad by automatically+-- 'explore'ing it.+prospect+ :: (Functor f, Generic1 f, GExplore f (Rep1 f))+ => Free f a+ -> (Maybe a, [f ()])+prospect = survey explore+++------------------------------------------------------------------------------+-- | The underlying machinery of 'guess'.+data Guess = Guess+ deriving (Show, Eq)+instance Exception Guess+++------------------------------------------------------------------------------+-- | A 'guess' is a bottom whose evaluation can be caught by way of 'verify' or+-- 'given'. It can be used to follow continuations in a free monad until it+-- branches.+guess :: a+guess = throw Guess+{-# INLINE guess #-}+++------------------------------------------------------------------------------+-- | Attempt to evaluate the pure value 'a', returning 'empty' if it was+-- a 'guess'.+verify :: Alternative f => a -> f a+verify = given pure+{-# INLINE verify #-}+++------------------------------------------------------------------------------+-- | Like 'verify', but much stricter.+ensure :: (Alternative f, NFData a) => a -> f a+ensure = proceed pure+{-# INLINE ensure #-}+++------------------------------------------------------------------------------+-- | Strictly attempt a function application, returning 'empty' if the argument+-- was a 'guess'.+given :: Alternative f => (a -> f b) -> a -> f b+given f a = unsafePerformIO $ do+ catch+ (let !_ = a+ in pure $ f a)+ (\(_ :: Guess) -> pure empty)+{-# INLINE given #-}+++------------------------------------------------------------------------------+-- | Like `given`, but much stricter.+proceed :: (Alternative f, NFData a) => (a -> f b) -> a -> f b+proceed f a = unsafePerformIO $ do+ catch+ (let !_ = force a+ in pure $ f a)+ (\(_ :: Guess) -> pure empty)+{-# INLINE proceed #-}+++------------------------------------------------------------------------------+-- | Helper class to derive 'explore' generically.+class GExplore (p :: * -> *) f where+ gexplore :: f b -> b++instance TypeError+ ( 'Text "Missing continuation parameter when attempting to derive 'explore'"+ ':$$: 'Text "Expected a type variable, but got "+ ':<>: 'ShowType a+ )+ => GExplore p (K1 _1 a) where+ gexplore = undefined+ {-# INLINE gexplore #-}++instance {-# OVERLAPPING #-} TypeError+ ( 'Text "Missing continuation parameter when attempting to derive 'explore'"+ ':$$: 'Text "Expected a type variable, but the constructor '"+ ':<>: 'Text tyConName+ ':<>: 'Text "' has none"+ )+ => GExplore p (C1 ('MetaCons tyConName _b _c) U1) where+ gexplore = undefined+ {-# INLINE gexplore #-}++instance GExplore p V1 where+ gexplore _ = undefined+ {-# INLINE gexplore #-}++instance Functor p => GExplore p (Rec1 ((->) a)) where+ gexplore (Rec1 z) = z guess+ {-# INLINE gexplore #-}++instance GExplore p Par1 where+ gexplore (Par1 z) = z+ {-# INLINE gexplore #-}++instance GExplore p g => GExplore p (f :*: g) where+ gexplore (_ :*: b) = gexplore @p b+ {-# INLINE gexplore #-}++instance (GExplore p f, GExplore p g) => GExplore p (f :+: g) where+ gexplore (L1 f) = gexplore @p f+ gexplore (R1 g) = gexplore @p g+ {-# INLINE gexplore #-}++instance GExplore p f => GExplore p (M1 _1 _2 f) where+ gexplore (M1 f) = gexplore @p f+ {-# INLINE gexplore #-}+++------------------------------------------------------------------------------+-- | An automatically generated (and unsafe) f-algebra capable of tearing down+-- any functor 'f' with a 'Generic1' instance. 'explore' will 'guess' its way+-- through any continuations it discovers.+explore+ :: forall f a+ . (Generic1 f, GExplore f (Rep1 f))+ => f a+ -> a+explore = gexplore @f . from1+{-# INLINE explore #-}+
+ src/Lib.hs view
@@ -0,0 +1,6 @@+module Lib+ ( someFunc+ ) where++someFunc :: IO ()+someFunc = putStrLn "someFunc"
+ test/Spec.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-}++module Main where++import Control.DeepSeq (NFData (..), force)+import Control.Exception (evaluate)+import Control.Monad.Codensity (improve)+import Control.Monad.Free (MonadFree, Free (..), liftF)+import Control.Monad.Prospect+import GHC.Generics (Generic1)+import Test.Hspec+import Test.Inspection (Result (..), inspectTest, hasNoGenerics)++++main :: IO ()+main = hspec $ do+ let contT = Cont $ const ()+ contI = ContI $ const ()++ describe "prospect" $ do+ testFree "should lazily produce values"+ (Just "hello")+ [ contT+ , contT+ ] $ do+ _ <- cont+ _ <- cont+ pure "hello"++ testFree "should not be cursed for producer patterns"+ (Just ())+ [ Action 1 ()+ , Action 2 ()+ ] $ do+ action 1+ action 2++ testFree "should not crash for a single continuation"+ Nothing+ [ contT+ ] $ do+ cont++ testFree "should stop on an explicit bang pattern"+ Nothing+ [ contT+ ] $ do+ !x <- cont+ pure "error"++ it "should not crash for guess" $ do+ prospect (pure @(Free Pattern) $ guess @Int)+ `shouldBe` (Nothing, [])++ it "should not crash for guess >>= pure" $ do+ prospect (pure @(Free Pattern) (guess @Int) >>= pure)+ `shouldBe` (Nothing, [])++ it "nothing you hold dear is safe" $ do+ let (u, z) = prospect $ do+ action $ guess @Int+ evaluate (force (u, z)) `shouldThrow` (== Guess)++ testFree "should stop before branching"+ Nothing+ [ contT+ , Action 5 ()+ , contT+ ] $ do+ x <- cont+ action 5+ y <- cont+ if x+ then pure True+ else cont++ describe "verify" $ do+ it "should catch guesses" $ do+ verify guess `shouldBe` Nothing @()+ verify (guess + guess) `shouldBe` Nothing @Int+ verify (guess @[()]) `shouldBe` []++ it "should not mess with values" $ do+ verify 0 `shouldBe` Just @Int 0+ verify (1 + 2) `shouldBe` Just @Int 3++ it "should respect strictness otherwise" $ do+ verify (const 3 guess) `shouldBe` Just @Int 3+++ describe "ensure" $ do+ let (a, ms) = prospect $ action 1 >> conti >>= action++ it "should crash if you're foolish" $ do+ a `shouldBe` Just ()+ evaluate (force $ show ms) `shouldThrow` (== Guess)++ it "shouldn't crash if you're wise" $ do+ a `shouldBe` Just ()+ fmap ensure ms+ `shouldBe` [Just (Action 1 ()), Just contI, Nothing]+++ describe "explore" $ do+ it "should optimize away its generics" $ do+ $(inspectTest $ hasNoGenerics 'explorePattern)+ `shouldSatisfy` isSuccess+++data Pattern a+ = Cont (Bool -> a)+ | ContI (Int -> a)+ | Action Int a+ deriving (Functor, Generic1)++instance Eq a => Eq (Pattern a) where+ Cont f == Cont g+ = f True == g True+ && f False == g False+ ContI _ == ContI _ = True+ Action i a == Action j b+ = i == j+ && a == b+ _ == _ = False++instance Show (Pattern a) where+ show (Cont _) = "Cont"+ show (ContI _) = "ContI"+ show (Action i _ ) = "Action " ++ show i+++instance NFData a => NFData (Pattern a) where+ rnf (Cont f) = seq f ()+ rnf (ContI f) = seq f ()+ rnf (Action i a) = seq i ()+++cont :: MonadFree Pattern m => m Bool+cont = liftF $ Cont id+++conti :: MonadFree Pattern m => m Int+conti = liftF $ ContI id+++action :: MonadFree Pattern m => Int -> m ()+action i = liftF $ Action i ()+++explorePattern :: Pattern (Free Pattern a) -> Free Pattern a+explorePattern = explore+++isSuccess :: Result -> Bool+isSuccess (Success _) = True+isSuccess (Failure _) = False+++testFree+ :: (Eq a, Show a)+ => String+ -> Maybe a+ -> [Pattern ()]+ -> (forall m. (MonadFree Pattern m) => m a)+ -> SpecWith (Arg Expectation)+testFree z v cs m =+ let (a, ms) = prospect $ improve m+ in it z $ do+ a `shouldBe` v+ ms `shouldBe` cs+