diff --git a/README.md b/README.md index 530318f..24ef211 100644 --- a/README.md +++ b/README.md @@ -4,6 +4,8 @@ Free applicative functors for PureScript. See the following reference for further information. * [Free Applicative Functors](http://arxiv.org/abs/1403.0749) (Capriotti and Kaposi 2014) +* [Free Applicative Functors in Haskell](https://www.eyrie.org/~zednenem/2013/05/27/freeapp) (Menendez 2013) +* [The fraxl package](https://hackage.haskell.org/package/fraxl) (Fancher 2016) ## Installation diff --git a/bower.json b/bower.json index 5a38fa5..2630be0 100644 --- a/bower.json +++ b/bower.json @@ -10,14 +10,10 @@ "url": "git://github.com/ethul/purescript-freeap.git" }, "dependencies": { - "purescript-exists": "^2.0.0", - "purescript-const": "^2.0.0" + "purescript-const": "^2.0.0", + "purescript-applicative-lists": "^0.1.0" }, "devDependencies": { - "purescript-either": "^2.0.0", - "purescript-integers": "^2.0.0", - "purescript-generics": "^3.1.0", - "purescript-console": "^2.0.0", - "purescript-exceptions": "^2.0.0" + "purescript-test-unit": "^10.0.1" } } diff --git a/docs/Control/Applicative/Free.md b/docs/Control/Applicative/Free.md deleted file mode 100644 index f81470f..0000000 --- a/docs/Control/Applicative/Free.md +++ /dev/null @@ -1,62 +0,0 @@ -## Module Control.Applicative.Free - -#### `FreeAp` - -``` purescript -data FreeAp f a -``` - -The free applicative functor for a type constructor `f`. - -##### Instances -``` purescript -Functor (FreeAp f) -Apply (FreeAp f) -Applicative (FreeAp f) -``` - -#### `liftFreeAp` - -``` purescript -liftFreeAp :: forall f a. f a -> FreeAp f a -``` - -Lift a value described by the type constructor `f` into -the free applicative functor. - -#### `retractFreeAp` - -``` purescript -retractFreeAp :: forall f a. Applicative f => FreeAp f a -> f a -``` - -Run a free applicative functor using the applicative instance for -the type constructor `f`. - -#### `foldFreeAp` - -``` purescript -foldFreeAp :: forall f g a. Applicative g => (f ~> g) -> FreeAp f a -> g a -``` - -Run a free applicative functor with a natural transformation from -the type constructor `f` to the applicative functor `g`. - -#### `hoistFreeAp` - -``` purescript -hoistFreeAp :: forall f g a. (f ~> g) -> FreeAp f a -> FreeAp g a -``` - -Natural transformation from `FreeAp f a` to `FreeAp g a` given a -natural transformation from `f` to `g`. - -#### `analyzeFreeAp` - -``` purescript -analyzeFreeAp :: forall f m a. Monoid m => (forall b. f b -> m) -> FreeAp f a -> m -``` - -Perform monoidal analysis over the free applicative functor `f`. - - diff --git a/package.json b/package.json new file mode 100644 index 0000000..4d0b0df --- /dev/null +++ b/package.json @@ -0,0 +1,8 @@ +{ + "name": "purescript-freeap", + "private": true, + "license": "MIT", + "scripts": { + "test": "node -e 'require(\"./output/Test.Main\").main()'" + } +} diff --git a/src/Control/Applicative/Free.purs b/src/Control/Applicative/Free.purs index cb92d69..f67f0a3 100644 --- a/src/Control/Applicative/Free.purs +++ b/src/Control/Applicative/Free.purs @@ -1,5 +1,15 @@ +-- | This module defines a free applicative functor. +-- | +-- | The implementation of this module is based on Dave Menendez and +-- | Will Fancher's work. +-- | +-- | See [Free Applicative Functors in Haskell](https://www.eyrie.org/~zednenem/2013/05/27/freeapp) (Menendez 2013) +-- | +-- | See [The fraxl package](https://hackage.haskell.org/package/fraxl) (Fancher 2016) module Control.Applicative.Free ( FreeAp + , freeAp + , unFreeAp , liftFreeAp , retractFreeAp , foldFreeAp @@ -9,53 +19,51 @@ module Control.Applicative.Free import Prelude hiding (ap) +import Data.ApList (ApList) +import Data.ApList as ApList import Data.Const (Const(..)) -import Data.Exists (Exists, mkExists, runExists) import Data.Monoid (class Monoid) import Data.Newtype (unwrap) +import Data.Tuple (Tuple(..)) -- | The free applicative functor for a type constructor `f`. -data FreeAp f a = Pure a | Ap (Exists (ApF f a)) +newtype FreeAp f a = FreeAp (forall u y z. (forall x. (x -> y) -> ApList f x -> z) -> (u -> a -> y) -> ApList f u -> z) -data ApF f a i = ApF (Unit -> f i) (Unit -> FreeAp f (i -> a)) +freeAp :: forall f a. (forall u y z. (forall x. (x -> y) -> ApList f x -> z) -> (u -> a -> y) -> ApList f u -> z) -> FreeAp f a +freeAp = FreeAp -ap :: forall f a i. (Unit -> f i) -> (Unit -> FreeAp f (i -> a)) -> FreeAp f a -ap v k = Ap (mkExists (ApF v k)) +unFreeAp :: forall f a. FreeAp f a -> (forall u y z. (forall x. (x -> y) -> ApList f x -> z) -> (u -> a -> y) -> ApList f u -> z) +unFreeAp (FreeAp x) = x -- | Lift a value described by the type constructor `f` into -- | the free applicative functor. liftFreeAp :: forall f a. f a -> FreeAp f a -liftFreeAp a = ap (\_ -> a) (\_ -> Pure id) +liftFreeAp a = freeAp (\k f s -> k (\(Tuple a' s') -> f s' a') (ApList.cons a s)) -- | Run a free applicative functor using the applicative instance for -- | the type constructor `f`. retractFreeAp :: forall f a. Applicative f => FreeAp f a -> f a -retractFreeAp (Pure a) = pure a -retractFreeAp (Ap x) = runExists (\(ApF v k') -> apply (retractFreeAp (k' unit)) (v unit)) x +retractFreeAp fa = unFreeAp fa (\f s -> f <$> ApList.reduce s) (\_ -> id) ApList.nil -- | Run a free applicative functor with a natural transformation from -- | the type constructor `f` to the applicative functor `g`. foldFreeAp :: forall f g a. Applicative g => (f ~> g) -> FreeAp f a -> g a -foldFreeAp k (Pure a) = pure a -foldFreeAp k (Ap x) = runExists (\(ApF v k') -> apply (map (flip id) (k (v unit))) (foldFreeAp k (k' unit))) x +foldFreeAp k = retractFreeAp <<< hoistFreeAp k -- | Natural transformation from `FreeAp f a` to `FreeAp g a` given a -- | natural transformation from `f` to `g`. hoistFreeAp :: forall f g a. (f ~> g) -> FreeAp f a -> FreeAp g a -hoistFreeAp k (Pure a) = Pure a -hoistFreeAp k (Ap x) = runExists (\(ApF v k') -> ap (\_ -> k (v unit)) (\_ -> hoistFreeAp k (k' unit))) x +hoistFreeAp g x = freeAp (\k f s -> unFreeAp x (\f' s' -> ApList.rebase (ApList.hoist g s') k (\v u -> f v (f' u)) s) (const id) ApList.nil) -- | Perform monoidal analysis over the free applicative functor `f`. analyzeFreeAp :: forall f m a. Monoid m => (forall b. f b -> m) -> FreeAp f a -> m analyzeFreeAp k = unwrap <<< foldFreeAp (Const <<< k) instance functorFreeAp :: Functor (FreeAp f) where - map k (Pure a) = Pure (k a) - map k (Ap x) = runExists (\(ApF v k') -> ap v (\_ -> map ((<<<) k) (k' unit))) x + map g x = freeAp (\k f -> unFreeAp x k (\s -> f s <<< g)) instance applyFreeAp :: Apply (FreeAp f) where - apply (Pure k) f = map k f - apply (Ap x) f = runExists (\(ApF v k') -> ap v (\_ -> apply (map flip (k' unit)) f)) x + apply x y = freeAp (\k f -> unFreeAp y (unFreeAp x k) (\s a g -> f s (g a))) instance applicativeFreeAp :: Applicative (FreeAp f) where - pure = Pure + pure a = freeAp (\k f -> k (_ `f` a)) diff --git a/test/Test/Control/Applicative/Free/Validation.purs b/test/Test/Control/Applicative/Free/Validation.purs index e6c114c..db5aa7c 100644 --- a/test/Test/Control/Applicative/Free/Validation.purs +++ b/test/Test/Control/Applicative/Free/Validation.purs @@ -1,9 +1,9 @@ module Test.Control.Applicative.Free.Validation - ( User + ( User(..) , runForm ) where -import Prelude (class Show, show, (<<<), (==), (<$>), (<*>), (<>)) +import Prelude (class Eq, class Show, show, (<<<), (==), (<$>), (<*>), (<>), (&&)) import Control.Applicative.Free (FreeAp, foldFreeAp, liftFreeAp) import Control.Monad.Eff.Exception.Unsafe (unsafeThrow) @@ -52,3 +52,9 @@ runForm first last age = instance showUser :: Show User where show (User m) = m.firstName <> " " <> m.lastName <> " " <> show m.age + +instance eqUser :: Eq User where + eq (User m) (User n) = + m.firstName == n.firstName && + m.lastName == n.lastName && + m.age == n.age diff --git a/test/Test/Main.purs b/test/Test/Main.purs index b7e7daa..da3d6a8 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -2,22 +2,36 @@ module Test.Main where import Prelude (Unit, bind) +import Data.Either (Either(..)) + +import Control.Monad.Aff.AVar (AVAR) import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, log, logShow) +import Control.Monad.Eff.Console (CONSOLE) import Test.Control.Applicative.Free.Validation as Validation import Test.Control.Applicative.Free as FreeTest -main :: Eff (console :: CONSOLE) Unit -main = do - log "\nvalid case:" - logShow (Validation.runForm "Joe" "Smith" "28") +import Test.Unit (suite, test) +import Test.Unit.Assert as Assert +import Test.Unit.Console (TESTOUTPUT) +import Test.Unit.Main (runTest) + +main :: forall eff. Eff (avar :: AVAR, console :: CONSOLE, testOutput :: TESTOUTPUT | eff) Unit +main = runTest do + suite "validation" do + test "valid input" do + Assert.equal (Right (Validation.User { firstName: "Joe", lastName: "Smith", age: 28 })) + (Validation.runForm "Joe" "Smith" "28") - log "\nempty last name:" - logShow (Validation.runForm "Larry" "" "45") + test "empty last name" do + Assert.equal (Left "Last name: Invalid NES") + (Validation.runForm "Larry" "" "45") - log "\ninvalid age:" - logShow (Validation.runForm "Sue" "Larry" "A") + test "invalid age" do + Assert.equal (Left "Age: Invalid Int") + (Validation.runForm "Sue" "Larry" "A") - log "\nanalyze:" - logShow FreeTest.checkAnalyze + suite "analyze" do + test "checkAnalyze" do + Assert.equal (Right "AB") + FreeTest.checkAnalyze