Initial sketch of a free applicative implementation

The goal of this implementation is to improve performance
characteristics of the operations of the free applicative functor in
PureScript.

Reference #7

Reference #8

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
 

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"
   }
 }

package.json

@@ -0,0 +1,8 @@
+{
+  "name": "purescript-freeap",
+  "private": true,
+  "license": "MIT",
+  "scripts": {
+    "test": "node -e 'require(\"./output/Test.Main\").main()'"
+  }
+}

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))

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

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