diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog + +`trial` uses [PVP Versioning][1]. +The changelog is available [on GitHub][2]. + +## 0.0.0.0 + +* Initially created. + +[1]: https://pvp.haskell.org +[2]: https://github.com/kowainik/trial/releases diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,177 @@ +# trial + +[![GitHub CI](https://github.com/kowainik/trial/workflows/CI/badge.svg)](https://github.com/kowainik/trial/actions) +[![Hackage](https://img.shields.io/hackage/v/trial.svg?logo=haskell)](https://hackage.haskell.org/package/trial) +[![MPL-2.0 license](https://img.shields.io/badge/license-MPL--2.0-blue.svg)](LICENSE) + +The `Trial` Data Structure is a `Either`-like structure that keeps events history +inside. The data type allows to keep track of the `Fatality` level of each such +event entry (`Warning` or `Error`). + +## Project Structure + +This is a multi-package project that has the following packages inside: + +| Package | Description | +|------------------------------|--------------------------------------------------------------------------------------------------------------------------------------------------------------| +| `trial` | The main package that contains the `Trial` data structure, instances and useful functions to work with the structure. | +| `trial-optparse-applicative` | `Trial` structure integration with the [`optparse-applicative`](https://hackage.haskell.org/package/optparse-applicative) library for Command Line Interface. | +| `trial-tomland` | `Trial` structure integration with the [`tomland`](https://hackage.haskell.org/package/tomland) library for TOML configurations. | +| `trial-example` | Example project with the usage example of the `Trial` data structure. | + +## How to use `trial` + +`trial` is compatible with the latest GHC versions starting from `8.6.5`. + +In order to start using `trial` in your project, you will need to set it up with +the three easy steps: + +1. Add the dependency on `trial` in your project's `.cabal` file. For this, you + should modify the `build-depends` section by adding the name of this library. + After the adjustment, this section could look like this: + + ```haskell + build-depends: base ^>= 4.14 + , trial ^>= 0.0 + ``` + +2. In the module where you plan to use `Trial`, you should add the import: + + ```haskell + import Trial (Trial (..), fiasco, prettyPrintTrial) + ``` + +3. Now you can use the types and functions from the library: + + ```haskell + main :: IO () + main = putStrLn $ prettyPrintTrial $ fiasco "This is fiasco, bro!" + ``` + +## Trial Data Structure + +Let's have a closer look at the `Trial` data structure. +`Trial` is a sum type that has two constructors: + + - `Fiasco` — represents the unsuccessful state similar to the `Left` + constructor of `Either`. However, unlike `Left`, `Fiasco` holds a list of all + `error`-like items that happened along the way. Each such item has a notion of + `Fatality` (the severity of the error). The following cases cover + `Fatality`: + + `Error` — fatal error that led to the final fatal `Fiasco`. + + `Warning` — non-essential error, which didn't affect the result. + - `Result` — represents the successful state similar to the `Right` + constructor of `Either`. However, unlike `Right`, `Result` keeps the list of + all `error`-like items that happened along the way. All error items are + warnings as the final result was found anyway. + +Schematically, `Trial` has the following internal representation: + +```haskell +data Trial e a + │ │ + │ ╰╴Resulting type + │ + ╰╴An error item type + + -- | Unsuccessful case + = Fiasco (DList (Fatality, e)) + │ │ │ + │ │ ╰╴One error item + │ │ + │ ╰╴Level of damage + │ + ╰╴Efficient list-container for error type items + + -- | Successful case + | Result (DList e) a + │ │ │ + │ │ ╰╴Result + │ │ + │ ╰╴One warning item + │ + ╰╴Efficient list-container for warning type items +``` + +### `Trial` instances + +In order to follow the basis idea of the data type, `Trial` uses smart +constructors and different instances to make the structure work the way it +works. + +Here are the main points: + +* All `Fiasco`s can be created only with the `Error` `Fatality` level. +* The `Fatality` level can be eased only through the `Semigroup` appends of + different `Trial`s. +* All error items in `Result` should have only `Warning` `Fatality` level. This + is guaranteed by the `Trial` `Semigroup` and `Applicative` instances. +* `Semigroup` is responsible for the correct collection of history events, their + `Fatality` level and the final result decision. +* `Semigroup` chooses the latest 'Result' and combines all events. +* Think of `Semigroup` instance as of high-level combinator of your result. +* `Applicative` is responsible for the correct combination of `Trial`s. +* `Applicative` returns `Fiasco`, if at least one value if `Fiasco`, combine all + events. +* Think of `Applicative` instance as of low-level combinator of your result on the + record fields level. +* `Alternative` instance could help when you want to stop on the first + `Result` and get the history of all failures before it. +* `Alternative`: return first `Result`, also combine all events for + all `Trial`s before this `Result`. + +## Tagged `Trial` + +Additionally, there is a `Trial`-like data type that has a notion of the `tag` +inside. + +The main difference from `Trial` is that the resulting type contains additional +information of the tag (or source it came from). The type looks like this: + +```haskell +type TaggedTrial tag a = Trial tag (tag, a) +``` + +Due to the described instances implementation, the tag will always be aligned +with the final source it came from. + +The library provides different ways to add the tag: + * Manual with the `withTag` function + * Using `OverloadedLabels`and the provided `IsLabel` instance for + `TaggedTrial`. + +You can choose the one that is more suitable for your use-case. + +## Usage Examples + +One of the use cases when one could consider using `Trial` is the configurations +in the application. + +If you need to collect configurations from different places, combine the results +into a single configuration, you can find the `Trial` data structure quite +handy. With `trial` you can get the event history for free and also you can keep +track of where the final result for each component of your configurations type +comes from (by using `tag` functionality). + +The complete example in the `trial-example` package. It combines CLI, TOML +configuration and the default options provided in the source code. + +| Executable | Description | +|------------|-------------| +| [`trial-example`](https://github.com/kowainik/trial/blob/master/trial-example/app/Main.hs) | The basic example of config problem with the usage of `TaggedTrial` | +| [`trial-example-advanced`](https://github.com/kowainik/trial/blob/master/trial-example/app-advanced/Main.hs) | The basic example of config problem with the usage of `TaggedTrial` with the `Phase` based approach. | + +To run it you can use the following command: + +```shell +$ cabal run trial-example +$ cabal run trial-example-advanced +``` + +For the successful result you can use the CLI and provide necessary information +in order to have the complete configurations: + +```shell +$ cabal run trial-example -- --host="abc" +$ cabal run trial-example-advanced -- --host="abc" +``` diff --git a/src/Trial.hs b/src/Trial.hs new file mode 100644 --- /dev/null +++ b/src/Trial.hs @@ -0,0 +1,917 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | +Copyright: (c) 2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +The 'Trial' Data Structure is a 'Either'-like structure that keeps +events history inside. The data type allows to keep track of the +'Fatality' level of each such event entry ('Warning' or 'Error'). + +'Trial' has two constructors: + +* 'Fiasco': stores the list of events with the explicit 'Fatality' + level; at least one event has level 'Error' +* 'Result': stores the final result and the list of events where each + event has implicit 'Fatality' level 'Warning' + +@trial@ implements the composable interface for creating and combining +values of type 'Trial', so the history of all events is stored +inside. Fundamental algebraic instances provide the following main +features: + +* 'Semigroup': take the last 'Result' and combine all events. +* 'Applicative': return 'Fiasco', if at least one value if 'Fiasco', + combine all events. +* 'Alternative': return first 'Result', also combine all events for + all 'Trial's before this 'Result'. +-} + +module Trial + ( -- * Data structures + Trial (..) + , TaggedTrial + -- ** 'Fatality' + , Fatality + , pattern Warning + , pattern Error + + + -- * Smart constructors + , fiasco + , fiascos + , result + -- * Combinators + , alt + , isFiasco + , isResult + , whenResult + , whenResult_ + , whenFiasco + , whenFiasco_ + + -- * Work with Lists + -- $patternList + , pattern FiascoL + , pattern ResultL + , getTrialInfo + , fiascoErrors + , fiascoWarnings + , resultWarnings + , anyWarnings + , dlistToList + + + -- * 'Maybe' combinators + , maybeToTrial + , trialToMaybe + -- * 'Either' combinators + , eitherToTrial + , trialToEither + + -- * Tag + , withTag + , unTag + , fiascoOnEmpty + + -- * Pretty printing + , prettyFatality + , prettyTrial + , prettyTrialWith + , prettyTaggedTrial + , prettyTaggedTrialWith + + -- * Configuration helpers + -- $phase + , Phase (..) + , (:-) + , (::-) + ) where + +import Control.Applicative (Alternative (..), Applicative (..)) +import Data.Bifoldable (Bifoldable (..)) +import Data.Bifunctor (Bifunctor (..)) +import Data.Bitraversable (Bitraversable (..)) +import Data.DList (DList) +import Data.Foldable (foldl') +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Proxy (Proxy (..)) +import Data.Semigroup (Semigroup (..)) +import Data.String (IsString (..)) +import GHC.OverloadedLabels (IsLabel (..)) +import GHC.Records (HasField (..)) +import GHC.TypeLits (KnownSymbol, symbolVal) + +import qualified Colourista as C +import qualified Colourista.Short as C +import qualified Data.DList as DL +import qualified Data.List.NonEmpty as NE + + +{- | Severity of the event in history. + +* 'Error': fatal error that led to the final 'Fiasco' +* 'Warning': non-essential error, which didn't affect the result + +You can't create values of type 'Fatality', you can only pattern-match +on them. 'Trial' smart constructors and instances take care of +assigning proper 'Fatality' values. + +Use 'Warning' and 'Error' Pattern Synonyms to pattern match on +'Fatality': + +>>> :{ +showFatality :: Fatality -> String +showFatality Warning = "Warning" +showFatality Error = "Error" +:} + +@since 0.0.0.0 +-} +data Fatality + = W + | E + deriving stock (Show, Eq, Enum, Bounded) + +{- | 'Warning' pattern synonym. + +@since 0.0.0.0 +-} +pattern Warning :: Fatality +pattern Warning <- W + +{- | 'Error' pattern synonym. + +@since 0.0.0.0 +-} +pattern Error :: Fatality +pattern Error <- E + +{-# COMPLETE Warning, Error #-} + +withW :: Functor f => f e -> f (Fatality, e) +withW = fmap (W,) +{-# INLINE withW #-} + +{- | 'Trial' is a data type that stores history of all events happened +with a value. In addition, each event is associated with the +'Fatality' level that indicates whether the event is fatal or not. + +API provided by @trial@ guarantees the following property: + +* If the final value is 'Fiasco', it is either an empty list or a list + with at least one event with the 'Fatality' level 'Error'. + +@since 0.0.0.0 +-} +data Trial e a + -- | Stores list of events with the explicit 'Fatality' level. + = Fiasco (DList (Fatality, e)) + -- | Store list of events and the final result. + | Result (DList e) a + deriving stock (Show, Eq) + +{- | In addition to usual 'Trial' capabilities, 'TaggedTrial' allows +attaching a @tag@ to the resulting value, so you can track which event +helped to obtain a value. + +@since 0.0.0.0 +-} +type TaggedTrial tag a = Trial tag (tag, a) + +{- | Combine two 'Trial' values. Returns 'Result' if at least one +argument is 'Result'. + +Let's create some default values: + +>>> f1 = fiasco "Not initialised..." +>>> f2 = fiasco "Parsing error!" +>>> r1 = result "r1: From CLI" 5 +>>> r2 = result "r2: Default" 42 + +And here is how combination of those values look like: + +>>> f1 <> f2 +Fiasco (fromList [(E,"Not initialised..."),(E,"Parsing error!")]) +>>> f1 <> r1 +Result (fromList ["Not initialised...","r1: From CLI"]) 5 +>>> f2 <> r2 +Result (fromList ["Parsing error!","r2: Default"]) 42 +>>> r1 <> r2 +Result (fromList ["r1: From CLI","r2: Default"]) 42 +>>> f1 <> r1 <> f2 <> r2 +Result (fromList ["Not initialised...","r1: From CLI","Parsing error!","r2: Default"]) 42 + +@since 0.0.0.0 +-} +instance Semigroup (Trial e a) where + (<>) :: Trial e a -> Trial e a -> Trial e a + Fiasco e1 <> Fiasco e2 = Fiasco $ e1 <> e2 + Fiasco e1 <> Result e2 a = Result (DL.map snd e1 <> e2) a + Result e1 a <> Fiasco e2 = Result (e1 <> DL.map snd e2) a + Result e1 _ <> Result e2 b = Result (e1 <> e2) b + {-# INLINE (<>) #-} + + sconcat :: NonEmpty (Trial e a) -> Trial e a + sconcat (x :| xs) = foldl' (<>) x xs + {-# INLINE sconcat #-} + +-- | @since 0.0.0.0 +instance Functor (Trial e) where + fmap :: (a -> b) -> Trial e a -> Trial e b + fmap _ (Fiasco e) = Fiasco e + fmap f (Result e a) = Result e $ f a + {-# INLINE fmap #-} + + (<$) :: a -> Trial e b -> Trial e a + _ <$ Fiasco e = Fiasco e + a <$ Result e _ = Result e a + {-# INLINE (<$) #-} + +{- | Combine two 'Trial's but recording all 'Result' events inside +'Fiasco' as 'Warning's. + +>>> fiasco "No default" <*> fiasco "No config" +Fiasco (fromList [(E,"No default"),(E,"No config")]) +>>> fiasco "No default" *> result "Option deprecated" 10 +Fiasco (fromList [(E,"No default"),(W,"Option deprecated")]) +>>> (,) <$> result "Redundant" 10 <*> result "No CLI Flag" True +Result (fromList ["Redundant","No CLI Flag"]) (10,True) +>>> result "Option deprecated" 10 *> pure 42 +Result (fromList ["Option deprecated"]) 42 + +@since 0.0.0.0 +-} +instance Applicative (Trial e) where + pure :: a -> Trial e a + pure = Result DL.empty + {-# INLINE pure #-} + + (<*>) :: Trial e (a -> b) -> Trial e a -> Trial e b + Fiasco e1 <*> trial = Fiasco $ case trial of + Fiasco e2 -> e1 <> e2 + Result e2 _ -> e1 <> withW e2 + Result e1 _ <*> Fiasco e2 = Fiasco (withW e1 <> e2) + Result e1 f <*> Result e2 a = Result (e1 <> e2) (f a) + {-# INLINE (<*>) #-} + + (*>) :: Trial e a -> Trial e b -> Trial e b + Fiasco e1 *> trial = Fiasco $ case trial of + Fiasco e2 -> e1 <> e2 + Result e2 _ -> e1 <> withW e2 + Result e1 _ *> Fiasco e2 = Fiasco (withW e1 <> e2) + Result e1 _ *> Result e2 b = Result (e1 <> e2) b + {-# INLINE (*>) #-} + + (<*) :: Trial e a -> Trial e b -> Trial e a + Fiasco e1 <* trial = Fiasco $ case trial of + Fiasco e2 -> e1 <> e2 + Result e2 _ -> e1 <> withW e2 + Result e1 _ <* Fiasco e2 = Fiasco (withW e1 <> e2) + Result e1 a <* Result e2 _ = Result (e1 <> e2) a + {-# INLINE (<*) #-} + + liftA2 :: (a -> b -> c) -> Trial e a -> Trial e b -> Trial e c + liftA2 _ (Fiasco e1) trial = Fiasco $ case trial of + Fiasco e2 -> e1 <> e2 + Result e2 _ -> e1 <> withW e2 + liftA2 _ (Result e1 _) (Fiasco e2) = Fiasco (withW e1 <> e2) + liftA2 f (Result e1 a) (Result e2 b) = Result (e1 <> e2) (f a b) + {-# INLINE liftA2 #-} + +{- | Return the first 'Result' with the whole history before +it. If both are 'Fiasco's, return 'Fiasco's with the histories +combined. + +>>> fiasco "No info" <|> pure 42 +Result (fromList ["No info"]) 42 +>>> pure 42 <|> result "Something" 10 +Result (fromList []) 42 +>>> fiasco "No info" <|> fiasco "Some info" +Fiasco (fromList [(E,"No info"),(E,"Some info")]) + +See 'alt' if you want a different behaviour. + +@since 0.0.0.0 +-} +instance Alternative (Trial e) where + empty :: Trial e a + empty = Fiasco DL.empty + {-# INLINE empty #-} + + (<|>) :: Trial e a -> Trial e a -> Trial e a + r@Result{} <|> _ = r + f@Fiasco{} <|> r = f <> r + {-# INLINE (<|>) #-} + +{- | Alternative implementation of the 'Alternative' instance for +'Trial'. Return the first 'Result'. Otherwise, append two histories in +both 'Fiasco's. both 'Fiasco's. + +>>> fiasco "No info" `alt` pure 42 +Result (fromList []) 42 +>>> pure 42 `alt` result "Something" 10 +Result (fromList []) 42 +>>> fiasco "No info" `alt` fiasco "Some info" +Fiasco (fromList [(E,"No info"),(E,"Some info")]) + +@since 0.0.0.0 +-} +infixl 3 `alt` +alt :: Trial e a -> Trial e a -> Trial e a +alt r@Result{} _ = r +alt _ r@Result{} = r +alt (Fiasco e1) (Fiasco e2) = Fiasco (e1 <> e2) + +-- | @since 0.0.0.0 +instance Bifunctor Trial where + bimap :: (e1 -> e2) -> (a -> b) -> Trial e1 a -> Trial e2 b + bimap ef _ (Fiasco es) = Fiasco (DL.map (second ef) es) + bimap ef af (Result e a) = Result (DL.map ef e) (af a) + {-# INLINE bimap #-} + +-- | @since 0.0.0.0 +instance Bifoldable Trial where + bifoldMap :: (Monoid m) => (e -> m) -> (a -> m) -> Trial e a -> m + bifoldMap ef _ (Fiasco es) = foldMap (ef . snd) es + bifoldMap ef ea (Result es a) = foldMap ef es <> ea a + {-# INLINE bifoldMap #-} + +-- | @since 0.0.0.0 +instance Bitraversable Trial where + bitraverse :: (Applicative f) => (e1 -> f e2) -> (a -> f b) -> Trial e1 a -> f (Trial e2 b) + bitraverse ef _ (Fiasco es) = Fiasco <$> traverseDList (traverse ef) es + bitraverse ef ea (Result es a) = Result <$> traverseDList ef es <*> ea a + {-# INLINE bitraverse #-} + +{- 'DList' doesn't have a 'Traversable' instance -} +traverseDList :: (Applicative f) => (a -> f b) -> DList a -> f (DList b) +traverseDList f = foldr (\a fDlistB -> liftA2 DL.cons (f a) fDlistB) (pure DL.empty) +{-# INLINE traverseDList #-} + +{- | Smart constructor for 'Trial'. Returns 'Fiasco' with a single +event and 'Error' 'Fatality'. + +@since 0.0.0.0 +-} +fiasco :: e -> Trial e a +fiasco e = Fiasco $ DL.singleton (E, e) +{-# INLINE fiasco #-} + +{- | Smart constructor for 'Trial'. Returns 'Fiasco' with a list of +events, where each has 'Fatality' 'Error'. + +@since 0.0.0.0 +-} +fiascos :: NonEmpty e -> Trial e a +fiascos = Fiasco . DL.fromList . map (E,) . NE.toList +{-# INLINE fiascos #-} + +{- | Smart constructor for 'Trial'. Returns 'Result' with a single +event of 'Warning' 'Fatality'. + +__Hint:__ Use 'pure' to create a 'Result' with an empty list of events. + +@since 0.0.0.0 +-} +result :: e -> a -> Trial e a +result e = Result $ DL.singleton e +{-# INLINE result #-} + +{- | Predicate on if the given 'Trial' is 'Fiasco'. + +>>> isFiasco (fiasco 'e') +True +>>> isFiasco (result 'a' 42) +False + +@since 0.0.0.0 +-} +isFiasco :: Trial e a -> Bool +isFiasco (Fiasco _) = True +isFiasco _ = False + +{- | Predicate on if the given 'Trial' is 'Result'. + +>>> isResult (result 'a' 42) +True +>>> isResult (fiasco 'e') +False + +@since 0.0.0.0 +-} +isResult :: Trial e a -> Bool +isResult (Result _ _) = True +isResult _ = False + +{- | Applies the given action to 'Trial' if it is 'Result' and returns the +value. In case of 'Fiasco' the default value is returned. + +>>> whenResult "bar" (fiasco "foo") (\es a -> "success!" <$ (print a >> print es)) +"bar" + +>>> whenResult "bar" (result "res" 42) (\es a -> "success!" <$ (print a >> print es)) +42 +["res"] +"success!" + +@since 0.0.0.0 +-} +whenResult :: Applicative f => x -> Trial e a -> ([e] -> a -> f x) -> f x +whenResult x (FiascoL _) _ = pure x +whenResult _ (ResultL es a) f = f es a +{-# INLINE whenResult #-} + +{- | Applies given action to the 'Trial' content if it is 'Result'. + +Similar to 'whenResult' but the default value is @()@. + +>>> whenResult_ (fiasco "foo") (\es a -> print a >> print es) +>>> whenResult_ (result "res" 42) (\es a -> print a >> print es) +42 +["res"] + +@since 0.0.0.0 +-} +whenResult_ :: Applicative f => Trial e a -> ([e] -> a -> f ()) -> f () +whenResult_ = whenResult () +{-# INLINE whenResult_ #-} + +{- | Applies the given action to 'Trial' if it is 'Fiasco' and returns the +result. In case of 'Result' the default value is returned. + +>>> whenFiasco "bar" (fiasco 42) (\es -> "foo" <$ print es) +[(E,42)] +"foo" + +>>> whenFiasco "bar" (result "res" 42) (\es -> "foo" <$ print es) +"bar" + +@since 0.0.0.0 +-} +whenFiasco :: Applicative f => x -> Trial e a -> ([(Fatality, e)] -> f x) -> f x +whenFiasco _ (FiascoL e) f = f e +whenFiasco a (ResultL _ _) _ = pure a +{-# INLINE whenFiasco #-} + +{- | Applies given action to the 'Trial' content if it is 'Fiasco'. + +Similar to 'whenFiasco' but the default value is @()@. + +>>> whenFiasco_ (result "res" 42) print +>>> whenFiasco_ (fiasco "foo") print +[(E,"foo")] + +@since 0.0.0.0 +-} +whenFiasco_ :: Applicative f => Trial e a -> ([(Fatality, e)] -> f ()) -> f () +whenFiasco_ = whenFiasco () +{-# INLINE whenFiasco_ #-} + +{- | Convert 'Maybe' to 'Trial' but assigning 'Error' 'Fatality' when +the value is 'Nothing'. + +>>> maybeToTrial "No default" (Just 10) +Result (fromList []) 10 +>>> maybeToTrial "No default" Nothing +Fiasco (fromList [(E,"No default")]) + +Functions 'maybeToTrial' and 'trialToMaybe' satisfy property: + +@ +'trialToMaybe' . 'maybeToTrial' e ≡ 'id' +@ + +@since 0.0.0.0 +-} +maybeToTrial :: e -> Maybe a -> Trial e a +maybeToTrial e = \case + Just a -> pure a + Nothing -> fiasco e + +{- | 'Convert 'Trial' to 'Maybe' by losing all history information. + +>>> trialToMaybe $ fiasco "Some info" +Nothing +>>> trialToMaybe $ result "From CLI" 3 +Just 3 + +@since 0.0.0.0 +-} +trialToMaybe :: Trial e a -> Maybe a +trialToMaybe (Result _ a) = Just a +trialToMaybe (Fiasco _) = Nothing + +{- | Convert 'Either' to 'Trial' by assigning 'Fatality' 'Warning' to +a 'Left' value. + +>>> eitherToTrial (Right 42) +Result (fromList []) 42 +>>> eitherToTrial (Left "Missing value") +Fiasco (fromList [(E,"Missing value")]) + +Functions 'eitherToTrial' and 'trialToEither' satisfy property: + +@ +'trialToEither' . 'eitherToTrial' ≡ 'id' +@ + +@since 0.0.0.0 +-} +eitherToTrial :: Either e a -> Trial e a +eitherToTrial (Right a) = pure a +eitherToTrial (Left e) = fiasco e + +{- | Convert 'Trial' to 'Either' by concatenating all history events. + +>>> trialToEither (result "No info" 42) +Right 42 +>>> trialToEither $ fiascos $ "Hello, " :| ["there"] +Left "Hello, there" + +@since 0.0.0.0 +-} +trialToEither :: Monoid e => Trial e a -> Either e a +trialToEither (Result _ a) = Right a +trialToEither (Fiasco es) = Left $ foldl' (<>) mempty $ DL.map snd es + +{- | Tag a 'Trial'. + +>>> withTag "Answer" $ pure 42 +Result (fromList []) ("Answer",42) +>>> withTag "Answer" $ fiasco "No answer" +Fiasco (fromList [(E,"No answer")]) + +@since 0.0.0.0 +-} +withTag :: tag -> Trial tag a -> TaggedTrial tag a +withTag tag = fmap (tag,) + +{- | Untag a 'Trial' by adding a @tag@ to a history of events. + +>>> unTag $ pure ("Chosen randomly",5) +Result (fromList ["Chosen randomly"]) 5 +>>> unTag $ fiasco "No random" +Fiasco (fromList [(E,"No random")]) + +@since 0.0.0.0 +-} +unTag :: TaggedTrial tag a -> Trial tag a +unTag (Fiasco e) = Fiasco e +unTag (Result e (tag, a)) = Result (DL.snoc e tag) a + +{- | Tag a value with a given tag, and add a message to events using +tag and a name if the given 'Foldable' is 'null'. + +When used like this: + +@ +fiascoOnEmpty \"CLI\" "port" someList +@ + +it's equivalent to the following: + +@ +'withTag' \"CLI\" $ __case__ someList __of__ + [] -> 'fiasco' "No CLI option specified for: port" + xs -> pure xs +@ + +@since 0.0.0.0 +-} +fiascoOnEmpty + :: (IsString tag, Semigroup tag, Foldable f) + => tag -- ^ Tag + -> tag -- ^ Field name + -> f a -- ^ Container of elements + -> TaggedTrial tag (f a) +fiascoOnEmpty tag name f + | null f = fiasco $ "No " <> tag <> " option specified for: " <> name + | otherwise = withTag tag (pure f) + +-- TODO: add usage example of the IsLabel instance +{- | Convenient instance to convert record fields of type +'TaggedTrial' to 'Trial' by appending field names to the history. This +instance automatically combines tags and record field names into human +readable message, so the resulting history has more context. + +@since 0.0.0.0 +-} +instance + ( HasField label r (Trial tag (tag, a)) + , IsString tag + , Semigroup tag + , KnownSymbol label + ) + => IsLabel label (r -> Trial tag a) + where + fromLabel :: r -> Trial tag a + fromLabel r = let fieldName = fromString $ symbolVal (Proxy @label) <> " is set through the source: " in + case getField @label r of + Fiasco e -> Fiasco e + Result e (tag, a) -> Result (DL.snoc e $ fieldName <> tag) a + {-# INLINE fromLabel #-} + +{- $patternList + +'Trial' stores list of events as 'DList' internally for efficient +appending. But when pattern-matching on the final value, it's more +convenient to work directly with lists. 'FiascoL' and 'ResultL' are +Pattern Synonyms for working with lists. It's recommended to use them +only once at the end, since conversion from 'DList' to list takes some +time. + +>>> :{ +foo :: Trial String Int -> String +foo (FiascoL []) = "Fiasco list is empty" +foo (ResultL [] _) = "Result list is empty" +foo _ = "Other case" +:} + +>>> foo empty +"Fiasco list is empty" +>>> foo $ pure 42 +"Result list is empty" +>>> foo $ result "Something" 42 +"Other case" +-} + +{- | Uni-directional Pattern Synonym for 'Fiasco' that allows +pattern-matching directly on lists. + +@since 0.0.0.0 +-} +pattern FiascoL :: [(Fatality, e)] -> Trial e a +pattern FiascoL e <- Fiasco (DL.toList -> e) + +{- | Uni-directional Pattern Synonym for 'Result' that allows +pattern-matching directly on lists. + +@since 0.0.0.0 +-} +pattern ResultL :: [e] -> a -> Trial e a +pattern ResultL e a <- Result (DL.toList -> e) a + +{-# COMPLETE FiascoL, ResultL #-} +{-# COMPLETE Result, FiascoL #-} +{-# COMPLETE ResultL, Fiasco #-} + +{- | Get the list of 'Warning's and 'Error's together with the 'Maybe' +'Result' if applicable. + +>>> getTrialInfo $ result "Warning" 42 +([(W,"Warning")],Just 42) +>>> getTrialInfo $ fiasco "Error" +([(E,"Error")],Nothing) + +@since 0.0.0.0 +-} +getTrialInfo :: Trial e a -> ([(Fatality, e)], Maybe a) +getTrialInfo = \case + Fiasco e -> (DL.toList e, Nothing) + Result e a -> (map (W,) $ DL.toList e, Just a) + +{- | Returns all 'Error's in the 'Fiasco' constructor. +If the given 'Trial' is 'Result' then returns an empty list instead. + +>>> fiascoErrors $ fiasco "One Error" +["One Error"] +>>> fiascoErrors $ result "Warning" 42 +[] +>>> fiascoErrors (fiasco "Error" *> result "Warning" 42) +["Error"] + +@since 0.0.0.0 +-} +fiascoErrors :: Trial e a -> [e] +fiascoErrors = \case + Result _ _ -> [] + Fiasco e -> map snd $ filter ((==) E . fst) $ DL.toList e + + +{- | Returns all 'Warning's in the 'Fiasco' constructor. +If the given 'Trial' is 'Result' then returns an empty list instead. + +>>> fiascoWarnings $ fiasco "One Error" +[] +>>> fiascoWarnings $ result "Warning" 42 +[] +>>> fiascoWarnings (fiasco "Error" *> result "Warning" 42) +["Warning"] + +@since 0.0.0.0 +-} +fiascoWarnings :: Trial e a -> [e] +fiascoWarnings = \case + Result _ _ -> [] + Fiasco e -> map snd $ filter ((==) W . fst) $ DL.toList e + + +{- | Returns all 'Warning's in the 'Result' constructor. +If the given 'Trial' is 'Fiasco' then returns an empty list instead. + +>>> resultWarnings $ fiasco "One Error" +[] +>>> resultWarnings $ result "Warning" 42 +["Warning"] +>>> resultWarnings (fiasco "Error" *> result "Warning" 42) +[] + +@since 0.0.0.0 +-} +resultWarnings :: Trial e a -> [e] +resultWarnings = \case + Result e _ -> DL.toList e + Fiasco _ -> [] + +{- | Returns all 'Warning's in the 'Trial'. These includes both warnings in +'Result' of in 'Fiasco'. + +>>> anyWarnings $ fiasco "One Error" +[] +>>> anyWarnings $ result "Warning" 42 +["Warning"] +>>> anyWarnings (fiasco "Error" *> result "Warning" 42) +["Warning"] + +@since 0.0.0.0 +-} +anyWarnings :: Trial e a -> [e] +anyWarnings = \case + Result e _ -> DL.toList e + Fiasco e -> map snd $ filter ((==) W . fst) $ DL.toList e + +{- | Helper function to convert 'DList' to list. + +@since 0.0.0.0 +-} +dlistToList :: DList a -> [a] +dlistToList = DL.toList +{-# INLINE dlistToList #-} + +{- | Print aligned and colourful 'Fatality': + +* 'Warning' in yellow +* 'Error' in red + +See 'prettyTrial' for examples. + +@since 0.0.0.0 +-} +prettyFatality :: (Semigroup str, IsString str) => Fatality -> str +prettyFatality = \case + E -> C.formatWith [C.red] "Error " + W -> C.formatWith [C.yellow] "Warning" + +prettyEntry :: (Semigroup e, IsString e) => (Fatality, e) -> e +prettyEntry (f, e) = " * [" <> prettyFatality f <> "] " <> e <> "\n" + +{- | Colourful pretty-printing of 'Trial'. + +![Fiasco](https://user-images.githubusercontent.com/8126674/82759167-830c9b80-9de3-11ea-8e72-c5f6c2cdcb6e.png) + +![Result](https://user-images.githubusercontent.com/8126674/82759176-8b64d680-9de3-11ea-8426-e5de941ae9a4.png) + +@since 0.0.0.0 +-} +prettyTrial + :: (Show a, Semigroup e, IsString e) + => Trial e a + -> e +prettyTrial = prettyTrialWith show + +{- | Similar to 'prettyTrial', but accepts a function to show Result in the +provided way. + +@since 0.0.0.0 +-} +prettyTrialWith + :: (Semigroup e, IsString e) + => (a -> String) + -> Trial e a + -> e +prettyTrialWith showRes = \case + Fiasco es -> C.formatWith [C.red, C.bold] "Fiasco:\n" + <> foldr (\e -> (<>) (prettyEntry e)) "" es + Result es a -> C.formatWith [C.green, C.bold] "Result:\n" + <> fromString (unlines $ map (" " <>) $ lines $ showRes a) + <> C.i "\nWith the following warnings:\n" + <> foldr (\e -> (<>) (prettyEntry (W, e))) "" es + +{- | Colourful pretty-printing of 'TaggedTrial'. Similar to +'prettyTrial', but also prints the resulting @tag@ for 'Result'. + +![Tag](https://user-images.githubusercontent.com/8126674/82759188-93bd1180-9de3-11ea-8a76-337d73cf6cc0.png) + +@since 0.0.0.0 +-} +prettyTaggedTrial + :: (Show a, Semigroup e, IsString e) + => TaggedTrial e a + -> e +prettyTaggedTrial = prettyTaggedTrialWith show + +{- | Similar to 'prettyTaggedTrial', but accepts a function to show the 'Result' +in the provided way. + +@since 0.0.0.0 +--} +prettyTaggedTrialWith + :: (Semigroup e, IsString e) + => (a -> String) + -> TaggedTrial e a + -> e +prettyTaggedTrialWith showRes = \case + Fiasco es -> C.formatWith [C.red, C.bold] "Fiasco:\n" + <> foldr (\e -> (<>) (prettyEntry e)) "" es + Result es (tag, a) -> C.formatWith [C.green, C.bold] "Result:\n" + <> C.formatWith [C.blue] (" [" <> tag <> "]\n ") + <> fromString (unlines $ map (" " <>) $ lines $ showRes a) + <> C.i "\nWith the following warnings:\n" + <> foldr (\e -> (<>) (prettyEntry (W, e))) "" es + +---------------------------------------------------------------------------- +-- Configurations +---------------------------------------------------------------------------- + +{- $phase +@trial@ introduced some additional data types and type families for adding __phase__ notion to your data types. + +This approach is especially useful when you have a data type with many fields and the goal is to roll up the 'Trial' data type to the one with /pure/ fields. + +In this case you can have two options: + +1. Use two separate data types: + + @ + __data__ MyType = MyType + { mtField1 :: 'Int' + , ... + + __data__ PartialMyType = PartialMyType + { pmtField1 :: 'Trial' 'String' 'Int' + , ... + + finalise :: PartialMyType -> Maybe MyType + @ + +2. Use 'Phase' notion together with ':-' type family: + + @ + __data__ MyType (p :: Phase String) = MyType + { mtField1 :: p :- 'Int' + , ... + + finalise :: MyType \'Partial -> Maybe (MyType \'Final) + @ + + And this will have the same effect + +See the usage example in the @trial-example@ package: + +* [trial-example-advanced](https://github.com/kowainik/trial/blob/master/trial-example/app-advanced/Main.hs) +-} + +{- | The phase of the configurations. +This type is parametrised by the @e@ (error) type of the 'Trial' data type. +It is a phantom parameter. +So it could easily be used in the following way: @Phase Text@. + +@since 0.0.0.0 +-} +data Phase (e :: Type) + = Partial + | Final + deriving stock (Show, Eq) + +{- | Type family to map 'Phase' to the corresponding field for the 'Trial' +approach. This is a Higher-Kinded Data approach specialised to custom +enumeration. + +@since 0.0.0.0 +-} +infixl 3 :- +type family (phase :: Phase (e :: Type)) :- field where + ('Partial :: Phase e) :- field = Trial e field + 'Final :- field = field + +{- | Type family to map 'Phase' to the corresponding field for the 'TaggedTrial' +approach. This is a Higher-Kinded Data approach specialised to custom +enumeration. + +@since 0.0.0.0 +-} +infixl 3 ::- +type family (phase :: Phase (tag :: Type)) ::- field where + ('Partial :: Phase tag) ::- field = TaggedTrial tag field + 'Final ::- field = field diff --git a/test/Doctest.hs b/test/Doctest.hs new file mode 100644 --- /dev/null +++ b/test/Doctest.hs @@ -0,0 +1,20 @@ +module Main (main) where + +import Test.DocTest (doctest) + + +main :: IO () +main = doctest + $ "-XDeriveAnyClass" + : "-XDeriveGeneric" + : "-XDerivingStrategies" + : "-XGeneralizedNewtypeDeriving" + : "-XInstanceSigs" + : "-XLambdaCase" + : "-XOverloadedStrings" + : "-XRecordWildCards" + : "-XScopedTypeVariables" + : "-XTupleSections" + : "-XTypeApplications" + : "-XViewPatterns" + : [ "src/Trial.hs" ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,12 @@ +module Main (main) where + +import Test.Hspec (describe, hspec, parallel) + +import Test.Trial.Laws (lawsSpec) +import Test.Trial.Property (propertySpec) + + +main :: IO () +main = hspec $ describe "Trial Test" $ parallel $ do + lawsSpec + propertySpec diff --git a/test/Test/Trial/Gen.hs b/test/Test/Trial/Gen.hs new file mode 100644 --- /dev/null +++ b/test/Test/Trial/Gen.hs @@ -0,0 +1,129 @@ +module Test.Trial.Gen + ( Property + , genEither + , genFunction + , genFunction2 + , genInt + , genSmallInt + , genSmallList + , genTrial + + -- * Trial tree + , TrialTree (..) + , evalTrialTree + , genTrialTree + ) where + +import Control.Applicative (Alternative (..), liftA2) +import Data.DList (DList) +import Data.List.NonEmpty (NonEmpty (..)) +import Hedgehog (Gen, PropertyT) + +import Trial (Fatality, Trial (..), fiasco, fiascos, result) + +import qualified Data.DList as DL +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + + +-- | Helper alias for tests. +type Property = PropertyT IO () + +-- | Generate an 'Int'. +genInt :: Gen Int +genInt = Gen.enumBounded + +-- | Generate a small list of the given generated elements. +genSmallList :: Gen a -> Gen [a] +genSmallList = Gen.list (Range.linear 0 6) + + +-- | Generate a small list of the given generated elements. +genSmallDList :: Gen a -> Gen (DList a) +genSmallDList = fmap DL.fromList . genSmallList + +-- | Generate a positive 'Int' within the range of @1-6@. +genSmallInt :: Gen Int +genSmallInt = Gen.int (Range.linear 1 6) + +-- | Generate a 'Validation'. +genTrial :: Gen a -> Gen (Trial Int a) +genTrial genA = Gen.choice + [ Fiasco <$> genSmallDList (liftA2 (,) genFatality genInt) + , Result <$> genSmallDList genInt <*> genA + ] + +genFatality :: Gen Fatality +genFatality = Gen.enumBounded + +-- | Generate a simple unary function from the list. +genFunction :: Gen (Int -> Int) +genFunction = genInt >>= \n -> Gen.element + [ id + , (+ n) + , (* n) + , const n + , (n -) + , subtract n + ] + +-- | Generate a simple binary function from the list. +genFunction2 :: Gen (Int -> Int -> Int) +genFunction2 = Gen.element + [ const + , (+) + , (*) + , (-) + , subtract + ] + +-- | Generate 'Either' with more frequent 'Right's. +genEither :: Gen e -> Gen a -> Gen (Either e a) +genEither genE genA = Gen.sized $ \n -> Gen.frequency + [ (2, Left <$> genE) + , (1 + fromIntegral n, Right <$> genA) + ] + +{- | Data type that represents 'Trial' event tree to create a value of +type @Trial Int a@. +-} +data TrialTree e a + = SCFiasco e -- ^ @fiasco@ smart constructor + | SCFiascos (NonEmpty e) -- ^ @fiascos@ smart constructor + | SCResult e a -- ^ @result@ smart constructor + | Pure a -- @pure@ from Applicative +-- | Empty -- @empty@ from Alternative + | Append (TrialTree e a) (TrialTree e a) -- ^ @(<>)@ from Semigroup + | SeqR (TrialTree e a) (TrialTree e a) -- ^ @(*>)@ from Applicative + | Alt (TrialTree e a) (TrialTree e a) -- ^ @(<|>)@ from Alternative + deriving stock (Show, Eq) + +evalTrialTree :: TrialTree e a -> Trial e a +evalTrialTree = \case + SCFiasco e -> fiasco e + SCFiascos es -> fiascos es + SCResult e a -> result e a + Pure a -> pure a +-- Empty -> empty + Append l r -> evalTrialTree l <> evalTrialTree r + SeqR l r -> evalTrialTree l *> evalTrialTree r + Alt l r -> evalTrialTree l <|> evalTrialTree r + +genTrialTree :: forall e a . Gen e -> Gen a -> Gen (TrialTree e a) +genTrialTree genE genA = Gen.recursive + Gen.choice + -- non-recursive generators + [ SCFiasco <$> genE + , SCFiascos <$> liftA2 (:|) genE (genSmallList genE) + , SCResult <$> genE <*> genA + , Pure <$> genA +-- , pure Empty + ] + -- recursive generators + [ Gen.subterm2 genTree genTree Append + , Gen.subterm2 genTree genTree SeqR + , Gen.subterm2 genTree genTree Alt + ] + where + genTree :: Gen (TrialTree e a) + genTree = genTrialTree genE genA diff --git a/test/Test/Trial/Laws.hs b/test/Test/Trial/Laws.hs new file mode 100644 --- /dev/null +++ b/test/Test/Trial/Laws.hs @@ -0,0 +1,198 @@ +module Test.Trial.Laws + ( lawsSpec + -- * Internals + , checkAssotiativityFor + ) where + +import Control.Applicative (Alternative (..), liftA2) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Semigroup (Semigroup (..)) +import Hedgehog (Gen, forAll, forAllWith, (===)) +import Test.Hspec (Spec, describe, it, parallel) +import Test.Hspec.Hedgehog (hedgehog) + +import Test.Trial.Gen (Property, genFunction, genFunction2, genInt, genSmallInt, genSmallList, + genTrial) +import Trial (Trial) + + +lawsSpec :: Spec +lawsSpec = describe "Trial Instance Laws" $ parallel $ do + describe "Semigroup instance for Trial" $ do + it "Associativity: a <> (b <> c) ≡ (a <> b) <> c" + semigroupAssociativity + it "Concatenation: sconcat ≡ foldr1 (<>)" + semigroupConcatenation + it "Times: stimes n a ≡ foldr1 (<>) (replicate n a)" + semigroupTimes + describe "Functor instance for Trial" $ do + it "Identity: fmap id ≡ id" + functorIdentity + it "Composition: map f . fmap g ≡ fmap (f . g)" + functorComposition + it "Const: fmap (const x) ≡ x <$" + functorConst + describe "Applicative instance for Trial" $ do + it "Functor and Applicative correspondence: fmap f x ≡ pure f <*> x" + functorApplicative + it "Identity: pure id <*> x ≡ x" + applicativeIdentity + it "Composition: pure (.) <*> f <*> g <*> x ≡ f <*> (g <*> x)" + applicativeComposition + it "Homomorphism: pure f <*> pure x ≡ pure (f x)" + applicativeHomomorphism + it "Interchange: f <*> pure x ≡ pure ($ x) <*> f" + applicativeInterchange + it "Apply Right: u *> v ≡ (id <$ u) <*> v" applicativeApplyRight + it "Apply Left: u <* v ≡ liftA2 const u v" applicativeApplyLeft + it "(<*>) via liftA2: (<*>) ≡ liftA2 id" + applicativeApViaLiftA2 + it "liftA2 via (<*>): liftA2 f x y ≡ f <$> x <*> y" + applicativeLiftA2ViaAp + describe "Alternative instance for Trial" $ do + it "Associativity: a <|> (b <|> c) ≡ (a <|> b) <|> c" + alternativeAssociativity + it "Right Identity: x <|> empty ≡ x" alternativeRightIdentity + it "Left Identity: empty <|> x ≡ x" alternativeLeftIdentity + +---------------------------------------------------------------------------- +-- Semigroup instance properties +---------------------------------------------------------------------------- + +semigroupAssociativity :: Property +semigroupAssociativity = checkAssotiativityFor (genTrial genInt) (<>) + +semigroupConcatenation :: Property +semigroupConcatenation = do + let gen = genTrial genInt + a <- forAll gen + as <- forAll $ genSmallList gen + let ne = a :| as + sconcat ne === foldr1 (<>) ne + +semigroupTimes :: Property +semigroupTimes = do + a <- forAll $ genTrial genInt + n <- forAll genSmallInt + stimes n a === foldr1 (<>) (replicate n a) + +---------------------------------------------------------------------------- +-- Functor instance laws +---------------------------------------------------------------------------- + +functorIdentity :: Property +functorIdentity = hedgehog $ do + a <- forAll $ genTrial genInt + fmap id a === id a + +functorComposition :: Property +functorComposition = hedgehog $ do + a <- forAll $ genTrial genInt + f <- forAllWith (const "f") genFunction + g <- forAllWith (const "g") genFunction + fmap f (fmap g a) === fmap (f . g) a + +functorConst :: Property +functorConst = hedgehog $ do + a <- forAll $ genTrial genInt + let x = 'X' + fmap (const x) a === (x <$ a) + +---------------------------------------------------------------------------- +-- Applicative instance properties +---------------------------------------------------------------------------- + +functorApplicative :: Property +functorApplicative = hedgehog $ do + f <- forAllWith (const "f") genFunction + x <- forAll $ genTrial genInt + fmap f x === (pure f <*> x) + +applicativeIdentity :: Property +applicativeIdentity = hedgehog $ do + vx <- forAll $ genTrial genInt + (pure id <*> vx) === vx + +applicativeComposition :: Property +applicativeComposition = hedgehog $ do + vf <- forAllWith (const "f") $ genTrial genFunction + vg <- forAllWith (const "g") $ genTrial genFunction + vx <- forAll $ genTrial genInt + (pure (.) <*> vf <*> vg <*> vx) === (vf <*> (vg <*> vx)) + +applicativeHomomorphism :: Property +applicativeHomomorphism = hedgehog $ do + f <- forAllWith (const "f") genFunction + x <- forAll genInt + (pure f <*> pure x) === pure @(Trial Int) (f x) + +applicativeInterchange :: Property +applicativeInterchange = hedgehog $ do + vf <- forAllWith (const "f") $ genTrial genFunction + x <- forAll genInt + (vf <*> pure x) === (pure ($ x) <*> vf) + +applicativeApplyRight :: Property +applicativeApplyRight = hedgehog $ do + let genVal = genTrial genInt + vy <- forAll genVal + vx <- forAll genVal + (vy *> vx) === ((id <$ vy) <*> vx) + +applicativeApplyLeft :: Property +applicativeApplyLeft = hedgehog $ do + let genVal = genTrial genInt + vy <- forAll genVal + vx <- forAll genVal + (vy <* vx) === liftA2 const vy vx + +applicativeApViaLiftA2 :: Property +applicativeApViaLiftA2 = hedgehog $ do + vf <- forAllWith (const "f") $ genTrial genFunction + vx <- forAll $ genTrial genInt + (vf <*> vx) === liftA2 id vf vx + +applicativeLiftA2ViaAp :: Property +applicativeLiftA2ViaAp = hedgehog $ do + f <- forAllWith (const "f") genFunction2 + vx <- forAll $ genTrial genInt + vy <- forAll $ genTrial genInt + liftA2 f vx vy === (f <$> vx <*> vy) + +---------------------------------------------------------------------------- +-- Alternative instance properties +---------------------------------------------------------------------------- + +alternativeAssociativity :: Property +alternativeAssociativity = checkAssotiativityFor (genTrial genInt) (<|>) + +alternativeRightIdentity :: Property +alternativeRightIdentity = hedgehog $ do + x <- forAll $ genTrial genSmallInt + (x <|> empty) === x + +alternativeLeftIdentity :: Property +alternativeLeftIdentity = hedgehog $ do + x <- forAll $ genTrial genInt + (empty <|> x) === x + +---------------------------------------------------------------------------- +-- Property helpers +---------------------------------------------------------------------------- + +{- | Property test for the associativity law: + +@ +a ⊗ (b ⊗ c) ≡ (a ⊗ b) ⊗ c +@ +-} +checkAssotiativityFor + :: (Show a, Eq a) + => Gen a + -> (a -> a -> a) + -> Property +checkAssotiativityFor gen op = hedgehog $ do + a <- forAll gen + b <- forAll gen + c <- forAll gen + a `op` (b `op` c) === (a `op` b) `op` c diff --git a/test/Test/Trial/Property.hs b/test/Test/Trial/Property.hs new file mode 100644 --- /dev/null +++ b/test/Test/Trial/Property.hs @@ -0,0 +1,42 @@ +module Test.Trial.Property + ( propertySpec + ) where + +import Hedgehog (assert, forAll, (===)) +import Test.Hspec (Spec, describe, it, parallel) +import Test.Hspec.Hedgehog (hedgehog) + +import Test.Trial.Gen (Property, evalTrialTree, genEither, genInt, genSmallList, genTrial, + genTrialTree) +import Test.Trial.Laws (checkAssotiativityFor) +import Trial (Trial (..), alt, eitherToTrial, fiascoErrors, maybeToTrial, trialToEither, + trialToMaybe) + +import qualified Hedgehog.Gen as Gen + + +propertySpec :: Spec +propertySpec = describe "Trial Property Tests" $ parallel $ do + it "trialToMaybe . maybeToTrial e ≡ id" trialMaybeProperty + it "trialToEither . eitherToTrial ≡ id" trialEitherProperty + it "Trial invariant: Fiasco has at least one 'Error'" trialInvariantProperty + it "'alt' associativity: a `alt` (b `alt` c) ≡ (a `alt` b) `alt` c" $ + checkAssotiativityFor (genTrial genInt) alt + +trialMaybeProperty :: Property +trialMaybeProperty = hedgehog $ do + ma <- forAll $ Gen.maybe genInt + e <- forAll genInt + trialToMaybe (maybeToTrial e ma) === ma + +trialEitherProperty :: Property +trialEitherProperty = hedgehog $ do + e <- forAll $ genEither (genSmallList genInt) genInt + trialToEither (eitherToTrial e) === e + +trialInvariantProperty :: Property +trialInvariantProperty = hedgehog $ do + tree <- forAll $ genTrialTree genInt genInt + case evalTrialTree tree of + Result _ _ -> pure () + f@(Fiasco es) -> assert $ es == mempty || fiascoErrors f /= [] diff --git a/trial.cabal b/trial.cabal new file mode 100644 --- /dev/null +++ b/trial.cabal @@ -0,0 +1,124 @@ +cabal-version: 2.4 +name: trial +version: 0.0.0.0 +synopsis: Trial Data Structure +description: + The @Trial@ Data Structure is a @Either@-like structure that keeps + events history inside. The data type allows to keep track of the + @Fatality@ level of each such event entry (@Warning@ or @Error@). + . + @ + __data__ Trial e a + \ │ │ + \ │ ╰╴Resulting type + \ │ + \ ╰╴An error item type + \ + \ -- | Unsuccessful case + \ = Fiasco (DList (Fatality, e)) + \ │ │ │ + \ │ │ ╰╴One error item + \ │ │ + \ │ ╰╴Level of damage + \ │ + \ ╰╴Efficient list-container for error type items + \ + \ -- | Successful case + \ | Result (DList e) a + \ │ │ │ + \ │ │ ╰╴Result + \ │ │ + \ │ ╰╴One warning item + \ │ + \ ╰╴Efficient list-container for warning type items + @ + . +homepage: https://github.com/kowainik/trial +bug-reports: https://github.com/kowainik/trial/issues +license: MPL-2.0 +license-file: LICENSE +author: Veronika Romashkina, Dmitrii Kovanikov +maintainer: Kowainik +copyright: 2020 Kowainik +category: Data Structure, Data +build-type: Simple +extra-doc-files: README.md + CHANGELOG.md +tested-with: GHC == 8.6.5 + GHC == 8.8.3 + GHC == 8.10.1 + +source-repository head + type: git + location: https://github.com/kowainik/trial.git + +common common-options + build-depends: base >= 4.12.0.0 && < 4.15 + + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + if impl(ghc >= 8.0) + ghc-options: -Wredundant-constraints + if impl(ghc >= 8.2) + ghc-options: -fhide-source-paths + if impl(ghc >= 8.4) + ghc-options: -Wmissing-export-lists + -Wpartial-fields + if impl(ghc >= 8.8) + ghc-options: -Wmissing-deriving-strategies + if impl(ghc >= 8.10) + ghc-options: -Wunused-packages + + default-language: Haskell2010 + default-extensions: ConstraintKinds + DeriveGeneric + DerivingStrategies + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + +library + import: common-options + hs-source-dirs: src + build-depends: colourista ^>= 0.1.0.0 + , dlist ^>= 0.8.0.8 + exposed-modules: Trial + +test-suite trial-test + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: Test.Trial.Gen + Test.Trial.Laws + Test.Trial.Property + + build-depends: trial + , dlist + , hedgehog ^>= 1.0 + , hspec ^>= 2.7 + , hspec-hedgehog ^>= 0.0.1.1 + , splitmix < 0.0.5 + + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N + +test-suite trial-doctest + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Doctest.hs + build-depends: doctest ^>= 0.16 + ghc-options: -threaded