salmon-core (empty) → 0.1.0.0

raw patch · 11 files changed

+484/−0 lines, 11 filesdep +aesondep +basedep +comonad

Dependencies added: aeson, base, comonad, containers, contravariant, free, text

Files

• CHANGELOG.md +5/−0
• LICENSE +29/−0
• salmon-core.cabal +47/−0
• src/Salmon/FoldBranch.hs +28/−0
• src/Salmon/Op/Actions.hs +46/−0
• src/Salmon/Op/Eval.hs +17/−0
• src/Salmon/Op/G.hs +29/−0
• src/Salmon/Op/Graph.hs +44/−0
• src/Salmon/Op/GraphFold.hs +77/−0
• src/Salmon/Op/OpGraph.hs +51/−0
• src/Salmon/Op/Track.hs +111/−0

@@ -0,0 +1,5 @@+# Revision history for salmon-core++## 0.1.0.0 -- unreleased++* First release.

@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2022-2026, Lucas DiCioccio+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its+   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 HOLDER 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.

@@ -0,0 +1,47 @@+cabal-version:      2.4+name:               salmon-core+version:            0.1.0.0+synopsis:           Idempotent operations as DAGs: the core graph and evaluation primitives.+description:        Salmon expresses infrastructure, provisioning and CI/CD operations as DAGs of idempotent operations with uniform up/down/check semantics. This package holds the core algebraic-graph (OpGraph, Track, Eval) representation, with minimal dependencies.+homepage:           https://lucasdicioccio.github.io/salmon/+bug-reports:        https://github.com/lucasdicioccio/salmon/issues+license:            BSD-3-Clause+license-file:       LICENSE+author:             Lucas DiCioccio+maintainer:         lucas@dicioccio.fr+copyright:          2022-2026 Lucas DiCioccio+category:           Development+build-type:         Simple+tested-with:        GHC == 9.10.3+extra-doc-files:    CHANGELOG.md++source-repository head+    type:     git+    location: https://github.com/lucasdicioccio/salmon+    subdir:   salmon-core++library+    exposed-modules: Salmon.Op.Graph+                   , Salmon.Op.OpGraph+                   , Salmon.Op.Actions+                   , Salmon.Op.Eval+                   , Salmon.Op.GraphFold+                   , Salmon.Op.Track+                   , Salmon.Op.G+                   , Salmon.FoldBranch+    build-depends:    base >=4.16.3.0 && <4.22+                    , aeson+                    , comonad+                    , containers+                    , contravariant+                    , free+                    , text+    hs-source-dirs:   src+    default-language: Haskell2010+    default-extensions: KindSignatures+                      , DataKinds+                      , OverloadedStrings+                      , DeriveFunctor+                      , OverloadedRecordDot+                      , TypeApplications+                      , ScopedTypeVariables

@@ -0,0 +1,28 @@+module Salmon.FoldBranch where++import Control.Comonad.Cofree (Cofree (..))++{- | Maps the branch of a Cofree comonad by accumulating a function+from tree to leaves.++Unlike a typical fold, at each branch of the the Cofree, the accumulator+forks.++This function is useful to turn nodes into paths from the Cofree seed to each+node.+-}+foldBranch ::+    forall t item accum.+    (Functor t) =>+    (accum -> item -> accum) ->+    accum ->+    Cofree t item ->+    Cofree t accum+foldBranch f pfx (x :< xs) =+    path :< subtree+  where+    path :: accum+    path = f pfx x++    subtree :: t (Cofree t accum)+    subtree = fmap (foldBranch f path) xs

@@ -0,0 +1,46 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}++module Salmon.Op.Actions where++import Data.Text (Text)++{- | Actions are bundles of named effects ongoing in a given monad.++A special action name Actionless is a noop and allows to define+a Monoid on a decorated bag of structures.++`Actions e` is isomorphic to `Maybe (Act e)`.+-}+data Actions e+    = -- | a true no-op action as in, it behaves as a mempty for the Monoid instance+      Actionless+    | -- | a proper set of actions+      Actions (Act e)+    deriving (Show, Functor, Foldable, Traversable)++-- | The monoidal actions revert the up and down.+instance (Semigroup e) => Semigroup (Actions e) where+    Actionless <> b = b+    a <> Actionless = a+    (Actions a) <> (Actions b) =+        Actions $+            Act+                (shorthand a <> "|" <> shorthand b)+                (extension a <> extension b)++-- | The mempty is Actionless+instance (Semigroup e) => Monoid (Actions e) where+    mempty = Actionless++-- | A name for something.+type ShortHand = Text++-- | Base action bag of function.+data Act extension = Act+    { shorthand :: ShortHand+    , extension :: extension+    }+    deriving (Show, Functor, Foldable, Traversable)

