diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Tobias Dammers (c) 2016 + +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 Tobias Dammers 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/praglude.cabal b/praglude.cabal new file mode 100644 --- /dev/null +++ b/praglude.cabal @@ -0,0 +1,44 @@ +name: praglude +version: 0.1.1.0 +synopsis: A pragmatic Prelude +description: An opinionated alternative Prelude, focused on practicality. +homepage: https://github.com/tdammers/praglude +license: BSD3 +license-file: LICENSE +author: Tobias Dammers +maintainer: tdammers@gmail.com +copyright: 2016 Tobias Dammers +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Praglude + build-depends: base >= 4.7 && < 5 + , aeson + , bytestring + , base64-bytestring + , casing + , containers + , data-default + , deepseq + , directory + , filepath + , hashable + , lens + , template-haskell + , mtl + , random + , semigroups + , string-convert + , text + , time + , unordered-containers + , vector + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/tdammers/praglude diff --git a/src/Praglude.hs b/src/Praglude.hs new file mode 100644 --- /dev/null +++ b/src/Praglude.hs @@ -0,0 +1,695 @@ +{-#LANGUAGE TypeSynonymInstances #-} +{-#LANGUAGE FlexibleInstances #-} +{-#LANGUAGE MultiParamTypeClasses #-} +{-#LANGUAGE DeriveGeneric #-} +{-#LANGUAGE DeriveFunctor #-} +{-#LANGUAGE DeriveTraversable #-} +{-#LANGUAGE AutoDeriveTypeable #-} +{-#LANGUAGE GeneralizedNewtypeDeriving #-} +{-#LANGUAGE FunctionalDependencies #-} +module Praglude +( +-- * The Original Prelude + module Prelude + +-- * Monoids +, module Data.Monoid +, concat +, append +, empty + +-- * Maybe +, module Data.Maybe + +-- * Applicative +, (<|>) + +-- * Monads +, module Control.Monad + +-- * Arrows +, module Control.Arrow + +-- * Mutable Variables In IO +, module Data.IORef +, module Control.Concurrent.MVar +, module Control.Concurrent.Chan + +-- * Default +, module Data.Default + +-- * Lens +, module Control.Lens + +-- * State monads +, module Control.Monad.State + +-- * Painless String Types +, s +, ToString (..) +, FromString +, IsString (..) + +, Text +, LText +, ByteString +, LByteString + +-- * Generalized String Operations + +, trim +, ltrim +, rtrim +, words +, lines + +, module Data.Char + +-- * String Case Conversions +, kebab, snake, pascal + +-- * I/O +, stderr +, stdout +, stdin +, Handle + +-- * Environment +, module System.Environment + +-- * Generalized I/O +, StringIO (..) + +-- * Printf +, module Text.Printf + +-- * Filename And File System Manipulation +, module System.FilePath +, module System.Directory + +-- * Type Forcers +-- +-- Useful for disambiguation +, asString +, asText +, asLText +, asByteString +, asLByteString +, asHashMap + +-- * Container Types With Unified Interfaces + +, module Data.Foldable + +, AList (..) +, HashMap +, LHashMap +, HashSet +, Map +, Set +, Vector + +, Hashable (..) +, Lookup (..) +, ListLike (..) +, DictLike (..) +, SetLike (..) +, Filterable (..) +, cull +, startsWith +, endsWith +, intercalate + +-- * JSON +, ToJSON (..) +, FromJSON (..) +, Value +, object +, prettyJsonOptions +, derivePrettyJSON +, deriveJSON + +, encodeJSON +, decodeJSON +, encodeJSONStrict +, decodeJSONStrict +, (~>) + +-- * Base-64 +, encodeBase64 +, decodeBase64 + +-- * Concurrency And Exception Handling +, threadDelay +, forkIO +, bracket +, bracket_ +, throw +, catch +, catches + +-- * Generics +, Generic + +-- * Functions +, chain +, module Data.Function + +-- * Date and Time +, Day (..) +, TimeOfDay (..) +, UTCTime (..) +, LocalTime (..) +, TimeZone (..) +, ZonedTime (..) +, TimeLocale (..) +, DiffTime (..) +, NominalDiffTime (..) +, secondsToDiffTime +, picosecondsToDiffTime +, addUTCTime +, diffUTCTime +, getCurrentTime + +, defaultTimeLocale + +, toGregorian +, fromGregorian + +, formatTime +) +where + +import Prelude hiding ( putStr + , putStrLn + , readFile + , writeFile + , lookup + , getContents + , null + , elem + , concat + , filter + , take + , drop + , lines + , words + , length + ) +import qualified Prelude +import System.FilePath hiding ( (<.>), isValid ) +import System.Directory +import qualified System.IO as IO +import System.IO (stderr, stdout, stdin, Handle) +import Data.Maybe +import Control.Monad +import Control.Applicative hiding ( empty ) +import Text.Printf +import Data.Monoid +import Data.Char +import Control.Arrow (left, right, (+++), (|||)) +import Data.Foldable hiding (null, elem, concat, length) +import System.Environment +import Control.Concurrent.MVar +import Control.Concurrent.Chan +import Data.IORef +import Control.Monad.State + +import Text.Casing +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Lazy.IO as LText +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashMap.Lazy as LHashMap +import qualified Data.HashSet as HashSet +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.Vector as Vector +import Data.Vector (Vector) +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Hashable (Hashable (..)) +import Text.StringConvert +import Data.Typeable +import GHC.Generics +import GHC.Exts hiding (toList) +import Data.Data +import Data.Semigroup +import Control.DeepSeq +import qualified Data.List as List +import Control.Lens +import Control.Lens.TH (makeLenses) +import Data.Aeson (ToJSON (..), FromJSON (..), Value, object) +import Data.Aeson.TH (deriveJSON) +import qualified Data.Aeson as JSON +import qualified Data.Aeson.TH as JSON +import Data.Default +import Data.List (foldl') +import Control.Concurrent +import Control.Exception +import Data.Function + +import Data.Time + +import Language.Haskell.TH.Syntax (Name, Q, Dec) + +type Text = Text.Text +type LText = LText.Text +type ByteString = BS.ByteString +type LByteString = LBS.ByteString + +empty :: Monoid a => a +empty = mempty + +append :: Monoid a => a -> a -> a +append = mappend + +concat :: Monoid a => [a] -> a +concat = mconcat + +lines :: (FromString a, ToString a) => a -> [a] +lines = map s . Prelude.lines . s + +words :: (FromString a, ToString a) => a -> [a] +words = map s . Prelude.words . s + +trim :: (FromString a, ToString a) => a -> a +trim = ltrim . rtrim + +ltrim :: (FromString a, ToString a) => a -> a +ltrim = s . dropWhile isSpace . s + +rtrim :: (FromString a, ToString a) => a -> a +rtrim = s . List.dropWhileEnd isSpace . s + +{-#RULES "Text.trim" trim = Text.strip #-} +{-#RULES "LText.trim" trim = Data.Text.Lazy.strip #-} +{-#RULES "Text.ltrim" trim = Text.dropWhile isSpace #-} +{-#RULES "Text.rtrim" trim = Text.dropWhileEnd isSpace #-} +{-#RULES "LText.ltrim" trim = Data.Text.Lazy.dropWhile isSpace #-} +{-#RULES "LText.rtrim" trim = Data.Text.Lazy.dropWhileEnd isSpace #-} + +type HashMap = HashMap.HashMap + +-- | A lazy hash map. Because 'LHashMap.HashMap' is actually the exact +-- same type as 'HashMap.HashMap', we wrap it in a newtype so that +-- we can tie laziness into the type itself (similar to how it works +-- for 'Text' and 'ByteString'). +newtype LHashMap k v = LHashMap { unLHashMap :: LHashMap.HashMap k v } + deriving (Read, Show, Typeable, Generic, Functor, Foldable, Traversable, Eq, Data, Semigroup, Monoid, NFData, Hashable) + +type HashSet = HashSet.HashSet + +-- | Types that can be written to / read from file descriptors. +class StringIO a where + putStr :: a -> IO () + putStrLn :: a -> IO () + hPutStr :: Handle -> a -> IO () + hPutStrLn :: Handle -> a -> IO () + readFile :: FilePath -> IO a + writeFile :: FilePath -> a -> IO () + getContents :: IO a + hGetContents :: Handle -> IO a + putStrLn str = putStr str >> putStr "\n" + hPutStrLn h str = hPutStr h str >> hPutStr h "\n" + +instance StringIO String where + putStr = IO.putStr + putStrLn = IO.putStrLn + hPutStr = IO.hPutStr + hPutStrLn = IO.hPutStrLn + readFile = IO.readFile + writeFile = IO.writeFile + getContents = IO.getContents + hGetContents = IO.hGetContents + +instance StringIO Text where + putStr = Text.putStr + putStrLn = Text.putStrLn + hPutStr = Text.hPutStr + hPutStrLn = Text.hPutStrLn + readFile = Text.readFile + writeFile = Text.writeFile + getContents = Text.getContents + hGetContents = Text.hGetContents + +instance StringIO LText where + putStr = LText.putStr + putStrLn = LText.putStrLn + hPutStr = LText.hPutStr + hPutStrLn = LText.hPutStrLn + readFile = LText.readFile + writeFile = LText.writeFile + getContents = LText.getContents + hGetContents = LText.hGetContents + +instance StringIO ByteString where + putStr = BS.putStr + hPutStr = BS.hPutStr + readFile = BS.readFile + writeFile = BS.writeFile + getContents = BS.getContents + hGetContents = BS.hGetContents + +instance StringIO LByteString where + putStr = LBS.putStr + hPutStr = LBS.hPutStr + readFile = LBS.readFile + writeFile = LBS.writeFile + getContents = LBS.getContents + hGetContents = LBS.hGetContents + +-- | Things that support keyed element lookup. +class Lookup m k | m -> k where + lookup :: k -> m v -> Maybe v + lookupDef :: v -> k -> m v -> v + lookupDef d k = fromMaybe d . lookup k + +newtype AList k v = AList { unAList :: [(k, v)] } + deriving (Show, Read, Eq, Ord, Generic, Functor) + +instance Eq k => Lookup (AList k) k where + lookup k = Prelude.lookup k . unAList + +class ListLike m a | m -> a where + intersperse :: a -> m -> m + take :: Int -> m -> m + takeEnd :: Int -> m -> m + drop :: Int -> m -> m + dropEnd :: Int -> m -> m + slice :: Int -> Int -> m -> m + slice offset len = take len . drop offset + length :: m -> Int + takeEnd n x = drop (length x - n) x + dropEnd n x = take (length x - n) x + +instance ListLike [a] a where + intersperse = List.intersperse + take = List.take + drop = List.drop + length = List.length + +instance ListLike (Vector a) a where + intersperse e = Vector.fromList . List.intersperse e . Vector.toList + take = Vector.take + drop = Vector.drop + slice = Vector.slice + length = Vector.length + +instance ListLike Text Char where + intersperse = Text.intersperse + take = Text.take . fromIntegral + drop = Text.drop . fromIntegral + length = fromIntegral . Text.length + +instance ListLike LText Char where + intersperse = LText.intersperse + take = LText.take . fromIntegral + drop = LText.drop . fromIntegral + length = fromIntegral . LText.length + +startsWith :: (Eq a, ListLike a e) => a -> a -> Bool +startsWith haystack needle = + take (length needle) haystack == needle + +endsWith :: (Eq a, ListLike a e) => a -> a -> Bool +endsWith haystack needle = + takeEnd (length needle) haystack == needle + +intercalate :: (Monoid a, Foldable m, ListLike (m a) a) => a -> m a -> a +intercalate s = mconcat . toList . intersperse s + +-- | Things that behave like sets. +class SetLike m v | m -> v where + -- | Conjoin: add an element to a set. For ordered sets, the + -- end at which the new element is inserted is unspecified. + conj :: v -> m -> m + + -- | Remove all occurrences of the element from the set. + remove :: v -> m -> m + + -- | Test if the element is in the set. + elem :: v -> m -> Bool + + -- | Test if the set is empty. + null :: m -> Bool + + -- | Convert the set to a list of elements. The ordering is unspecified. + items :: m -> [v] + + -- | Create a set from a list of elements. Duplicate list elements + -- may be skipped at the implementation's discretion. + fromItems :: [v] -> m + + -- | Create a singleton (one-element) set. + singleton :: v -> m + + -- | Get the number of elements in the set. + size :: m -> Int + + size = List.length . items + null = List.null . items + +-- | Things that can be filtered +class Filterable m where + -- | Filter the set to retain only the elements that match the predicate. + filter :: (v -> Bool) -> m v -> m v + +cull :: Filterable m => (v -> Bool) -> m v -> m v +cull = filter . (not .) + +-- | Things that behave like key-value dictionaries. +class DictLike m k where + -- | Add or overwrite an element at a key. + insert :: k -> v -> m k v -> m k v + -- | Delete by key + delete :: k -> m k v -> m k v + -- | Modify an element at a key + update :: k -> (v -> Maybe v) -> m k v -> m k v + -- | Convert to an association list (list of key/value pairs) + pairs :: m k v -> [(k, v)] + -- | Convert from an association list (list of key/value pairs) + fromPairs :: [(k, v)] -> m k v + -- | Get the keys, discard the values + keys :: m k v -> [k] + -- | Get the values, discard the keys + elems :: m k v -> [v] + -- | Create a singleton dictionary (just one key-value pair) + singletonMap :: k -> v -> m k v + -- | Test whether the dictionary contains a given key + member :: k -> m k v -> Bool + + keys = map fst . pairs + elems = map snd . pairs + +instance Eq k => DictLike AList k where + insert k v (AList xs) = AList $ (k,v):xs + delete k (AList xs) = AList $ filter ((/= k) . fst) xs + update k f (AList xs) = AList [ (k, fromMaybe v $ f v) | (k, v) <- xs ] + pairs = unAList + fromPairs = AList + singletonMap k v = AList [(k, v)] + member k = not . null . filter (== k) . keys + +instance Lookup [] Int where + lookup i xs = case drop i xs of + [] -> Nothing + (x:_) -> Just x + +instance Lookup Vector Int where + lookup = flip (Vector.!?) + +instance (Eq a) => SetLike (Vector a) a where + conj = Vector.cons + remove x = Vector.filter (/= x) + elem = Vector.elem + null = Vector.null + items = Vector.toList + fromItems = Vector.fromList + singleton = Vector.singleton + size = Vector.length + +instance Filterable Vector where + filter = Vector.filter + +instance (Eq a) => SetLike [a] a where + conj = (:) + remove x = filter (/= x) + elem = List.elem + null = List.null + items = id + fromItems = id + singleton = (:[]) + size = List.length + +instance Filterable [] where + filter = List.filter + +instance (Eq v, Hashable v) => SetLike (HashSet v) v where + conj = HashSet.insert + remove = HashSet.delete + elem = HashSet.member + null = HashSet.null + items = HashSet.toList + fromItems = HashSet.fromList + singleton = HashSet.singleton + size = HashSet.size + +instance Filterable HashSet where + filter = HashSet.filter + +instance (Eq v, Ord v) => SetLike (Set v) v where + conj = Set.insert + remove = Set.delete + elem = Set.member + null = Set.null + items = Set.toList + fromItems = Set.fromList + singleton = Set.singleton + size = Set.size + +instance Filterable Set where + filter = Set.filter + +instance (Eq k, Hashable k) => Lookup (HashMap.HashMap k) k where + lookup = HashMap.lookup + +instance (Eq k, Hashable k) => DictLike HashMap.HashMap k where + insert = HashMap.insert + delete = HashMap.delete + update = flip HashMap.update + pairs = HashMap.toList + fromPairs = HashMap.fromList + keys = HashMap.keys + elems = HashMap.elems + singletonMap = HashMap.singleton + member = HashMap.member + +instance (Eq k, Hashable k) => SetLike (HashMap k v) (k, v) where + conj = uncurry insert + remove = delete . fst + elem = member . fst + null = HashMap.null + items = pairs + fromItems = fromPairs + singleton = uncurry singletonMap + +instance Filterable (HashMap k) where + filter = HashMap.filter + +instance (Eq k, Ord k) => Lookup (Map.Map k) k where + lookup = Map.lookup + +instance (Eq k, Ord k) => DictLike Map.Map k where + insert = Map.insert + delete = Map.delete + update = flip Map.update + pairs = Map.toList + fromPairs = Map.fromList + keys = Map.keys + elems = Map.elems + singletonMap = Map.singleton + member = Map.member + +instance (Eq k, Ord k) => SetLike (Map k v) (k, v) where + conj = uncurry insert + remove = delete . fst + elem = member . fst + null = Map.null + items = pairs + fromItems = fromPairs + singleton = uncurry singletonMap + +instance Filterable (Map k) where + filter = Map.filter + +overLHashMap :: (HashMap k v -> HashMap k v) -> LHashMap k v -> LHashMap k v +overLHashMap f = LHashMap . f . unLHashMap + +instance (Eq k, Hashable k) => DictLike LHashMap k where + insert k v = overLHashMap $ LHashMap.insert k v + delete k = overLHashMap $ LHashMap.delete k + update k f = overLHashMap $ LHashMap.update f k + pairs = LHashMap.toList . unLHashMap + fromPairs = LHashMap . LHashMap.fromList + keys = LHashMap.keys . unLHashMap + elems = LHashMap.elems . unLHashMap + singletonMap k v = LHashMap (LHashMap.singleton k v) + member k = LHashMap.member k . unLHashMap + +instance (Eq k, Hashable k) => Lookup (LHashMap k) k where + lookup k = LHashMap.lookup k . unLHashMap + +instance (Eq k, Hashable k) => SetLike (LHashMap k v) (k, v) where + conj = uncurry insert + remove = delete . fst + elem = member . fst + null = LHashMap.null . unLHashMap + items = pairs + fromItems = fromPairs + singleton = uncurry singletonMap + +instance Filterable (LHashMap k) where + filter p = overLHashMap $ LHashMap.filter p + +prettyJsonOptions :: JSON.Options +prettyJsonOptions = + JSON.defaultOptions + { JSON.fieldLabelModifier = kebab . dropWhile (== '_') + , JSON.constructorTagModifier = kebab + , JSON.omitNothingFields = True + , JSON.sumEncoding = JSON.defaultTaggedObject + { JSON.tagFieldName = "what" + , JSON.contentsFieldName = "value" + } + } + +derivePrettyJSON :: Name -> Q [Dec] +derivePrettyJSON = deriveJSON prettyJsonOptions + +asString :: String -> String +asString = id + +asText :: Text -> Text +asText = id + +asLText :: LText -> LText +asLText = id + +asByteString :: ByteString -> ByteString +asByteString = id + +asLByteString :: LByteString -> LByteString +asLByteString = id + +asHashMap :: HashMap k v -> HashMap k v +asHashMap = id + +encodeJSON :: ToJSON a => a -> LByteString +encodeJSON = JSON.encode + +decodeJSON :: FromJSON a => LByteString -> Maybe a +decodeJSON = JSON.decode + +encodeJSONStrict :: ToJSON a => a -> ByteString +encodeJSONStrict = s . JSON.encode + +decodeJSONStrict :: FromJSON a => ByteString -> Maybe a +decodeJSONStrict = JSON.decodeStrict + +chain :: Traversable t => t (a -> a) -> a -> a +chain = foldl' (.) id + +(~>) :: ToJSON a => Text -> a -> (Text, Value) +(~>) = (JSON..=) + +decodeBase64 :: ByteString -> ByteString +decodeBase64 = Base64.decodeLenient + +encodeBase64 :: ByteString -> ByteString +encodeBase64 = Base64.encode