packages feed

railroad (empty) → 0.1.0.0

raw patch · 6 files changed

+314/−0 lines, 6 filesdep +basedep +effectfuldep +hspec

Dependencies added: base, effectful, hspec, mtl, railroad, validation

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for railroad++## 0.1.0.0 -- 2026-02-25++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2026, Frederik Kallstrup Mastratisi+++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 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.
+ railroad.cabal view
@@ -0,0 +1,47 @@+cabal-version:      3.0+name:               railroad+version:            0.1.0.0+license:            BSD-3-Clause+license-file:       LICENSE+author:             Frederik Kallstrup Mastratisi+maintainer:         mastratisi@proton.me+category:           Control, Error Handling+build-type:         Simple+extra-doc-files:    CHANGELOG.md+synopsis:           A railway oriented mini-DSL for unified error handling.+description:+    A railway oriented mini-DSL for handling and interpreting error states +    and cardinality checks across diverse failure types in a unified way.+homepage:     https://github.com/mastratisi/railroad+bug-reports:  https://github.com/mastratisi/railroad/issues+source-repository head+  type:     git+  location: https://github.com/mastratisi/railroad++common stuff+    ghc-options: -Wall+    build-depends:+      base ^>=4.20.2.0,+      effectful >= 2.5.1 && < 2.6,+      mtl >= 2.3.1 && < 2.4,+      validation >= 1.1.3 && < 1.2++library+    import:           stuff+    exposed-modules:  Railroad+                      +    hs-source-dirs:   src+    default-language: GHC2021+    ++test-suite railroad-test+    import:           stuff+    default-language: GHC2021+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          Main.hs+    other-modules:    RailroadSpec+    build-depends:+                  base ^>=4.20.2.0,+                  hspec  >= 2.11.14 && < 2.12,+                  railroad
+ src/Railroad.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE LambdaCase           #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}++module Railroad where++import           Data.Bool               (bool)+import           Data.Foldable           (toList)+import           Data.Kind               (Type)+import           Data.Validation         (Validation, toEither)+import           Effectful               (Eff, type (:>))+import           Effectful.Error.Dynamic (Error, throwError_)+++type family CErr f :: Type where+  CErr Bool               = ()+  CErr (Maybe a)          = ()+  CErr (Either e a)       = e+  CErr (Validation e a)   = e+  CErr (t a)              = CErr a+type family CRes f :: Type where+  CRes Bool               = ()+  CRes (Maybe a)          = a+  CRes (Either e a)       = a+  CRes (Validation e a)   = a+  CRes (t a)              = t (CRes a)++-- | A catamorphism to Either+class Bifurcate f where+  bifurcate :: f -> Either (CErr f) (CRes f)+instance Bifurcate Bool where+  bifurcate = bool (Left ()) (Right ())+  -- bool   :: b -> b -> Bool -> b+instance Bifurcate (Maybe a) where+  bifurcate = maybe (Left ()) Right+  -- maybe  :: b -> (a -> b) -> Maybe a -> b+instance Bifurcate (Either e a) where+  bifurcate = id+  -- either :: (e -> b) -> (a -> b) -> Either e a -> b+instance Bifurcate (Validation e a) where+  bifurcate = toEither+  -- validation :: (e -> b) -> (a -> b) -> Validation e a -> b++instance (Traversable t, CErr (t Bool) ~ (), CRes (t Bool) ~ t ())+    => Bifurcate (t Bool) where+  bifurcate = bifurcate . sequenceA . fmap bifurcate+  -- Bool is not Applicative, so we need to map to Either first+instance (Traversable t, CErr (t (Maybe a)) ~ (), CRes (t (Maybe a)) ~ t a)+    => Bifurcate (t (Maybe a)) where+  bifurcate = bifurcate . sequenceA+instance (Traversable t, CErr (t (Either e a)) ~ e, CRes (t (Either e a)) ~ t a)+    => Bifurcate (t (Either e a)) where+  bifurcate = sequenceA+  -- pedagogically: bifurcate = bifurcate . sequenceA+instance (Traversable t, Semigroup e, CErr (t (Validation e a)) ~ e, CRes (t (Validation e a)) ~ t a)+    => Bifurcate (t (Validation e a)) where+  bifurcate = toEither . sequenceA+  -- pedagogically: bifurcate = bifurcate . sequenceA++-- | Collapses a structure into its inner type or an effectful error+collapse :: (Error e :> es, Bifurcate f) => (CErr f -> e) -> f -> Eff es (CRes f)+collapse toErr = either (throwError_ . toErr) pure . bifurcate+++-- | Collapses a structure using an error mapper.+(??) :: forall a es e. (Error e :> es, Bifurcate a) => Eff es a -> (CErr a -> e) -> Eff es (CRes a)+action ?? toErr = action >>= collapse toErr++-- | Collapses a structure using a constant error.+(?) :: forall es e a. (Error e :> es, Bifurcate a) => Eff es a -> e -> Eff es (CRes a)+action ? err = action ?? const err++-- | Collapses any value based on a predicate+(?>) :: forall es e a. (Error e :> es) => Eff es a -> (a -> Bool) -> (a -> e) -> Eff es a+(?>) action predicate toErr = do+  val <- action+  if predicate val then pure val else throwError_ $ toErr val++-- | Collapses a structure and recovers to a value dependent on the error+(??~) :: forall es a. Bifurcate a => Eff es a -> (CErr a -> CRes a) -> Eff es (CRes a)+action ??~ defaultFunc = action >>= either (pure . defaultFunc) pure . bifurcate++-- | Collapses a structure, and recovers to a constant default value in the error case+(?~) :: forall es a. Bifurcate a => Eff es a -> CRes a -> Eff es (CRes a)+action ?~ defaultVal = action ??~ (const defaultVal)+++-- TODO: Derive instances for it? Functor?+data CardinalityError ta = IsEmpty | TooMany !ta++-- | Catamorphism for CardinalityError+cardinalityErr :: e -> (ta -> e) -> CardinalityError ta -> e+cardinalityErr onEmpty onTooMany = \case+  IsEmpty -> onEmpty+  TooMany xs -> onTooMany xs+++-- |  Non-empty is sucess state. Returns the collection as-is.+(?+) :: forall es e t a. (Error e :> es, Foldable t)+     => Eff es (t a) -> e -> Eff es (t a)+(?+) action err = do+  xs <- action+  if null xs then throwError_ err else pure xs+++-- | Single element is sucess state.  Returns the single element+(?!) :: forall es e t a. (Error e :> es, Foldable t)+     => Eff es (t a) -> (CardinalityError (t a) -> e) -> Eff es a+(?!) action toErr = do+  xs <- action+  case toList xs of+    []  -> throwError_ $ toErr IsEmpty+    [x] -> pure x+    _   -> throwError_ $ toErr $ TooMany xs+++-- | Empty is success state. Returns Unit.+(?∅) :: forall es e t a. (Error e :> es, Foldable t)+     => Eff es (t a) -> ((t a) -> e) -> Eff es ()+(?∅) action toErr = do+  xs <- action+  if null xs then pure () else throwError_ (toErr xs)++++infixl  0 ??, ?, ?~, ?!, ?+, ?∅+infixl 1 ?>++
+ test/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/RailroadSpec.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE TypeApplications #-}+module RailroadSpec where+++import           Data.Validation+import           Effectful+import           Effectful.Error.Dynamic+import           Railroad+import           Test.Hspec++-- Helper to run the Railroad effects in a pure context+runRail :: Eff '[Error String] a -> Either String a+runRail = runPureEff . runErrorNoCallStack++spec :: Spec+spec = do+  describe "Bifurcate Instances" $ do+    it "bifurcates Bool" $ do+      bifurcate True  `shouldBe` (Right () :: Either () ())+      bifurcate False `shouldBe` (Left ()  :: Either () ())++    it "bifurcates Maybe" $ do+      bifurcate (Just 5) `shouldBe` (Right 5 :: Either () Int)+      bifurcate (Nothing :: Maybe Int) `shouldBe` (Left () :: Either () Int)++    it "bifurcates Either" $ do+      bifurcate (Right 5 :: Either String Int) `shouldBe` Right 5+      bifurcate (Left "fire" :: Either String Int) `shouldBe` Left "fire"++    it "bifurcates Validation" $ do+      bifurcate (Success 10 :: Validation String Int) `shouldBe` Right 10+      bifurcate (Failure "ice" :: Validation String Int) `shouldBe` Left "ice"++    it "bifurcates List of Bool" $ do+        bifurcate [True, True] `shouldBe` (Right [(), ()] :: Either () [()])+        bifurcate [True, False, True] `shouldBe` (Left () :: Either () [()])++    it "bifurcates List of Maybe" $ do+      bifurcate [Just 1, Just 2] `shouldBe` (Right [1, 2] :: Either () [Int])+      bifurcate [Just 1, Nothing] `shouldBe` (Left () :: Either () [Int])++    it "bifurcates List of Either" $ do+      let input0 = [Right 1, Right 2] :: [Either String Int]+      bifurcate input0 `shouldBe` Right [1, 2]+      let input1 = [Right 1, Left "first", Left "second"] :: [Either String Int]+      bifurcate input1 `shouldBe` Left "first"++    it "List of Validation (Error Accumulation)" $ do+      let input = [Success 1, Success 2] :: [Validation String Int]+      bifurcate input `shouldBe` Right [1, 2]+        -- Note: Validation accumulates because String is a Semigroup+      let input = [Success 1, Failure "Fail A ", Failure "Fail B"] :: [Validation String Int]+      bifurcate input `shouldBe` Left "Fail A Fail B"++  describe "Basic Operators (? and ??)" $ do+    it "unwraps success values with (?)" $ do+      runRail (pure (Just 10 :: Maybe Int) ? "missing") `shouldBe` Right 10++    it "throws constant error on failure with (?)" $ do+      runRail (pure (Nothing :: Maybe ()) ? "missing") `shouldBe` Left "missing"++    it "maps internal errors with (??)" $ do+      let action = pure (Left "original" :: Either String String)+      runRail (action ?? reverse) `shouldBe` Left "lanigiro"++  describe "Predicate Operator (?>)" $ do+    it "passes when predicate is met" $ do+      runRail (pure 10 ?> (> 5) $ const "too small") `shouldBe` Right 10++    it "fails when predicate is not met" $ do+      runRail (pure 4 ?> (> 5) $ const "too small") `shouldBe` Left "too small"++  describe "Recovery Operators (?~ and ??~)" $ do+    it "recovers to a constant value with (?~)" $ do+      runPureEff (pure Nothing ?~ 0) `shouldBe` (0 :: Int)++    it "recovers using a function with (??~)" $ do+      runPureEff (pure (Left "err") ??~ length) `shouldBe` 3++  describe "Cardinality Operators" $ do+    describe "(?+)" $ do+      it "succeeds on non-empty list" $ do+        runRail (pure [1, 2, 3] ?+ "empty") `shouldBe` Right [1, 2, 3]+      it "fails on empty list" $ do+        runRail (pure ([] :: [Int]) ?+ "empty") `shouldBe` Left "empty"++    describe "(?!)" $ do+      let toErr = cardinalityErr "none" (const "too many")+      it "extracts the single element" $ do+        runRail (pure [42] ?! toErr) `shouldBe` Right 42+      it "fails on empty" $ do+        runRail (pure ([] :: [Int]) ?! toErr) `shouldBe` Left "none"+      it "fails on multiple elements" $ do+        runRail (pure [1, 2] ?! toErr) `shouldBe` Left "too many"++    describe "(?∅)" $ do+      it "succeeds on empty" $ do+        runRail (pure [] ?∅ const "not empty") `shouldBe` Right ()+      it "fails on non-empty" $ do+        runRail (pure [1] ?∅ const "not empty") `shouldBe` Left "not empty"