diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/library/Supplemented.hs b/library/Supplemented.hs new file mode 100644 --- /dev/null +++ b/library/Supplemented.hs @@ -0,0 +1,175 @@ +module Supplemented +( + Supplemented, + runSupplemented, + essence, + supplement, +) +where + +import Supplemented.Prelude + + +{-# RULES +"essence/supplement/<*" [~2] + forall p1 p2. + essence p1 <* supplement p2 = + essenceAndSupplement p1 p2 +"essence/supplement/*>" [~2] + forall p1 p2. + essence p1 *> supplement p2 = + essenceAndSupplement (p1 $> ()) p2 +"*>/supplement" [~2] + forall p pp. + pp *> supplement p = + mapSupplement (*> p) pp $> () +"<*/supplement" [~2] + forall p pp. + pp <* supplement p = + mapSupplement (*> p) pp + #-} + + +newtype Supplemented m a = + Supplemented (Either (a, m ()) (m (a, m ()))) + +instance Functor m => Functor (Supplemented m) where + {-# INLINABLE fmap #-} + fmap f (Supplemented either1) = + Supplemented either2 + where + either2 = + case either1 of + Left (result1, supplement1) -> + Left (f result1, supplement1) + Right m1 -> + Right $ + fmap (\(result1, supplement1) -> (f result1, supplement1)) $ + m1 + +instance Monad m => Applicative (Supplemented m) where + {-# INLINE pure #-} + pure a = + Supplemented (Left (a, pure ())) + {-# INLINABLE [2] (<*>) #-} + (<*>) (Supplemented either1) (Supplemented either2) = + {-# SCC "(<*>)" #-} + Supplemented either3 + where + either3 = + case either1 of + Left (result1, supplement1) -> + case either2 of + Left (result2, supplement2) -> + Left (result1 result2, supplement1 *> supplement2) + Right m2 -> + Right $ + fmap (\(result2, supplement2) -> (result1 result2, supplement2)) $ + supplement1 *> m2 + Right m1 -> + case either2 of + Left (result2, supplement2) -> + Right $ + fmap (\(result1, supplement1) -> (result1 result2, supplement1 *> supplement2)) $ + m1 + Right m2 -> + Right $ + do + (result1, supplement1) <- m1 + supplement1 + (result2, supplement2) <- m2 + return (result1 result2, supplement2) + +instance MonadPlus m => Alternative (Supplemented m) where + {-# INLINE empty #-} + empty = + Supplemented (Right mzero) + {-# INLINABLE [2] (<|>) #-} + (<|>) (Supplemented either1) (Supplemented either2) = + {-# SCC "(<|>)" #-} + Supplemented either3 + where + either3 = + Right (mplus (m either1) (m either2)) + where + m = + either (\(result, supplement) -> (result, return ()) <$ supplement) id + +instance Monad m => Monad (Supplemented m) where + {-# INLINE return #-} + return = + pure + {-# INLINABLE (>>=) #-} + (>>=) (Supplemented either1) k2 = + {-# SCC "(>>=)" #-} + Supplemented either3 + where + either3 = + case either1 of + Left (result1, supplement1) -> + case k2 result1 of + Supplemented either2 -> + case either2 of + Left (result2, supplement2) -> + Left (result2, supplement1 *> supplement2) + Right m2 -> + Right (supplement1 *> m2) + Right m1 -> + Right $ + do + (result1, supplement1) <- m1 + case k2 result1 of + Supplemented either2 -> + case either2 of + Left (result2, supplement2) -> + return (result2, supplement1 *> supplement2) + Right m2 -> + do + supplement1 + m2 + +instance MonadPlus m => MonadPlus (Supplemented m) where + {-# INLINE mzero #-} + mzero = + empty + {-# INLINE mplus #-} + mplus = + (<|>) + +instance MonadTrans Supplemented where + {-# INLINE lift #-} + lift = + essence + + +{-# INLINE runSupplemented #-} +runSupplemented :: Monad m => Supplemented m a -> m (a, m ()) +runSupplemented (Supplemented either1) = + either return id either1 + +{-# INLINE [2] essence #-} +essence :: Monad m => m a -> Supplemented m a +essence essence = + Supplemented (Right (fmap (\r -> (r, return ())) essence)) + +{-# INLINE [2] supplement #-} +supplement :: Monad m => m () -> Supplemented m () +supplement supplement = + Supplemented (Left ((), supplement)) + +{-# INLINE [2] essenceAndSupplement #-} +essenceAndSupplement :: Monad m => m a -> m () -> Supplemented m a +essenceAndSupplement essence supplement = + Supplemented (Right (fmap (\r -> (r, supplement)) essence)) + +{-# INLINE [2] mapSupplement #-} +mapSupplement :: Monad m => (m () -> m ()) -> Supplemented m a -> Supplemented m a +mapSupplement mapping (Supplemented either1) = + Supplemented $ + case either1 of + Left (result1, supplement1) -> + Left (result1, mapping supplement1) + Right m1 -> + Right $ + fmap (\(result1, supplement1) -> (result1, mapping supplement1)) $ + m1 diff --git a/library/Supplemented/Prelude.hs b/library/Supplemented/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/Supplemented/Prelude.hs @@ -0,0 +1,20 @@ +module Supplemented.Prelude +( + module Exports, +) +where + + +-- base-prelude +------------------------- +import BasePrelude as Exports + +-- 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 +import Control.Monad.Trans.Maybe as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) diff --git a/supplemented.cabal b/supplemented.cabal new file mode 100644 --- /dev/null +++ b/supplemented.cabal @@ -0,0 +1,79 @@ +name: + supplemented +version: + 0.5.0.1 +synopsis: + Attoparsec extension for early termination +description: +category: + Parsing +homepage: + https://github.com/nikita-volkov/supplemented +bug-reports: + https://github.com/nikita-volkov/supplemented/issues +author: + Nikita Volkov +maintainer: + Nikita Volkov +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/supplemented.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: + Supplemented.Prelude + exposed-modules: + Supplemented + build-depends: + -- + attoparsec >= 0.13 && < 0.14, + -- + transformers >= 0.4 && < 0.6, + base-prelude < 2 + + +test-suite test + type: + exitcode-stdio-1.0 + hs-source-dirs: + 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: + -- + supplemented, + -- 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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,29 @@ +module Main where + +import Rebase.Prelude hiding (takeWhile) +import Test.Tasty +import Test.Tasty.Runners +import Test.Tasty.HUnit +import Supplemented + + +main = + defaultMain $ + testGroup "All tests" + [ + testCase "Supplements unite" $ + let + result :: [Int] + result = + execWriter $ + runSupplemented $ + do + essence (tell (pure 1)) + supplement (tell (pure 2)) + essence (tell (pure 3)) + supplement (tell (pure 4)) + supplement (tell (pure 5)) + pure () + supplement (tell (pure 6)) + in assertEqual (show result) [1, 2, 3] result + ]