diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Mark Andrus Roberts + +All rights reserved. + +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 Mark Andrus Roberts nor the names of other + 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 +OWNER 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. 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/dist/build/GoldenStub/GoldenStub-tmp/GoldenStub.hs b/dist/build/GoldenStub/GoldenStub-tmp/GoldenStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/GoldenStub/GoldenStub-tmp/GoldenStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import Golden ( tests ) +main :: IO () +main = stubMain tests diff --git a/first-and-last.cabal b/first-and-last.cabal new file mode 100644 --- /dev/null +++ b/first-and-last.cabal @@ -0,0 +1,44 @@ +name: first-and-last +version: 0.1.0.0 +synopsis: First and Last generalized to return up to n values +description: + This library provides data types @@ and @@ generalizing @First@ and @Last@ from @@ to return up to @n@ values. + . + >>> getFirst' (foldMap pure [1,2,3,4] :: First' 2 Int) + [1,2] + . + >>> getLast' (foldMap pure [1,2,3,4] :: Last' 2 Int) + [3,4] + . + It also provides API-compatible type synonyms @@ and @@ as well as functions @@ and @@, allowing you to use it as a drop-in replacement. +homepage: https://github.com/markandrus/first-and-last +license: BSD3 +license-file: LICENSE +author: Mark Andrus Roberts +maintainer: markandrusroberts@gmail.com +copyright: Copyright (C) 2015 Mark Andrus Roberts +category: Data +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/markandrus/first-and-last + +library + exposed-modules: Data.Monoid.First, + Data.Monoid.Last + build-depends: base >=4.8 && <4.9 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite Golden + type: detailed-0.9 + test-module: Golden + build-depends: base >=4.8 && <4.9, + Cabal >=1.22.4, + first-and-last + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Data/Monoid/First.hs b/src/Data/Monoid/First.hs new file mode 100644 --- /dev/null +++ b/src/Data/Monoid/First.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +------------------------------------------------------------------------------- +-- | +-- Module : Data.Monoid.First +-- Copyright : (C) 2015 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- @'First'' n@ is a generalization of the @First@ exported by @Data.Monoid@: +-- whereas @Data.Monoid.First@ returns up to one value, @'First'' n@ returns +-- up to @n@ values. +-- +-- @ +-- Data.Monoid.First a ≡ +-- 'First'' 1 a ≡ +-- 'First' a +-- @ +-- +-- This library also provides an API-compatible type synonym 'First' and +-- function 'getFirst' allowing you to use it as a drop-in replacement. +------------------------------------------------------------------------------- +module Data.Monoid.First + ( -- * @First@ + First + , getFirst + -- * @First'@ + , First' + , getFirst' + ) where + +import Control.Applicative (Applicative((<*>), pure), Alternative) +import Data.Data (Data) +import Data.Proxy (Proxy(Proxy)) +import Data.String (IsString(fromString)) +import GHC.Generics (Generic, Generic1) +import GHC.TypeLits (KnownNat, Nat, natVal) +import Prelude (($), (.), Char, Eq, Foldable(foldr), Functor, Maybe(Just, Nothing), Monoid(mappend, mempty), Ord, Read, Show, Traversable, fromIntegral, head, take) + +-------------------------------------------------------------------------------- +-- * First +-------------------------------------------------------------------------------- + +-- | A type isomorphic to @Data.Monoid.First@ +type First a = First' 1 a + +-- | Get the first value of type @a@, if any. +-- +-- >>> getFirst (foldMap pure []) +-- Nothing +-- +-- >>> getFirst (foldMap pure [1,2,3,4]) +-- Just 1 +getFirst :: First a -> Maybe a +getFirst (First' []) = Nothing +getFirst (First' as) = Just . head $ take 1 as + +-------------------------------------------------------------------------------- +-- * First' +-------------------------------------------------------------------------------- + +-- | A generalized version of @Data.Monoid.First@ +newtype First' (n :: Nat) a = First' { _getFirst' :: [a] } deriving + ( Alternative + , Data + , Eq + , Foldable + , Functor + , Generic + , Generic1 + , Ord + , Read + , Show + , Traversable + ) + +-- | Get the first @n@ values or fewer of type @a@. +-- +-- >>> getFirst' (foldMap pure [1,2,3,4] :: First' 0 Int) +-- [] +-- +-- >>> getFirst' (foldMap pure [1,2,3,4] :: First' 1 Int) +-- [1] +-- +-- >>> getFirst' (foldMap pure [1,2,3,4] :: First' 2 Int) +-- [1,2] +getFirst' :: First' n a -> [a] +getFirst' = _getFirst' + +instance KnownNat n => Applicative (First' n) where + First' l <*> First' r = First' $ l <*> r + pure a = case natVal (Proxy :: Proxy n) of + 0 -> mempty + _ -> First' $ pure a + +instance KnownNat n => Monoid (First' n a) where + First' l `mappend` First' r = + let n = fromIntegral $ natVal (Proxy :: Proxy n) + in First' . take n $ l `mappend` r + mempty = First' mempty + +instance KnownNat n => IsString (First' n Char) where + fromString = foldr (\c a -> pure c `mappend` a) mempty diff --git a/src/Data/Monoid/Last.hs b/src/Data/Monoid/Last.hs new file mode 100644 --- /dev/null +++ b/src/Data/Monoid/Last.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +------------------------------------------------------------------------------- +-- | +-- Module : Data.Monoid.Last +-- Copyright : (C) 2015 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- @'Last'' n@ is a generalization of the @Last@ exported by @Data.Monoid@: +-- whereas @Data.Monoid.Last@ returns up to one value, @'Last'' n@ returns +-- up to @n@ values. +-- +-- @ +-- Data.Monoid.Last a ≡ +-- 'Last'' 1 a ≡ +-- 'Last' a +-- @ +-- +-- This library also provides an API-compatible type synonym 'Last' and +-- function 'getLast' allowing you to use it as a drop-in replacement. +------------------------------------------------------------------------------- +module Data.Monoid.Last + ( -- * @Last@ + Last + , getLast + -- * @Last'@ + , Last' + , getLast' + ) where + +import Control.Applicative (Applicative((<*>), pure), Alternative) +import Data.Data (Data) +import Data.Proxy (Proxy(Proxy)) +import Data.String (IsString(fromString)) +import GHC.Generics (Generic, Generic1) +import GHC.TypeLits (KnownNat, Nat, natVal) +import Prelude (($), (.), Char, Eq, Foldable(foldr), Functor, Int, Maybe(Just, Nothing), Monoid(mappend, mempty), Ord, Read, Show, Traversable, fromIntegral, drop, error, head) + +-------------------------------------------------------------------------------- +-- * Last +-------------------------------------------------------------------------------- + +-- | A type isomorphic to @Data.Monoid.Last@ +type Last a = Last' 1 a + +-- | Get the last value of type @a@, if any. +-- +-- >>> getLast (foldMap pure []) +-- Nothing +-- +-- >>> getLast (foldMap pure [1,2,3,4]) +-- Just 4 +getLast :: Last a -> Maybe a +getLast (Last' []) = Nothing +getLast (Last' as) = Just . head $ takeR 1 as + +-------------------------------------------------------------------------------- +-- * Last' +-------------------------------------------------------------------------------- + +-- | A generalized version of @Data.Monoid.Last@ +newtype Last' (n :: Nat) a = Last' { _getLast' :: [a] } deriving + ( Alternative + , Data + , Eq + , Foldable + , Functor + , Generic + , Generic1 + , Ord + , Read + , Show + , Traversable + ) + +-- | Get the last @n@ values or fewer of type @a@. +-- +-- >>> getLast' (foldMap pure [1,2,3,4] :: Last' 0 Int) +-- [] +-- +-- >>> getLast' (foldMap pure [1,2,3,4] :: Last' 1 Int) +-- [4] +-- +-- >>> getLast' (foldMap pure [1,2,3,4] :: Last' 2 Int) +-- [3,4] +getLast' :: Last' n a -> [a] +getLast' = _getLast' + +instance KnownNat n => Applicative (Last' n) where + Last' l <*> Last' r = Last' $ l <*> r + pure a = case natVal (Proxy :: Proxy n) of + 0 -> mempty + _ -> Last' $ pure a + +instance KnownNat n => Monoid (Last' n a) where + Last' l `mappend` Last' r = + let n = fromIntegral $ natVal (Proxy :: Proxy n) + in Last' . takeR n $ l `mappend` r + mempty = Last' mempty + +-- https://www.joachim-breitner.de/blog/600-On_taking_the_last_n_elements_of_a_list +takeR :: Int -> [a] -> [a] +takeR n l = go (drop n l) l + where + go [] r = r + go (_:xs) (_:ys) = go xs ys + go (_:_) [] = error "impossible!" + +instance KnownNat n => IsString (Last' n Char) where + fromString = foldr (\c a -> pure c `mappend` a) mempty diff --git a/test/Golden.hs b/test/Golden.hs new file mode 100644 --- /dev/null +++ b/test/Golden.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------------------------- +-- | +-- Module : Data.Monoid.First +-- Copyright : (C) 2015 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +------------------------------------------------------------------------------- +module Golden where + +import Data.Monoid.First +import Data.Monoid.Last +import Distribution.TestSuite (Progress(Finished), Result(Error, Pass), Test(Test), TestInstance(TestInstance, name, options, run, setOption, tags)) +import Prelude (($), (++), (.), Bool, Eq((==)), Char, Int, IO, Show(show), String, foldMap, pure) + +assert :: String -> Bool -> String -> Test +assert name' assertion error' = + let test = TestInstance + { name = name' + , options = [] + , run = pure . Finished $ + if assertion + then Pass + else Error error' + , setOption = \_ _ -> pure test + , tags = [] + } + in Test test + +assertEqual :: (Eq a, Show a) => (a, a) -> Test +assertEqual (a, b) + = assert (show a ++ " == " ++ show b) (a == b) (show a ++ " /= " ++ show b) + +firstTest :: Test +firstTest = assertEqual + (getFirst (foldMap pure [1, 2, 3, 4]), pure 1) + +first'0PureTest :: Test +first'0PureTest = assertEqual + (getFirst' (pure 1 :: First' 0 Int), []) + +first'OverloadedStringTest :: Test +first'OverloadedStringTest = assertEqual + ("abcd" :: First' 2 Char, "ab" :: First' 2 Char) + +firstOverloadedStringTest :: Test +firstOverloadedStringTest = assertEqual + ("abcd" :: First Char, "a" :: First Char) + +lastTest :: Test +lastTest = assertEqual + (getLast (foldMap pure [1, 2, 3, 4]), pure 4) + +last'0PureTest :: Test +last'0PureTest = assertEqual + (getLast' (pure 1 :: Last' 0 Int), []) + +last'OverloadedStringTest :: Test +last'OverloadedStringTest = assertEqual + ("abcd" :: Last' 2 Char, "cd" :: Last' 2 Char) + +lastOverloadedStringTest :: Test +lastOverloadedStringTest = assertEqual + ("abcd" :: Last Char, "d" :: Last Char) + +tests :: IO [Test] +tests = pure + [ firstTest + , first'0PureTest + , first'OverloadedStringTest + , firstOverloadedStringTest + , lastTest + , last'0PureTest + , last'OverloadedStringTest + , lastOverloadedStringTest + ]