packages feed

unsequential (empty) → 0.5.0.2

raw patch · 7 files changed

+407/−0 lines, 7 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed

Dependencies added: QuickCheck, attoparsec, base, base-prelude, dlist, interspersed, quickcheck-instances, rebase, tasty, tasty-hunit, tasty-quickcheck, tasty-smallcheck, transformers, unsequential

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2016, Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ attoparsec-integration-test/Main.hs view
@@ -0,0 +1,99 @@+module Main where++import Rebase.Prelude hiding (takeWhile)+import Data.Attoparsec.ByteString.Char8+import Unsequential+import Interspersed+import Test.Tasty+import Test.Tasty.Runners+import Test.Tasty.HUnit+++main =+  defaultMain $+  testGroup "All tests"+  [+    testCase "Primitive" $+    let+      input =+        "{\"year\" : \"2001\", \"month\": \"1\", \"day\": \"2\"}"+      result =+        parseOnly dateOutOfAnyObject input+      in assertEqual (show result) (Right ("2001", "1", "2")) result+    ,+    testCase "In different order" $+    let+      input =+        "{\"month\": \"1\", \"day\": \"2\", \"year\" : \"2001\"}"+      result =+        parseOnly dateOutOfAnyObject input+      in assertEqual (show result) (Right ("2001", "1", "2")) result+    ,+    testCase "With redundant fields" $+    let+      input =+        "{\"redundant1\": \"4\", \"month\": \"1\", \"redundant2\": \"3\", \"day\": \"2\", \"year\" : \"2001\"}"+      result =+        parseOnly dateOutOfAnyObject input+      in assertEqual (show result) (Right ("2001", "1", "2")) result+    ,+    testCase "With trailing fields" $+    let+      input =+        "{\"month\": \"1\", \"day\": \"2\", \"year\" : \"2001\", \"trailing\": \"3\"}"+      result =+        parseOnly dateOutOfAnyObject input+      in assertEqual (show result) (Right ("2001", "1", "2")) result+  ]+++-- * Parsers+-------------------------++dateOutOfAnyObject :: Parser (ByteString, ByteString, ByteString)+dateOutOfAnyObject =+  objectWithUnsequentialRows $+  (,,) <$>+  unsequential (interspersed (objectRow (== "year") stringLit)) <*>+  unsequential (interspersed (objectRow (== "month") stringLit)) <*>+  unsequential (interspersed (objectRow (== "day") stringLit))++objectWithUnsequentialRows :: Unsequential (Interspersed Parser) a -> Parser a+objectWithUnsequentialRows unsequentialRows =+  object rows+  where+    rows =+      runInterspersed (runUnsequential unsequentialRows skip <* skipMany skip) comma+      where+        skip =+          interspersed $+          objectRow (const True) stringLit $> ()++-- |+-- Given a rows parser produces a parser of the object.+object :: Parser a -> Parser a+object rows =+  char '{' *> skipSpace *> rows <* skipSpace <* char '}'++-- |+-- Object row parser, which tests the key with a predicate and parses the value.+objectRow :: (ByteString -> Bool) -> Parser a -> Parser a+objectRow keyPredicate valueParser =+  do+    key <- stringLit+    guard (keyPredicate key)+    skipSpace+    char ':'+    skipSpace+    valueParser ++-- |+-- Note: this parser does not satisfy the JSON standards,+-- but suffices the purposes of the test.+stringLit :: Parser ByteString+stringLit =+  char '"' *> takeWhile (/= '"') <* char '"'++comma :: Parser ()+comma =+  skipSpace *> char ',' *> skipSpace
+ library/Unsequential.hs view
@@ -0,0 +1,77 @@+module Unsequential+(+  Unsequential,+  runUnsequential,+  unsequential,+)+where++import Unsequential.Prelude+import qualified Unsequential.Execution as Execution+++-- |+-- Allows to use the 'Applicative' interface to +-- compose the actions of the base monad+-- while being abstracted from the order of their successful execution.+data Unsequential m a =+  forall b. Unsequential !(DList (m b)) !([b] -> Maybe a)++instance Functor m => Functor (Unsequential m) where+  {-# INLINE fmap #-}+  fmap f (Unsequential alternatives extractor) =+    Unsequential alternatives (fmap (fmap f) extractor)++instance Applicative m => Applicative (Unsequential m) where+  {-# INLINE pure #-}+  pure a =+    Unsequential empty (const (pure a))+  {-# INLINABLE (<*>) #-}+  (<*>) (Unsequential alternatives1 extractor1) (Unsequential alternatives2 extractor2) =+    Unsequential alternatives3 extractor3+    where+      alternatives3 =+        (fmap . fmap) Left alternatives1 <>+        (fmap . fmap) Right alternatives2+      extractor3 intermediates =+        case partitionEithers intermediates of+          (intermediates1, intermediates2) ->+            ($) <$> extractor1 intermediates1 <*> extractor2 intermediates2++instance MonadTrans Unsequential where+  {-# INLINE lift #-}+  lift =+    unsequential++-- |+-- Runs 'Unsequential' given an implementation of the \"skip\" effect.+-- +-- The \"skip\" effect can be just @return ()@ in case you don't want+-- skipping or @mzero@ if you want to fail on the attempt to skip.+{-# INLINABLE runUnsequential #-}+runUnsequential :: MonadPlus m => Unsequential m a -> m () -> m a+runUnsequential (Unsequential alternatives extractor) skip =+  {-# SCC "runUnsequential" #-} +  do+    (remainingAlternatives, results) <- Execution.run (Execution.process skip) (toList alternatives)+    guard (null remainingAlternatives)+    maybe mzero return (extractor results)++-- |+-- Lift a computation in the base monad.+-- +-- Same as 'lift'.+{-# INLINABLE unsequential #-}+unsequential :: Monad m => m a -> Unsequential m a+unsequential alternative =+  {-# SCC "unsequential" #-} +  Unsequential alternatives extractor+  where+    alternatives =+      pure alternative+    extractor =+      \case+        head : _ ->+          return head+        _ ->+          mzero
+ library/Unsequential/Execution.hs view
@@ -0,0 +1,63 @@+module Unsequential.Execution+where++import Unsequential.Prelude+++type Execution b m a =+  StateT ([m b], [b]) m a++{-# INLINE run #-}+run :: Monad m => Execution b m () -> [m b] -> m ([m b], [b])+run execution alternatives =+  {-# SCC "run" #-} +  execStateT execution (alternatives, [])++{-# INLINABLE tryAlternatives #-}+tryAlternatives :: MonadPlus m => m () -> Execution b m ()+tryAlternatives skip =+  {-# SCC "tryAlternatives" #-} +  modifyM loop+  where+    loop (alternatives, results) =+      case alternatives of+        alternativesHead : alternativesTail ->+          mplus tryHead tryTail+          where+            tryHead =+              fmap (\result -> (alternativesTail, result : results)) $+              alternativesHead+            tryTail =+              fmap (\(alternatives, results) -> (alternativesHead : alternatives, results)) $+              loop (alternativesTail, results)+        _ ->+          skip $> (alternatives, results)++untilNoAlternativesLeft :: Monad m => Execution b m () -> Execution b m ()+untilNoAlternativesLeft action =+  loop+  where+    loop =+      anyAlternativesLeft >>=+      bool (return ()) (action >> loop)++{-# INLINE ifAnyAlternativesLeft #-}+ifAnyAlternativesLeft :: MonadPlus m => Execution b m a -> Execution b m a+ifAnyAlternativesLeft action =+  anyAlternativesLeft >>=+  bool (mzero) action++anyAlternativesLeft :: Monad m => Execution b m Bool+anyAlternativesLeft =+  gets $+  \(alternatives, _) -> not (null alternatives)++getResults :: Monad m => Execution b m [b]+getResults =+  gets $+  \(_, results) -> results++{-# INLINE process #-}+process :: MonadPlus m => m () -> Execution b m ()+process skip =+  inline skipMany (ifAnyAlternativesLeft (inline tryAlternatives skip))
+ library/Unsequential/Prelude.hs view
@@ -0,0 +1,62 @@+module Unsequential.Prelude+( +  module Exports,+  modifyM,+  skipSepBy,+  skipSepBy1,+  skipMany,+  skipMany1,+)+where+++-- base-prelude+-------------------------+import BasePrelude as Exports hiding (Alt, scanl)++-- transformers+-------------------------+import Control.Monad.IO.Class as Exports+import Control.Monad.Trans.Class as Exports+import Control.Monad.Trans.Except as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass)+import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass)+import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass)+import Control.Monad.Trans.Writer.Strict as Exports++-- dlist+-------------------------+import Data.DList as Exports (DList)++-- Utils+-------------------------++{-# INLINE modifyM #-}+modifyM :: Monad m => (a -> m a) -> StateT a m ()+modifyM f =+  StateT (fmap (\s -> ((), s)) . f)++{-# INLINE skipSepBy #-}+skipSepBy :: Alternative m => m () -> m () -> m ()+skipSepBy one sep =+  skipSepBy1 one sep <|> pure ()++{-# INLINABLE skipSepBy1 #-}+skipSepBy1 :: Alternative m => m () -> m () -> m ()+skipSepBy1 one sep =+  one *> remainders+  where+    remainders =+      (sep *> one *> remainders) <|> pure ()++{-# INLINABLE skipMany #-}+skipMany :: Alternative f => f a -> f ()+skipMany fx =+  loop+  where+    loop =+      (fx *> loop) <|> pure ()++{-# INLINE skipMany1 #-}+skipMany1 :: Alternative f => f a -> f ()+skipMany1 fx =+  fx *> skipMany fx
+ unsequential.cabal view
@@ -0,0 +1,82 @@+name:+  unsequential+version:+  0.5.0.2+synopsis:+  An extension removing the sequentiality from monads+description:+category:+  Control+homepage:+  https://github.com/nikita-volkov/unsequential +bug-reports:+  https://github.com/nikita-volkov/unsequential/issues +author:+  Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer:+  Nikita Volkov <nikita.y.volkov@mail.ru>+copyright:+  (c) 2016, Nikita Volkov+license:+  MIT+license-file:+  LICENSE+build-type:+  Simple+cabal-version:+  >=1.10+++source-repository head+  type:+    git+  location:+    git://github.com/nikita-volkov/unsequential.git+++library+  hs-source-dirs:+    library+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+  other-modules:+    Unsequential.Prelude+    Unsequential.Execution+  exposed-modules:+    Unsequential+  build-depends:+    dlist >= 0.7 && < 0.8,+    -- +    transformers >= 0.4 && < 0.6,+    base-prelude < 2+++test-suite attoparsec-integration-test+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    attoparsec-integration-test+  main-is:+    Main.hs+  other-modules:+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+  build-depends:+    -- +    unsequential,+    interspersed >= 0.1 && < 0.2,+    -- +    attoparsec >= 0.13 && < 0.14,+    -- testing:+    tasty == 0.11.*,+    tasty-quickcheck == 0.8.*,+    tasty-smallcheck == 0.8.*,+    tasty-hunit == 0.9.*,+    quickcheck-instances >= 0.3.11 && < 0.4,+    QuickCheck >= 2.8.1 && < 2.9,+    --+    rebase >= 0.4 && < 0.5