@@ -0,0 +1,17 @@+{-# LANGUAGE ApplicativeDo #-}++module Salmon.Op.Eval where++import Control.Comonad.Cofree (Cofree, unfoldM)++import Salmon.Op.Graph+import Salmon.Op.OpGraph++-- | Expands all predecessors of an operation graph.+expand :: (Monad m) => OpGraph m node -> m (Cofree Graph (OpGraph m node))+expand = unfoldM expandOne+  where+    expandOne :: (Applicative m) => OpGraph m node -> m (OpGraph m node, (Graph (OpGraph m node)))+    expandOne op = do+        preds <- op.predecessors+        pure (op, preds)

@@ -0,0 +1,29 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}++module Salmon.Op.G where++import Control.Comonad.Cofree (Cofree (..))+import Data.Aeson (FromJSON, ToJSON (..), (.:), (.=))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson+import Data.Coerce (coerce)++import Salmon.Op.Graph (Graph)++-- | Helper to provide Aeson instances for (Cofree Graph a).+newtype G a = G {getCofreeGraph :: (Cofree Graph a)}+    deriving (Functor, Foldable)++instance (ToJSON a) => ToJSON (G a) where+    toJSON (G (x :< p)) =+        Aeson.object+            [ "node" .= toJSON x+            , "preds" .= (toJSON $ fmap G p)+            ]++instance (FromJSON a) => FromJSON (G a) where+    parseJSON = Aeson.withObject "cofree layer" $ \o -> do+        obj <- o .: "node"+        preds <- o .: "preds" :: Aeson.Parser (Graph (G a))+        pure $ G $ obj :< fmap coerce preds

@@ -0,0 +1,44 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE PolyKinds #-}++module Salmon.Op.Graph where++import Data.Aeson (FromJSON, ToJSON)+import Data.Functor.Classes+import GHC.Generics++{- Graph is an algebraic graph from the alga paper.++   We depart from the alga paper by using a single constructor named `Vertices+[a]` which is isomorphic to the branches `empty | vertex | unconnected-overlay`+in Alga. This small digression allows us to be more compact.++-- todo: consider playing with t instead of Graph as recursion could be recovered via a (Fix GraphF)+-}+data Graph a+    = Vertices [a]+    | Connect (Graph a) (Graph a)+    | Overlay (Graph a) (Graph a)+    deriving (Show, Ord, Eq, Functor, Foldable, Traversable, Generic)++instance (FromJSON a) => FromJSON (Graph a)+instance (ToJSON a) => ToJSON (Graph a)++instance Show1 Graph where+    liftShowsPrec f g n gr =+        case gr of+            Vertices xs -> g xs+            Connect gr1 gr2 ->+                let+                    s1 = liftShowsPrec f g n gr1+                    s2 = liftShowsPrec f g n gr2+                 in+                    \sfx -> "(" ++ s1 ("->" ++ s2 (")" ++ sfx))+            Overlay gr1 gr2 ->+                let+                    s1 = liftShowsPrec f g n gr1+                    s2 = liftShowsPrec f g n gr2+                 in+                    \sfx -> "{" ++ s1 ("," ++ s2 ("}" ++ sfx))

