add stacksafe version of FreeAp

bower.json

@@ -8,5 +8,8 @@
     "purescript-applicative-lists": "^0.1.0",
     "purescript-const": "^2.0.0",
     "purescript-day": "^7.0.0"
+  },
+  "resolutions": {
+    "purescript-lists": "^3.0.0"
   }
 }

src/FreeApStackSafe.purs

@@ -0,0 +1,152 @@
+module FreeApStackSafe
+  ( FreeAp
+  , liftFreeAp
+  , retractFreeAp
+  , foldFreeAp
+  , hoistFreeAp
+  , analyzeFreeAp
+  ) where
+
+import Prelude
+import Data.Const (Const(..))
+import Data.Either (Either(..))
+import Data.List (List(..))
+import Data.List.NonEmpty as NEL
+import Data.Monoid (class Monoid)
+import Data.Newtype (unwrap)
+import Data.NonEmpty ((:|))
+import Data.Tuple (Tuple(..))
+import Unsafe.Coerce (unsafeCoerce)
+
+-- NOTE is not in the version of ps-list this lib depends on
+consNEL :: forall a. a -> NEL.NonEmptyList a -> NEL.NonEmptyList a
+consNEL y (NEL.NonEmptyList (x :| xs)) = NEL.NonEmptyList (y :| (Cons x xs))
+
+
+-- | The free applicative functor for a type constructor `f`.
+data FreeAp f a
+  = Pure a
+  | Lift (f a)
+  | Ap (FreeAp f (Val -> a)) (FreeAp f Val)
+
+data Val
+
+-- | Lift a value described by the type constructor `f` into
+-- | the free applicative functor.
+liftFreeAp :: forall f a. f a -> FreeAp f a
+liftFreeAp = Lift
+
+type ApFunc g = { func :: g (Val -> Val), count :: Int }
+type FuncStack g = List (ApFunc g)
+type ValStack f = NEL.NonEmptyList (FreeAp f Val)
+type Stack f g = Tuple (FuncStack g) (ValStack f)
+
+-- | 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 nat z =
+  unsafeToG $ go $ Tuple Nil (NEL.singleton $ unsafeToFVal z)
+  where
+  unsafeToG :: g Val -> g a
+  unsafeToG = unsafeCoerce
+
+  unsafeToFVal :: forall f' a'. FreeAp f' a' -> FreeAp f' Val
+  unsafeToFVal = unsafeCoerce
+
+  go :: Stack f g -> g Val
+  go stck@(Tuple fStack (NEL.NonEmptyList (val :| vals))) =
+    let zzz = stck
+    in case val of
+      Pure a -> case goApply fStack vals (pure a) of
+        Left x -> x
+        Right s -> go s
+      Lift a -> case goApply fStack vals (nat a) of
+        Left x -> x
+        Right s -> go s
+      Ap l r ->
+        let nextVals = NEL.NonEmptyList (r :| vals)
+        in go $ goLeft fStack nextVals nat l 1
+
+goApply
+  :: forall f g
+  . Applicative g
+  => FuncStack g
+  -> List (FreeAp f Val)
+  -> g Val
+  -> Either (g Val) (Stack f g)
+goApply fStack vals gVal =
+  case fStack of
+    Nil -> Left gVal
+    Cons f fs ->
+      let gRes = f.func <*> gVal
+      in if f.count == 1 then
+        case fs of
+          Nil ->
+            -- here vals must be empty
+            Left gRes
+          _ -> goApply fs vals gRes
+        else
+          case vals of
+            Nil -> Left gRes
+            Cons val vals' ->
+              Right $ Tuple
+                (Cons { func: unsafeToGFunc gRes, count: f.count - 1 } fs)
+                (NEL.NonEmptyList (val :| vals'))
+  where
+  unsafeToGFunc :: g Val -> g (Val -> Val)
+  unsafeToGFunc = unsafeCoerce
+
+goLeft
+  :: forall f g
+  . Applicative g
+  => FuncStack g
+  -> ValStack f
+  -> (f ~> g)
+  -> FreeAp f (Val -> Val)
+  -> Int
+  -> Stack f g
+goLeft fStack valStack nat func count = case func of
+  Pure a -> Tuple (Cons { func: pure a, count } fStack) valStack
+  Lift a -> Tuple (Cons { func: nat a, count } fStack) valStack
+  Ap l r -> goLeft fStack (consNEL r valStack) nat (unsafeToFunc l) (count + 1)
+  where
+  unsafeToFunc :: FreeAp f (Val -> Val -> Val) -> FreeAp f (Val -> Val)
+  unsafeToFunc = unsafeCoerce
+
+-- | 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 = foldFreeAp id
+
+-- | 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 f = foldFreeAp (f >>> liftFreeAp)
+
+-- | 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)
+
+mkAp :: forall f a b. FreeAp f (b -> a) -> FreeAp f b -> FreeAp f a
+mkAp fba fb = Ap (coerceFunc fba) (coerceValue fb)
+  where
+  coerceFunc :: FreeAp f (b -> a) -> FreeAp f (Val -> a)
+  coerceFunc = unsafeCoerce
+
+  coerceValue :: FreeAp f b -> FreeAp f Val
+  coerceValue = unsafeCoerce
+
+instance functorFreeAp :: Functor (FreeAp f) where
+  map f x = mkAp (Pure f) x
+
+instance applyFreeAp :: Apply (FreeAp f) where
+  apply fba fb = mkAp fba fb
+
+instance applicativeFreeAp :: Applicative (FreeAp f) where
+  pure = Pure
+
+instance showFreeAp :: Show (FreeAp f a) where
+  show = case _ of
+    Pure a -> "(Pure Val)"
+    Lift f -> "(Lift F)"
+    Ap l r -> "(Ap " <> show l <> " " <> show r <> ")"

src/Main.purs

@@ -20,66 +20,94 @@ import FreeAp9ccd7db as FreeApOld
 
 import FreeAp71acf67 as FreeApNew
 
+import FreeApStackSafe as FreeApStackSafe
+
 import FreeApDay as FreeApDay
 
 trials :: Int
 trials = 1
 
-benchRetractFreeAp :: Int -> String -> Benchmark
-benchRetractFreeAp size label = mkBenchmark
-  { slug: "retractFreeAp-71acf67-9ccd7db-day-" <> toLower label
+benchRetractFreeAp :: Boolean -> Int -> String -> Benchmark
+benchRetractFreeAp shouldRunOld size label = mkBenchmark
+  { slug: "retractFreeAp-71acf67" <> (if shouldRunOld then "-9ccd7db" else "") <> "-day-safe-" <> toLower label
   , title: "retractFreeAp (sequence [ FreeAp f a, ..., FreeAp f z ]) - " <> label
   , sizes: (1..20) <#> (_ * size)
   , sizeInterpretation: "Number of elements in the array"
   , inputsPerSize: trials
   , gen: \n -> { old: _
                , new: _
                , day: _
+               , safe: _
                } <$> vectorOf n (pure (FreeApOld.liftFreeAp (Identity unit)))
                  <*> vectorOf n (pure (FreeApNew.liftFreeAp (Identity unit)))
                  <*> vectorOf n (pure (FreeApDay.liftFreeAp (Identity unit)))
-  , functions: [ benchFn "FreeAp Old @ 9ccd7db" (\a -> FreeApOld.retractFreeAp (sequence a.old))
-               , benchFn "FreeAp New @ 71acf67" (\a -> FreeApNew.retractFreeAp (sequence a.new))
+                 <*> vectorOf n (pure (FreeApStackSafe.liftFreeAp (Identity unit)))
+  , functions: [ benchFn "FreeAp New @ 71acf67" (\a -> FreeApNew.retractFreeAp (sequence a.new))
                , benchFn "FreeAp Day" (\a -> FreeApDay.retractFreeAp (sequence a.day))
-               ]
+               , benchFn "FreeAp stacksafe" (\a -> FreeApStackSafe.retractFreeAp (sequence a.safe))
+               ]  <> oldBench
   }
+  where
+  oldBench =
+    if shouldRunOld then
+      [ benchFn "FreeAp Old @ 9ccd7db" (\a -> FreeApOld.retractFreeAp (sequence a.old)) ]
+    else []
 
 type A = { old :: Array (FreeApOld.FreeAp Identity Unit)
          , new :: Array (FreeApNew.FreeAp Identity Unit)
          , day :: Array (FreeApDay.FreeAp Identity Unit)
+         , safe :: Array (FreeApStackSafe.FreeAp Identity Unit)
          }
 
-benchFoldFreeAp :: Int -> String -> Benchmark
-benchFoldFreeAp size label = mkBenchmark
-  { slug: "foldFreeAp-71acf67-9ccd7db-day-" <> toLower label
+benchFoldFreeAp :: Boolean -> Boolean -> Int -> String -> Benchmark
+benchFoldFreeAp shouldRunOld shouldRunDay size label = mkBenchmark
+  { slug: "foldFreeAp-71acf67" <> (if shouldRunOld then "-9ccd7db" else "") <> (if shouldRunDay then "-day" else "")<> "-safe-" <> toLower label
   , title: "foldFreeAp (a -> a) (k <$> FreeAp f a <* FreeAp f b <* ... <* FreeAp f z) - " <> label
   , sizes: (1..12) <#> (_ * size)
   , sizeInterpretation: "Number of elements in the array"
   , inputsPerSize: trials
   , gen: \n -> { old: _
                , new: _
                , day: _
+               , safe: _
                } <$> vectorOf n (pure (FreeApOld.liftFreeAp (Identity unit)))
                  <*> vectorOf n (pure (FreeApNew.liftFreeAp (Identity unit)))
                  <*> vectorOf n (pure (FreeApDay.liftFreeAp (Identity unit)))
-  , functions: [ benchFn "FreeAp Old @ 9ccd7db" (\(a :: A) ->
-                   maybe (pure unit)
-                         (\{head, tail} -> FreeApOld.foldFreeAp (\a' -> a') (id <$> (foldl (\x y -> x <* y) head tail)))
-                         (uncons a.old))
-               , benchFn "FreeAp New @ 71acf67" (\(a :: A) ->
+                 <*> vectorOf n (pure (FreeApStackSafe.liftFreeAp (Identity unit)))
+  , functions: [ benchFn "FreeAp New @ 71acf67" (\(a :: A) ->
                    maybe (pure unit)
                          (\{head, tail} -> FreeApNew.foldFreeAp (\a' -> a') (id <$> (foldl (\x y -> x <* y) head tail)))
                          (uncons a.new))
-               , benchFn "FreeAp Day" (\(a :: A) ->
+               , benchFn "FreeAp stacksafe" (\(a :: A) ->
                    maybe (pure unit)
-                         (\{head, tail} -> FreeApDay.foldFreeAp (\a' -> a') (id <$> (foldl (\x y -> x <* y) head tail)))
-                         (uncons a.day))
-               ]
+                         (\{head, tail} -> FreeApStackSafe.foldFreeAp (\a' -> a') (id <$> (foldl (\x y -> x <* y) head tail)))
+                         (uncons a.safe))
+               ] <> dayBench <> oldBench
   }
+  where
+  dayBench = 
+    if shouldRunDay then 
+      [ benchFn "FreeAp Day" (\(a :: A) ->
+          maybe (pure unit)
+                (\{head, tail} -> FreeApDay.foldFreeAp (\a' -> a') (id <$> (foldl (\x y -> x <* y) head tail)))
+                (uncons a.day))
+      ]
+    else []
+  oldBench = 
+    if shouldRunOld then 
+      [ benchFn "FreeAp Old @ 9ccd7db" (\(a :: A) ->
+          maybe (pure unit)
+                (\{head, tail} -> FreeApOld.foldFreeAp (\a' -> a') (id <$> (foldl (\x y -> x <* y) head tail)))
+                (uncons a.old))
+      ]
+    else []
 
 main :: forall eff. Eff (BenchEffects eff) Unit
-main = runSuite [ benchRetractFreeAp 2 "Small"
-                , benchFoldFreeAp 1 "Small"
-                , benchRetractFreeAp 100 "Large"
-                , benchFoldFreeAp 10 "Large"
+main = runSuite [ benchRetractFreeAp true 2 "Small"
+                , benchFoldFreeAp true true 1 "Small"
+                , benchRetractFreeAp true 100 "Large"
+                , benchRetractFreeAp false 125 "Large"
+                , benchFoldFreeAp true true 10 "Large"
+                , benchFoldFreeAp false true 180 "Large"
+                , benchFoldFreeAp false false 250 "Large"
                 ]