diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,5 @@ ## v0.1 + initial release -+ ***deprecated*** ## v0.1.0.1 + Patch: Modules were not properly exported in Cabal file @@ -15,7 +14,7 @@ + Added CHANGELOG.md to source package ## v0.2.1 -+ Added __ ++ Added `__` (short hand for `undefined`) ## v0.3 + Also exports @@ -27,4 +26,81 @@ + New dependency on `hydrogen-version` + Exports `module Hydrogen.Version` as replacement for `module Data.Version` +## v0.4 +*Skipped, bumped to v0.5 to be aligned with other hydrogen packages* + +## v0.5 ++ Deriving instance `Eq` for `ZonedTime` + +## v0.6 ++ New dependencies + + `cereal` for serialization + + `strict` for strict io in `Hydrogen.Prelude.IO` ++ Also exports + + `module Data.Dynamic` + + `module Data.Typeable` ++ Added `ShowBox` class (an existentially qualified container type) + +## v0.7 ++ Newly deriving instances + + `Serialize` for `ZonedTime` + + `Serialize` for `Version` + +## v0.8 ++ Added `class TMap (tmap)` and `class Has (HasKey, HasValue, (!))` ++ Introduced `type List a` as alias for `[a]` ++ Also exports + + `Data.Seq` ++ Added the F-Sharp inspired `|>` (which is `flip ($)`) ++ Exporting only `Generic` from `GHC.Generics` ++ Added `Hydrogen.Prelude.Network` + +## v0.9 ++ Also exports + + `module Data.Traversable` ++ Added `class Container (Contained, (?))` ++ `fmap` is exported as `map` + +## v0.10 ++ Added `safeHeadAndTail`, `safeHeadAndTail2`, `firstJust` ++ Little documentation improvements ++ Added `findFilesRecursively` and `findFilesRecursivelyWithContext` + in `Hydrogen.Prelude.System` + +## v0.11 ++ Added `nicify` form `Text.Nicify` ++ Upgraded dependency `hydrogen-version` from `>=1.2` to `>=1.3` + +## v0.12 ++ Added `Default` + +## v0.13 ++ _Skipped_ + +## v0.14 ++ Aligned with other `hydrogen-*` packages + +## v0.15 ++ Added `Apply` ++ Added `uncurry3`, `uncurry4`, `uncurry5` + +## v0.16 ++ Changed `Apply` to use `-XMultiParamTypeClasses` and `-XTypeFamilies` + for better type inference ++ Added `$$`, `$$$`, `$$$$`, `$$$$$` (like `uncurryN`) ++ Added `<$$>`, `<$$$>`, `<$$$$>`, `<$$$$$>` (like `<$>` and `uncurryN`) + +## v0.17 ++ Removed instance `MonadPlus m => Default (m a)`. + +## v0.18 ++ Removed dependency on `nicify` + +## v0.19 ++ Removed `Apply` and `Applicator` again ++ Lowered dependencies to work with GHC 7.6 and base 4.6 too + +## v0.20 ++ Support for GHC 7.4, 7.6, and 7.8 ++ Instances for `Serializable` but also for `Binary` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,312 @@ +hydrogen-prelude +================ +[![Build Status](https://travis-ci.org/scravy/hydrogen-prelude.svg?branch=master)](https://travis-ci.org/scravy/hydrogen-prelude) + ++ [`about`](#about) + + [`scravy.de/hydrogen-prelude`](http://scravy.de/hydrogen-prelude) + + [`hackage.haskell.org/package/hydrogen-prelude`](http://hackage.haskell.org/package/hydrogen-prelude) ++ [`goodies`](#goodies) + + [`(!)`](#--has-a--a--haskey-a--hasvalue-a) + + [`(?)`](#--container-a--a--contained-a--bool) + + [`tmap`](#tmap) + + [`fmap` vs `map`](#fmap-vs-map) + + [`__`](#__--a) + + [`|>`](#fsharps--which-is-flip-) + + [`safeHead`](#safehead--a--a--a) + + [`ShowBox`](#showbox--forall-a-show-a--a--showbox) + + [`.|`, `.&`, `.^`](#----a--bool--a--bool--a--bool) + + [`List a`](#type-list-a--a) + + [`Default a`](#class-default-a) + + [`Apply a`](#class-apply-a) ++ [`re-exports`](#re-exports) + + [`Hydrogen.Prelude`](#hydrogenprelude) + + [`Hydrogen.Prelude.IO`](#hydrogenpreludeio) + + [`Hydrogen.Prelude.System`](#hydrogenpreludesystem) + + [`Hydrogen.Prelude.Network`](#hydrogenpreludenetwork) ++ [`FAQ`](#faq) + +about +----- + +A Prelude that exports much of the standard library (more then `Prelude`), without conflicts. If for example you were to import `Prelude` and `Data.List` or `Data.Foldable` you will run into ambiguous imports (regarding `foldr` for example). This Prelude aims at exporting the most general functions (in this case `foldr` from `Data.Foldable`). + +It also pulls in some default packages like `cereal` for serialization and `containers` for data types like `Map` and `Set`. Every datatype exported by this Prelude comes with instances for `Serialize`. + +Longs story short, instead of: + + import Prelude hiding ( + all, and, any, concat, concatMap, elem, foldl, foldl1, foldr, foldr1, + mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum + ) + import "base" Control.Monad hiding ( + forM, forM_, mapM, mapM_, msum, sequence, sequence_ + ) + import Data.Foldable + import Data.Traversable + import Data.List hiding ( + all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, + mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sum + ) + +it suffices to: + + import Hydrogen.Prelude + +goodies +------- + +Beyond existing functions from well-known standard packages, this prelude defines a few utilities (mostly aimed at unifying functionality across different packages, like `containers` and `array`). + +--- + +### `(!) :: Has a ⇒ a → HasKey a → HasValue a` + +`(!)` is provided for several data types which associate a key and a value. + + [(1, 'a'), (3, 'v')] ! 1 → 'a' + +Instances are defined for + ++ `Eq k ⇒ [(k, v)]` ++ `Ix i ⇒ Array i e` with `HasKey → i` ++ `Ord k ⇒ Map k v` with `HasValue → v` ++ `Ord k ⇒ MultiMap k v` with `HasValue → [v]` + +--- + +### `(?) :: Container a ⇒ a → Contained a → Bool` + +Check whether the element on the right is contained in the collection on the left. + + [1, 2, 4] ? 3 → False + +Instances are defined for + ++ `Eq a ⇒ [a]` ++ `Ord a ⇒ Set a` ++ `Eq a ⇒ Seq a` ++ `Ord k ⇒ Map k v` with `Contained → k` ++ `Ord k ⇒ MultiMap k v` with `Contained → k` + +--- + +### `tmap` + +A little bit like `fmap` but defined differently on some datatypes (applies e.g. to both components of a tuple). + + tmap succ (3, 4) → (4, 5) + +Instances are defined for + ++ `(a, a)` ++ `(a, a, a)` ++ `(a, a, a, a)` ++ `[a]` ++ `Seq a` ++ `Map k v` ++ `MultiMap k v` + +--- + +### `fmap` vs `map` + +Hydrogen Prelude exports `fmap` as `map` - the way it ought to be. + +--- + +### `__ :: a` + +A handy shortcut for `undefined`. + +--- + +### FSharp's `|>` (which is `flip ($)`) + +Use it to pipe things from one function to the other, left to right: + + head xs |> fromEnum |> show + +--- + +### `safeHead :: a → [a] → a` + +The head of the list, or the default given as first argument. + + safeHead x xs = maybe x head . listToMaybe + +--- + +### `ShowBox :: forall a. (Show a) ⇒ a → ShowBox` ### + +Wrap anything that is showable (can be used to build heterogeneous lists). + +--- + +### `.|, .&, .^ :: (a → Bool) → (a → Bool) → (a → Bool)` + +Combines predicates. + + filter (isDigit .| isLetter) + +--- + +### `type List a = [a]` + +A longhand for the type of lists, if you prefer this more wordy version. + +--- + +### `class Default a` ### + +A class that provides the `def` function for default values for types. +Instances of `MonadPlus` automatically have an instance where `def = mzero`. + +Default instances for most primitive types are also provided. + +--- + +### `class Apply a` ### + +Provides the `*$*` operator which is your all-purpose application operator. +It does uncurrying (if you want to apply a tupel result of a function to +a function that is curryied, works with tupels of up to 5 components) and +also works with `Applicative`, i.e. it also does `fmap . uncurry`: + + data Operator = Operator Value OperatorType Value + + parseInfixOperation :: Parser (Value, OperatorType, Value) + + ... Operator *$* parseInfixOperation ... + +re-exports +---------- + + +### Hydrogen.Prelude + +The Hydrogen Prelude offers you the functions and datatypes from these modules, all with one import: + ++ from [`base`](http://hackage.haskell.org/package/base) + + `module Prelude` + + `module Control.Applicative` + + `module Control.Arrow` + + `module Control.Monad` + + `module Data.Bits` + + `module Data.Bool` + + `module Data.Char` + + `module Data.Complex` + + `module Data.Complex` + + `module Data.Dynamic` + + `module Data.Either` + + `module Data.Fixed` + + `module Data.Function` + + `module Data.Foldable` + + `module Data.Int` + + `module Data.Ix` + + `module Data.List` + + `module Data.Maybe` + + `module Data.Ord` + + `module Data.Ratio` + + `module Data.String` + + `module Data.Time` + + `module Data.Traversable` + + `module Data.Tuple` + + `module Data.Typeable` + + `module Data.Word` + + `module Numeric` + + `module Text.Printf` + ++ from [`array`](http://hackage.haskell.org/package/array) + + `module Data.Array` + ++ from [`cereal`](http://hackage.haskell.org/package/cereal) + + `module Data.Serialize` + ++ from [`containers`](http://hackage.haskell.org/package/containers) + + `Data.Set`, `Data.Map`, and `Data.Seq` + ++ from [`hashable`](http://hackage.haskell.org/package/hashable) + + `module Data.Hashable` + ++ form [`hydrogen-multimap`](http://hackage.haskell.org/package/hydrogen-multimap) + + `Hydrogen.MultiMap` + ++ from [`hydrogen-version`](http://hackage.haskell.org/package/hydrogen-version) + + `module Hydrogen.Version` + ++ from [`regex-tdfa`](http://hackage.haskell.org/package/regex-tdfa) + + `module Text.Regex.TDFA` + ++ from [`time`](http://hackage.haskell.org/package/time) + + `module Data.Time` + ++ from [`transformers`](http://hackage.haskell.org/package/transformers) + + `module Data.Functor.Identity` + + `module Data.Functor.Reverse` + ++ from [`uuid`](http://hackage.haskell.org/package/uuid) + + `Data.UUID` + + `Data.UUID.fromString` as `uuidFromString` + + `Data.UUID.V4.nextRandom` as `randomUUID` + + +### Hydrogen.Prelude.IO + ++ from [`base`](http://hackage.haskell.org/package/base) + + `module Data.IORef` + + `module Control.Concurret` + + `module Control.Exception` + + `module System.IO` + + `module System.Timeout` + ++ from [`strict`](http://hackage.haskell.org/package/strict) + + strict IO functions `hGetContents'`, `getContents'`, `readFile'`, `interact'` + + +### Hydrogen.Prelude.System + ++ from [`base`](http://hackage.haskell.org/package/base) + + `module System.CPUTime` + + `module System.Environment` + + `module System.Exit` + + `module System.Info` + ++ from [`directory`](http://hackage.haskell.org/package/directory) + + `module System.Directory` + ++ from [`filepath`](http://hackage.haskell.org/package/filepath) + + `module System.FilePath` + ++ from [`process`](http://hackage.haskell.org/package/process) + + `module System.Process` + ++ from [`random`](http://hackage.haskell.org/package/random) + + `module System.Random` + + +### Hydrogen.Prelude.Network + ++ from [`network`](http://hackage.haskell.org/package/network) + + `module Network` + + +FAQ +=== + +How is some of the *magic* accomplished? +---------------------------------------- + +Mostly with `XTypeFamilies` and `XStandaloneDeriving`. + +So this works only with GHC? +---------------------------- + +Yes, for now at least. + +What is `hydrogen` +------------------ + +https://www.youtube.com/watch?v=rbBX6aEzEz8 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,4 @@ import Distribution.Simple + main = defaultMain + diff --git a/hydrogen-prelude.cabal b/hydrogen-prelude.cabal --- a/hydrogen-prelude.cabal +++ b/hydrogen-prelude.cabal @@ -1,8 +1,8 @@ name: hydrogen-prelude -version: 0.8 -homepage: https://scravy.de/hydrogen-prelude/ +version: 0.20 +homepage: http://scravy.de/hydrogen-prelude/ synopsis: Hydrogen Prelude -license: BSD3 +license: MIT license-file: LICENSE extra-source-files: CHANGELOG.md, README.md author: Julian Fleischer @@ -12,50 +12,59 @@ cabal-version: >=1.14 source-repository head - type: git - location: https://github.com/scravy/hydrogen-prelude + type: git + location: https://github.com/scravy/hydrogen-prelude +flag explicitText + library exposed-modules: Hydrogen.Prelude , Hydrogen.Prelude.IO , Hydrogen.Prelude.Network , Hydrogen.Prelude.System - build-depends: base ==4.7.* - , array ==0.5.* - , cereal ==0.4.* - , containers ==0.5.* - , directory ==1.2.* - , filepath ==1.3.* - , hashable ==1.2.* - , hydrogen-version >=1.2 - , network >=2.4.2.2 - , process ==1.2.* - , random ==1.0.* - , regex-base ==0.93.* - , regex-tdfa ==1.2.* - , strict ==0.3.* - , time ==1.4.* - , transformers ==0.3.* - , uuid ==1.3.* + build-depends: base >=4.5 && <5 + , array >=0.4 + , binary >=0.5.1 + , bytestring >=0.9.2.1 + , cereal >=0.4.1.1 + , containers >=0.4.2.1 + , directory >=1.1 + , filepath >=1.3 + , hashable >=1.1 + , hydrogen-multimap >=0.3 + , hydrogen-version >=1.4 + , network >=2.3 + , process >=1.1.0.1 + , random >=1.0.1.1 + , regex-base >=0.93.1 + , regex-tdfa >=1.2 + , strict >=0.3 + , text >=0.11.2 + , time >=1.4 + , transformers >=0.3 + , uuid >=1.3 + if impl(ghc <= 7.6) + build-depends: ghc-prim + , text <1.2.0.4 + if impl(ghc >= 7.6) + build-depends: binary >=0.7 + hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010 default-extensions: CPP , DeriveDataTypeable + , DeriveFoldable , DeriveFunctor , DeriveGeneric - , EmptyCase + , DeriveTraversable , FlexibleInstances , FlexibleContexts , GADTs - , LambdaCase - , MultiWayIf - , NegativeLiterals + , MultiParamTypeClasses , NoImplicitPrelude , PackageImports - , RankNTypes , RecordWildCards , ScopedTypeVariables , StandaloneDeriving - , TupleSections , TypeFamilies diff --git a/src/Hydrogen/Prelude.hs b/src/Hydrogen/Prelude.hs --- a/src/Hydrogen/Prelude.hs +++ b/src/Hydrogen/Prelude.hs @@ -24,9 +24,10 @@ , module Data.Maybe , module Data.Ord , module Data.Ratio - , module Data.Serialize , module Data.String , module Data.Time + , module Data.Time.Calendar.OrdinalDate + , module Data.Traversable , module Data.Tuple , module Data.Typeable , module Data.Word @@ -35,22 +36,52 @@ , module Text.Printf , (.&) , (.|) + , (.^) , (=~) , (=~~) , (|>) - , for + , ($$) + , ($$$) + , ($$$$) + , ($$$$$) + , (<$$>) + , (<$$$>) + , (<$$$$>) + , (<$$$$$>) , uuidFromString , randomUUID , safeHead + , safeHeadAndTail + , safeHeadAndTail2 + , firstJust + , uncurry3 + , uncurry4 + , uncurry5 + , map , UUID + , ByteString + , LazyByteString + , Serialize + , encode + , encodeLazy + , decode + , decodeLazy + , Binary + , binaryEncode + , binaryDecode + , binaryEncodeFile + , binaryDecodeFile , Generic , List , Map - , Set + , MultiMap , Seq + , Set , ShowBox , TMap (..) , Has (..) + , Container (..) + , Default (..) , __ ) where @@ -65,30 +96,44 @@ , foldl1 , foldr , foldr1 + , map + , mapM , mapM_ , maximum , minimum , notElem , or , product + , sequence , sequence_ , sum +#if MIN_VERSION_base(4,6,0) +#else + , catch +#endif ) import "base" Control.Applicative import "base" Control.Arrow import "base" Control.Monad hiding ( - forM_ + forM + , forM_ + , mapM , mapM_ , msum + , sequence , sequence_ ) import "array" Data.Array hiding ((!)) import qualified "array" Data.Array as Array +import "binary" Data.Binary (Binary) +import qualified "binary" Data.Binary as Binary import "base" Data.Bits hiding (bitSize) import "base" Data.Bool +import "bytestring" Data.ByteString (ByteString) +import qualified "bytestring" Data.ByteString.Lazy as LazyByteString import "base" Data.Char import "base" Data.Complex import "base" Data.Dynamic @@ -114,9 +159,12 @@ , foldl1 , foldr , foldr1 + , map + , mapAccumL + , mapAccumR , maximum - , minimum , maximumBy + , minimum , minimumBy , notElem , or @@ -126,14 +174,21 @@ import "base" Data.Maybe import "base" Data.Ord import "base" Data.Ratio -import "cereal" Data.Serialize +import "cereal" Data.Serialize (Serialize) +import qualified "cereal" Data.Serialize as Serialize import "base" Data.String import "time" Data.Time +import "time" Data.Time.Calendar.OrdinalDate +import "base" Data.Traversable import "base" Data.Tuple import "base" Data.Typeable import "base" Data.Word +#if MIN_VERSION_base(4,6,0) import "base" GHC.Generics (Generic) +#else +import "ghc-prim" GHC.Generics (Generic) +#endif import "base" Numeric @@ -143,10 +198,11 @@ import "containers" Data.Map (Map) import qualified "containers" Data.Map as Map import "containers" Data.Set (Set) --- import qualified "containers" Data.Set as Set +import qualified "containers" Data.Set as Set import "containers" Data.Sequence (Seq) --- import qualified "containers" Data.Sequence as Seq +import "hydrogen-multimap" Hydrogen.MultiMap (MultiMap) +import qualified "hydrogen-multimap" Hydrogen.MultiMap as MultiMap import "hydrogen-version" Hydrogen.Version import "uuid" Data.UUID (UUID) @@ -154,6 +210,18 @@ import qualified "uuid" Data.UUID import qualified "uuid" Data.UUID.V4 + +----------------------------------------------------------------------- +-- Lazy type aliases +----------------------------------------------------------------------- + +type LazyByteString = LazyByteString.ByteString + + +----------------------------------------------------------------------- +-- Generic instances +----------------------------------------------------------------------- + deriving instance Eq ZonedTime deriving instance Generic Day deriving instance Generic LocalTime @@ -162,59 +230,197 @@ deriving instance Generic UniversalTime deriving instance Generic ZonedTime + +----------------------------------------------------------------------- +-- Serialize & Binary instances +----------------------------------------------------------------------- + instance Serialize Day -instance Serialize LocalTime -instance Serialize TimeOfDay +instance Binary Day + instance Serialize TimeZone +instance Binary TimeZone + instance Serialize UniversalTime +instance Binary UniversalTime + instance Serialize Version +instance Binary Version + +#if MIN_VERSION_base(4,7,0) +instance Serialize LocalTime +instance Binary LocalTime + +instance Serialize TimeOfDay +instance Binary TimeOfDay + instance Serialize ZonedTime +instance Binary ZonedTime instance Serialize (Fixed E12) where - put (MkFixed int) = put int + put (MkFixed int) = Serialize.put int - get = MkFixed <$> get + get = MkFixed <$> Serialize.get +instance Binary (Fixed E12) where + put (MkFixed int) = Binary.put int + + get = MkFixed <$> Binary.get +#endif + instance Serialize UUID where - put uuid = do - let p = putWord32be - (w1, w2, w3, w4) = Data.UUID.toWords uuid - p w1 >> p w2 >> p w3 >> p w4 + put uuid = p w1 >> p w2 >> p w3 >> p w4 + where + p = Serialize.putWord32be + (w1, w2, w3, w4) = Data.UUID.toWords uuid - get = let g = getWord32be in liftM4 Data.UUID.fromWords g g g g - + get = liftM4 Data.UUID.fromWords g g g g + where + g = Serialize.getWord32be + +-- instance Binary UUID is already provided by UUID package + + +----------------------------------------------------------------------- +-- Data.Serialize +----------------------------------------------------------------------- + +encode :: Serialize a => a -> ByteString +-- ^ Encode a value using binary serialization to a strict ByteString. +encode = Serialize.encode + +encodeLazy :: Serialize a => a -> LazyByteString +-- ^ Encode a value using binary serialization to a lazy ByteString. +encodeLazy = Serialize.encodeLazy + +decode :: Serialize a => ByteString -> Either String a +-- ^ Decode a value from a strict ByteString, reconstructing the +-- original structure. +decode = Serialize.decode + +decodeLazy :: Serialize a => LazyByteString -> Either String a +-- ^ Decode a value from a lazy ByteString, reconstructing the +-- original structure. +decodeLazy = Serialize.decodeLazy + + +----------------------------------------------------------------------- +-- Data.Binary +----------------------------------------------------------------------- + +binaryEncode :: Binary a => a -> LazyByteString +-- ^ Encode a value using binary serialisation to a lazy ByteString. +binaryEncode = Binary.encode + +binaryDecode :: Binary a => LazyByteString -> a +-- ^ Decode a value from a lazy ByteString, reconstructing the +-- original structure. +binaryDecode = Binary.decode + +binaryEncodeFile :: Binary a => FilePath -> a -> IO () +-- ^ Lazily serialise a value to a file. +binaryEncodeFile = Binary.encodeFile + +binaryDecodeFile :: Binary a => FilePath -> IO a +-- ^ Decode a value from a file. In case of errors, error will be +-- called with the error message. +binaryDecodeFile = Binary.decodeFile + + +----------------------------------------------------------------------- +-- ShowBox +----------------------------------------------------------------------- + data ShowBox where ShowBox :: forall a. (Show a) => a -> ShowBox instance Show ShowBox where show (ShowBox a) = show a -(.|), (.&) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) + +----------------------------------------------------------------------- +-- Composition of boolean functions +----------------------------------------------------------------------- + +(.|), (.&), (.^) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) f .| g = \x -> f x || g x f .& g = \x -> f x && g x +f .^ g = \x -> f x /= g x + +----------------------------------------------------------------------- +-- Nice shorthands & operators +----------------------------------------------------------------------- + (|>) :: a -> (a -> b) -> b +-- ^ @flip ('$')@ (|>) = flip ($) -for :: Functor f => f a -> (a -> b) -> f b -for = flip fmap - __ :: a +-- ^ A shorthand for 'undefined'. __ = error "Hydrogen.Prelude.undefined" + +----------------------------------------------------------------------- +-- UUID functions +----------------------------------------------------------------------- + uuidFromString :: String -> Maybe UUID uuidFromString = Data.UUID.fromString randomUUID :: IO UUID +-- ^ Produces a random V4 UUID (alias for 'Data.UUID.V4.nextRandom'). randomUUID = Data.UUID.V4.nextRandom -safeHead :: a -> [a] -> a -safeHead d = \case + +----------------------------------------------------------------------- +-- Safe functions +----------------------------------------------------------------------- + +safeHead + :: a -- ^ The default value for the case of the empty list. + -> [a] -- ^ The list. + -> a +-- ^ Returns the head of the list or the default value. +safeHead default_ = \z -> case z of x : _ -> x - _ -> d + _ -> default_ +safeHeadAndTail :: a -> [a] -> (a, [a]) +safeHeadAndTail default_ = \z -> case z of + x : xs -> (x, xs) + _ -> (default_, []) +safeHeadAndTail2 :: a -> a -> [a] -> (a, a, [a]) +safeHeadAndTail2 d1 d2 = \z -> case z of + x : y : xs -> (x, y, xs) + x : xs -> (x, d2, xs) + xs -> (d1, d2, xs) + + +----------------------------------------------------------------------- +-- firstJust +----------------------------------------------------------------------- + +firstJust :: [a -> Maybe b] -> a -> Maybe b +-- ^ Applies a bunch of functions on a given value, +-- returns the first result that is not Nothing +-- (or 'Nothing' if no 'Just' value was produced). +firstJust (f : fs) v = case f v of + Nothing -> firstJust fs v + x -> x +firstJust [] _ = Nothing + + +----------------------------------------------------------------------- +-- More generic maps +----------------------------------------------------------------------- + +map :: Functor f => (a -> b) -> f a -> f b +-- ^ map as it should be: 'fmap'. +map = fmap + class TMap a where type Component x @@ -249,15 +455,22 @@ type Component [a] = a type Transform ((a -> b) -> [a]) = [b] - tmap = map + tmap = fmap instance TMap (Map k v) where type Component (Map k v) = v type Transform ((v -> w) -> Map k v) = Map k w - tmap = Map.map + tmap = fmap +instance TMap (MultiMap k v) where + + type Component (MultiMap k v) = v + type Transform ((v -> w) -> MultiMap k v) = MultiMap k w + + tmap = fmap + instance TMap (Seq a) where type Component (Seq a) = a @@ -266,27 +479,36 @@ tmap = fmap +----------------------------------------------------------------------- +-- Verbose `List' type +----------------------------------------------------------------------- + type List a = [a] + +----------------------------------------------------------------------- +-- Has +----------------------------------------------------------------------- + class Has a where - type K a - type V a + type HasKey a + type HasValue a - (!) :: a -> K a -> V a + (!) :: a -> HasKey a -> HasValue a instance Ord k => Has (Map k v) where - type K (Map k v) = k - type V (Map k v) = v + type HasKey (Map k v) = k + type HasValue (Map k v) = v (!) = (Map.!) instance Eq k => Has [(k, v)] where - type K [(k, v)] = k - type V [(k, v)] = v + type HasKey [(k, v)] = k + type HasValue [(k, v)] = v list ! key = maybeKey (lookup key list) where @@ -294,9 +516,124 @@ instance Ix i => Has (Array i e) where - type K (Array i e) = i - type V (Array i e) = e + type HasKey (Array i e) = i + type HasValue (Array i e) = e (!) = (Array.!) +instance Ord k => Has (MultiMap k v) where + + type HasKey (MultiMap k v) = k + type HasValue (MultiMap k v) = [v] + + (!) = flip MultiMap.lookup + + +----------------------------------------------------------------------- +-- Container +----------------------------------------------------------------------- + +class Container a where + + type Contained a + + (?) :: a -> Contained a -> Bool + + +instance Ord a => Container (Set a) where + + type Contained (Set a) = a + + (?) = flip Set.member + +instance Eq a => Container [a] where + + type Contained [a] = a + + (?) = flip elem + +instance Eq a => Container (Seq a) where + + type Contained (Seq a) = a + + c ? e = any (== e) c + +instance Ord k => Container (Map k v) where + + type Contained (Map k v) = k + + (?) = flip Map.member + +instance Ord k => Container (MultiMap k v) where + + type Contained (MultiMap k v) = k + + (?) = flip MultiMap.member + + +----------------------------------------------------------------------- +-- Default +----------------------------------------------------------------------- + +class Default a where + + def :: a + +instance Default Int where def = 0 +instance Default Int8 where def = 0 +instance Default Int16 where def = 0 +instance Default Int32 where def = 0 +instance Default Int64 where def = 0 +instance Default Word8 where def = 0 +instance Default Word16 where def = 0 +instance Default Word32 where def = 0 +instance Default Word64 where def = 0 +instance Default Integer where def = 0 + +instance Default Bool where def = False +instance Default [a] where def = [] +instance Default (Maybe a) where def = Nothing + + +----------------------------------------------------------------------- +-- Apply / curry operators +----------------------------------------------------------------------- + +infixr 0 $$ +infixr 0 $$$ +infixr 0 $$$$ +infixr 0 $$$$$ + +($$) :: (a -> b -> z) -> (a, b) -> z +($$) = uncurry + +($$$), uncurry3 :: (a -> b -> c -> z) -> (a, b, c) -> z +uncurry3 f (a, b, c) = f a b c +($$$) = uncurry3 + +($$$$), uncurry4 :: (a -> b -> c -> d -> z) -> (a, b, c, d) -> z +uncurry4 f (a, b, c, d) = f a b c d +($$$$) = uncurry4 + +($$$$$), uncurry5 :: (a -> b -> c -> d -> e -> z) -> (a, b, c, d, e) -> z +uncurry5 f (a, b, c, d, e) = f a b c d e +($$$$$) = uncurry5 + + +infixl 4 <$$> +infixl 4 <$$$> +infixl 4 <$$$$> +infixl 4 <$$$$$> + +(<$$>) :: Functor f => (a -> b -> z) -> f (a, b) -> f z +(<$$>) = (<$>) . uncurry + +(<$$$>) :: Functor f => (a -> b -> c -> z) -> f (a, b, c) -> f z +(<$$$>) = (<$>) . uncurry3 + +(<$$$$>) :: Functor f => (a -> b -> c -> d -> z) -> f (a, b, c, d) -> f z +(<$$$$>) = (<$>) . uncurry4 + +(<$$$$$>) :: Functor f => (a -> b -> c -> d -> e -> z) -> f (a, b, c, d, e) -> f z +(<$$$$$>) = (<$>) . uncurry5 diff --git a/src/Hydrogen/Prelude/IO.hs b/src/Hydrogen/Prelude/IO.hs --- a/src/Hydrogen/Prelude/IO.hs +++ b/src/Hydrogen/Prelude/IO.hs @@ -2,7 +2,6 @@ module Hydrogen.Prelude , module Control.Concurrent , module Control.Exception - , module Control.Monad , module Data.IORef , module System.IO , module System.Timeout @@ -18,12 +17,6 @@ import "base" Control.Concurrent import "base" Control.Exception -import "base" Control.Monad hiding ( - forM_ - , mapM_ - , msum - , sequence_ - ) import "base" System.IO import "base" System.Timeout diff --git a/src/Hydrogen/Prelude/System.hs b/src/Hydrogen/Prelude/System.hs --- a/src/Hydrogen/Prelude/System.hs +++ b/src/Hydrogen/Prelude/System.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + module Hydrogen.Prelude.System ( module Hydrogen.Prelude.IO , module System.CPUTime @@ -8,6 +10,10 @@ , module System.Info , module System.Process , module System.Random + , findFilesRecursively + , findFilesRecursivelyWithContext + , escapeFileName + , unescapeFileName ) where import Hydrogen.Prelude.IO @@ -20,4 +26,78 @@ import "base" System.Info import "process" System.Process import "random" System.Random + +import qualified Data.Set as Set + + +findFilesRecursively :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath] +findFilesRecursively f dir = + map fst <$> findFilesRecursivelyWithContext (\c _ _ -> return c) f () dir + + +findFilesRecursivelyWithContext + :: forall c. + (c -> FilePath -> [FilePath] -> IO c) -- ^ update function for current context + -> (FilePath -> IO Bool) -- ^ predicate to filter files + -> c -- ^ current context + -> FilePath -> IO [(FilePath, c)] +findFilesRecursivelyWithContext updater predicate context dir = do + + cwd <- getCurrentDirectory + snd <$> find Set.empty context (cwd dir) + + where + + find :: Set FilePath -> c -> FilePath -> IO (Set FilePath, [(FilePath, c)]) + find visited context dir = canonicalizePath dir >>= find' + where + find' thisDirectory + | Set.member thisDirectory visited = return (Set.empty, []) + | otherwise = do + + allFiles <- map (dir ) <$> getDirectoryContents dir + theFiles <- filterFiles allFiles + theDirs <- filterM isDir allFiles + context' <- updater context dir theFiles + + let visited' = Set.insert thisDirectory visited + f (visited, files) dir = do + (visited', files') <- find visited context' dir + return (visited', files' : files) + + (visited'', files') <- foldM f (visited', []) theDirs + + return (visited'', concat (zip theFiles (repeat context') : files')) + + filterFiles = filterM (\x -> liftM2 (&&) (doesFileExist x) (predicate x)) + isDir x = liftM2 (&&) (doesDirectoryExist x) (return (head (takeFileName x) /= '.')) + + +escapeFileName :: String -> String +escapeFileName s = case s of + ('/' : xs) + -> '_' : escapeFileName xs + (x : xs) + | isSafeChar x -> x : escapeFileName xs + | ord x <= 255 -> '$' : printf "%02X" (ord x) ++ escapeFileName xs + | otherwise -> "$$" ++ printf "%04X" (ord x) ++ escapeFileName xs + [] -> [] + where + isSafeChar x = isAscii x && isAlphaNum x || x `elem` ".-" + + +unescapeFileName :: String -> Maybe String +unescapeFileName s = case s of + ('$' : '$' : a : b : c : d : xs) + -> (chr <$> hexnum (a : b : c : [d])) `cons` unescapeFileName xs + ('$' : a : b : xs) + -> (chr <$> hexnum (a : [b])) `cons` unescapeFileName xs + ('_' : xs) + -> pure '/' `cons` unescapeFileName xs + (x : xs) + -> pure x `cons` unescapeFileName xs + [] -> return [] + where + cons = liftA2 (:) + hexnum = fmap fst . listToMaybe . readHex