@@ -0,0 +1,77 @@+{-# LANGUAGE ScopedTypeVariables #-}++{- | Generic traversal primitives over 'Cofree' 'Graph' trees.++'Graph' already derives 'Foldable'/'Functor'/'Traversable', which gives+pre-order traversal for free (see 'Data.Foldable.toList'). 'foldWithContext'+covers the shape pre-order alone doesn't: a fold that carries context down+from ancestor to descendant while remembering which 'Graph' constructor+connected them. Generic over any node type and knows nothing about ops,+actions, or refs — that stays in the caller.++This module used to also offer a post-order visitor+(@postOrderM@), written for "Salmon.Actions.UpDown".'Salmon.Actions.UpDown.upTree'+to propagate "a predecessor failed, so skip me too" down a subtree. Milestone+4 of @specs\/per-node-state-machines.md@ moved both drivers onto+"Salmon.Op.Dag", which answers that question from the collapsed magma+instead of a tree walk, and nothing else in this repository ever called it —+dropped rather than kept speculative; recover it from history if a caller+needs it again.+-}+module Salmon.Op.GraphFold (+    Shape (..),+    Branch (..),+    foldWithContext,+) where++import Control.Comonad.Cofree (Cofree (..))++import Salmon.Op.Graph++-- | Which 'Graph' constructor a node's own predecessors are wrapped in.+data Shape = SVertices | SOverlay | SConnect+    deriving (Show, Eq, Ord)++-- | Which arm of its parent's 'Graph' constructor a child was reached+-- through.+data Branch+    = FromVertices+    | FromOverlayL+    | FromOverlayR+    | FromConnectL+    | FromConnectR+    deriving (Show, Eq, Ord)++{- | Walk a 'Cofree' 'Graph', calling @onNode ctx shape x@ at every node+(told the inherited context and the 'Shape' of its own predecessor graph),+and folding results with '(<>)'. @nextCtx@ computes the context handed down+to a child, told which 'Branch' connects the current node to that child —+this is how e.g. "skip through nodes with no real payload" is implemented by+callers: return the unchanged @ctx@ instead of a new one.+-}+foldWithContext ::+    forall a ctx r.+    (Monoid r) =>+    ctx ->+    (ctx -> Shape -> a -> r) ->+    (ctx -> Branch -> a -> ctx) ->+    Cofree Graph a ->+    r+foldWithContext ctx0 onNode nextCtx = go ctx0+  where+    go :: ctx -> Cofree Graph a -> r+    go ctx (x :< gr) = onNode ctx (shapeOf gr) x <> descend ctx x gr++    shapeOf :: Graph b -> Shape+    shapeOf (Vertices _) = SVertices+    shapeOf (Overlay _ _) = SOverlay+    shapeOf (Connect _ _) = SConnect++    descend :: ctx -> a -> Graph (Cofree Graph a) -> r+    descend ctx x (Vertices cs) = foldMap (go (nextCtx ctx FromVertices x)) cs+    descend ctx x (Overlay c1 c2) =+        foldMap (go (nextCtx ctx FromOverlayL x)) c1+            <> foldMap (go (nextCtx ctx FromOverlayR x)) c2+    descend ctx x (Connect c1 c2) =+        foldMap (go (nextCtx ctx FromConnectL x)) c1+            <> foldMap (go (nextCtx ctx FromConnectR x)) c2

@@ -0,0 +1,51 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE PolyKinds #-}++module Salmon.Op.OpGraph where++import Data.Functor.Classes+import Data.Kind (Type)+import Salmon.Op.Graph++-------------------------------------------------------------------------------++{- | An OpGraph is a complicated object.++- An OpGraph feels like a Comonad as it is centered on a node and has a recipe+  to find neighbors.+- An OpGraph feels like a program chunk because the recipe to find neighbors+  actually perfoms an effect.+- An OpGraph feels like a graph because the node on which is centered is+  somehow connected to a full graph of OpGraphs.++In Salmon, we want to define operations like "create a file" or "turn a server+up" as nodes.  It is really powerful to be able to see both operations+uniformly. However, to turn a server up, one needs many more steps than for+creating a file.+-}+data OpGraph (meval :: Type -> Type) node = OpGraph+    { predecessors :: meval (Graph (OpGraph meval node))+    , node :: node+    }+    deriving (Functor, Foldable, Traversable)++instance (Show a) => Show (OpGraph m a) where+    show gr = show gr.node++-------------------------------------------------------------------------------++-- | Injects a dependency so that op1 `inject` op2 is adding op2 as Connect-ed predecessor to op1+inject :: (Applicative m) => OpGraph m a -> OpGraph m a -> OpGraph m a+inject x y =+    x+        { predecessors = Connect <$> pure (Vertices [y]) <*> predecessors x+        }++-- | Injects a dependency so that op1 `inject` op2 is adding op2 as Overlay-ed predecessor to op1+overlaid :: (Applicative m) => OpGraph m a -> OpGraph m a -> OpGraph m a+overlaid x y =+    x+        { predecessors =+            Overlay <$> pure (Vertices [y]) <*> predecessors x+        }

@@ -0,0 +1,111 @@+-- A contravariant functor to track dependencies in a "serializer" style:+-- you defined basic nodes and then compose them.+module Salmon.Op.Track where++import Data.Functor.Contravariant (Contravariant (..), (>$<))+import Data.Functor.Contravariant.Divisible (Divisible (..), divided)+import Salmon.Op.Graph+import Salmon.Op.OpGraph++(>*<) :: (Divisible f) => f a -> f b -> f (a, b)+(>*<) = divided++infixr 5 >*<++-------------------------------------------------------------------------------++{- | A Track is a promise to make an OpGraph by consuming a given item.++In Salmon, a Track is a mechanism to say "yeah, if you need an database, I have a way to get you one".+Track has nice properties, by virtue of being a Contravariant and Divisible functor.++Track also has nice combinators, by virtue of producing an OpGraph, which is a+complex comonadic-ish object with combinators.+-}+newtype Track m n a+    = Track {run :: a -> OpGraph m n}++instance Contravariant (Track m n) where+    contramap f s = Track (run s . f)++instance (Applicative m, Monoid n) => Divisible (Track m n) where+    conquer = Track (const $ OpGraph (pure $ Vertices []) mempty)+    divide f t1 t2 = Track $ \a ->+        let+            (h, k) = f a+            x = run t1 h+            y = run t2 k+         in+            OpGraph (Vertices <$> pure [x, y]) mempty++{- | A function to inject a dependency form a tracer when generating an OpGraph.+At first it looks like the we could just directly apply.+-}+tracking ::+    (Applicative m) =>+    Track m n z ->+    (a -> (b, z)) ->+    a ->+    (b -> OpGraph m n) ->+    OpGraph m n+tracking t f arg use =+    let (b, z) = f arg+     in use b `inject` run t z++data Tracked m n a+    = Tracked+    { track :: Track m n a+    , obj :: a+    }++-- | A pure tracked merely is the constructor with some initial trace.+pureTracked :: Track m n a -> a -> Tracked m n a+pureTracked = Tracked++-- | Eval the OpGraph of a Tracked object.+trackedGraph :: Tracked m n a -> OpGraph m n+trackedGraph t = run t.track t.obj++-- | a quasi-functor which records all dependencies at the point of mapping+mapTracked :: (a -> b) -> Tracked m n a -> Tracked m n b+mapTracked f t = Tracked (Track $ const $ trackedGraph t) (f t.obj)++-- | a quasi-applicative which records all combined dependencies at the point of mapping+apTracked :: (Applicative m) => Tracked m n (a -> b) -> Tracked m n a -> Tracked m n b+apTracked tf ta = Tracked (Track $ const $ trackedGraph tf `overlaid` trackedGraph ta) (tf.obj ta.obj)++-- | a quasi-monad which records previous dependencies as predecessors before binding+bindTracked :: (Applicative m) => Tracked m n a -> (a -> Tracked m n b) -> Tracked m n b+bindTracked ta f = Tracked (Track $ const $ trackedGraph tb `inject` trackedGraph ta) b+  where+    tb@(Tracked _ b) = f ta.obj++-- | A similar to `tracking` but for a Tracked object.+using :: (Applicative m) => Tracked m n a -> (a -> OpGraph m n) -> OpGraph m n+using tracked use =+    tracking tracked.track dup tracked.obj use+  where+    dup a = (a, a)++{- | Like 'using', but for two independent 'Tracked' values at once — avoids+nesting two 'using' calls just to get both objects in scope together.+-}+using2 ::+    (Applicative m) =>+    Tracked m n a ->+    Tracked m n b ->+    ((a, b) -> OpGraph m n) ->+    OpGraph m n+using2 t1 t2 use =+    use (t1.obj, t2.obj) `inject` (trackedGraph t1 `overlaid` trackedGraph t2)++-- | Like 'using2', for three independent 'Tracked' values.+using3 ::+    (Applicative m) =>+    Tracked m n a ->+    Tracked m n b ->+    Tracked m n c ->+    ((a, b, c) -> OpGraph m n) ->+    OpGraph m n+using3 t1 t2 t3 use =+    use (t1.obj, t2.obj, t3.obj) `inject` (trackedGraph t1 `overlaid` trackedGraph t2 `overlaid` trackedGraph t3)