]> Git — Sourcephile - julm/worksheets.git/blob - src/Prelude.hs
add: Rosetta
[julm/worksheets.git] / src / Prelude.hs
1 {-# LANGUAGE FieldSelectors #-}
2 {-# LANGUAGE PackageImports #-}
3 {-# LANGUAGE UndecidableInstances #-}
4 {-# LANGUAGE NoMonomorphismRestriction #-}
5 {-# OPTIONS_GHC -Wno-orphans #-}
6
7 module Prelude (
8 traceString,
9 traceShow,
10 traceShowId,
11 traceShowM,
12 IsList (..),
13 pattern (:=),
14 forMap,
15 setSingle,
16 setInsert,
17 setSize,
18 mapSize,
19 mapLookup,
20 DropPrefix (..),
21 ($),
22 (<$>),
23 ($>),
24 (<&>),
25 (.),
26 (&),
27 (&&),
28 (||),
29 (>>>),
30 (++),
31 id,
32 const,
33 on,
34 fold,
35 foldr,
36 foldMap,
37 foldMapM,
38 Foldable,
39 forM,
40 forM_,
41 null,
42 any,
43 all,
44 or,
45 and,
46 not,
47 flip,
48 first,
49 second,
50 void,
51 Bool (..),
52 otherwise,
53 Enum (..),
54 Eq (..),
55 Ord (..),
56 Show (..),
57 Either (..),
58 either,
59 Generic,
60 IsString,
61 fromString,
62 fromRational,
63 HasCallStack,
64 IO,
65 FilePath,
66 Char,
67 -- Hashable (..),
68 ShortText,
69 Set,
70 String,
71 Natural,
72 Int,
73 Integer,
74 Map,
75 Maybe (..),
76 fromMaybe,
77 maybe,
78 maybeToList,
79 isJust,
80 isNothing,
81 Functor (..),
82 Down (..),
83 Sum (..),
84 Identity (..),
85 Applicative (..),
86 Semigroup (..),
87 Monoid (..),
88 Monad (..),
89 unless,
90 when,
91 Symbol,
92 KnownSymbol (..),
93 KnownNat (..),
94 Real (..),
95 Num (..),
96 natVal,
97 symbolVal,
98 pShow,
99 pShowNoColor,
100 IsLabel (..),
101 Proxy (..),
102 Last (..),
103 -- Surgery,
104 -- Surgeries,
105 -- ProductSurgery,
106 -- ProductSurgeries,
107 -- Surgery' (..),
108 -- Generically (..),
109 -- GenericProduct (..),
110 -- Derecordify,
111 -- OnField,
112 -- OnFields,
113 -- CopyRep,
114 -- type (%~),
115 Typeable,
116 fst,
117 snd,
118 maximum,
119 minimum,
120 Max (..),
121 Min (..),
122 ) where
123
124 import Control.Applicative (Applicative (..))
125 import Control.Arrow (first, second, (>>>))
126 import Control.Monad (Monad (..), forM, forM_, unless, void, when)
127 import Data.Bool (Bool (..), not, otherwise, (&&), (||))
128 import Data.Char (Char)
129 import Data.Either (Either (..), either)
130 import Data.Eq (Eq (..))
131 import Data.Foldable (Foldable, all, and, any, fold, foldMap, foldr, maximum, minimum, null, or)
132 import Data.Function (const, flip, id, on, ($), (&), (.))
133 import Data.Functor (Functor (..), ($>), (<$), (<$>), (<&>))
134 import Data.Functor.Identity (Identity (..))
135 import Data.List ((++))
136 import Data.Map.Strict (Map)
137 import Data.Map.Strict qualified as Map
138 import Data.Maybe (Maybe (..), fromMaybe, isJust, isNothing, maybe, maybeToList)
139 import Data.Monoid (Ap (..), Last (..), Monoid (..))
140 import Data.Ord (Down (..), Ord (..))
141 import Data.Proxy (Proxy (..))
142 import Data.Semigroup (Max (..), Min (..), Semigroup (..), Sum (..))
143 import Data.Set (Set)
144 import Data.Set qualified as Set
145 import Data.String (IsString, String, fromString)
146 import Data.Text qualified as Text
147 import Data.Text.Short (ShortText)
148 import Data.Text.Short qualified as ShortText
149 import Data.Tuple (fst, snd)
150 import Debug.Pretty.Simple (pTrace, pTraceShow, pTraceShowId, pTraceShowM)
151 import GHC.Generics (Generic)
152 import GHC.IsList (IsList (..), toList)
153 import GHC.OverloadedLabels (IsLabel (..))
154 import GHC.Stack (HasCallStack)
155 import GHC.TypeLits (KnownNat (..), KnownSymbol (..), Symbol, natVal, symbolVal)
156 import System.IO (FilePath, IO)
157
158 -- import Generic.Data.Microsurgery (
159 -- CopyRep,
160 -- Derecordify,
161 -- GenericProduct (..),
162 -- Generically (..),
163 -- OnField,
164 -- OnFields,
165 -- ProductSurgeries,
166 -- ProductSurgery,
167 -- Surgeries,
168 -- Surgery,
169 -- Surgery' (..),
170 -- type (%~),
171 -- )
172 import Numeric.Natural (Natural)
173
174 -- import Optics.Core
175 import Text.Pretty.Simple (pShow, pShowNoColor)
176 import Text.Show (Show (..))
177 import Type.Reflection (Typeable)
178 import "base" Prelude (Enum (..), Int, Integer, Num (..), Real (..), fromRational)
179
180 traceString = pTrace
181 traceShow = pTraceShow
182 traceShowId = pTraceShowId
183 traceShowM = pTraceShowM
184
185 pattern (:=) :: a -> b -> (a, b)
186 pattern (:=) x y = (x, y)
187 infixr 0 :=
188
189 class Assoc a b c where
190 (~>) :: a -> b -> c
191 instance Assoc a b (a, b) where
192 (~>) = (,)
193
194 (<&) :: Functor f => a -> f b -> f a
195 (&>) :: Functor f => f b -> a -> f a
196 (<&) = flip ($>)
197 (&>) = flip (<$)
198 infixl 4 <&
199 infixl 4 &>
200
201 -- l <>~ n = over l (<> n)
202 -- {-# INLINE (<>~) #-}
203
204 instance IsList a => IsList (Last a) where
205 type Item (Last a) = Item a
206 fromList [] = Last Nothing
207 fromList xs = Last (Just (fromList xs))
208 toList (Last Nothing) = []
209 toList (Last (Just x)) = toList x
210
211 -- | Like `Last` but `mempty` is `[]` instead not `Nothing`.
212 -- Useful for deriving:
213 --
214 -- @
215 -- deriving Semigroup via (ProductSurgery (OnFields Lasts) Foo)
216 -- @
217 newtype Lasts a = Lasts a
218 deriving (Eq, Ord, Show, Generic)
219
220 instance Semigroup (Lasts [a]) where
221 Lasts [] <> x = x
222 x <> Lasts [] = x
223 _x <> y = y
224 instance (Monoid a, Semigroup (Lasts a)) => Monoid (Lasts a) where
225 mempty = Lasts mempty
226
227 newtype Newest a = Newest {unNewest :: a}
228 deriving (Eq, Ord, Generic)
229 deriving newtype (Show)
230 instance Semigroup (Newest a) where
231 _x <> y = y
232
233 newtype MapUnion k a = MapUnion {unMapUnion :: Map.Map k a}
234 deriving (Eq, Ord, Generic, Functor)
235 deriving newtype (Show)
236
237 -- CorrectionWarning: `Monoid` is not derived correctly via `Generically`,
238 -- it does not reuses `(<>)`.
239 -- See https://github.com/haskell/core-libraries-committee/issues/324
240 -- deriving (Monoid) via (Generically (MapUnion k a))
241 instance (Ord k, Semigroup a) => Semigroup (MapUnion k a) where
242 MapUnion x <> MapUnion y = MapUnion (Map.unionWith (<>) x y)
243 instance (Ord k, Semigroup a) => Monoid (MapUnion k a) where
244 mempty = MapUnion mempty
245
246 forMap :: (Foldable t, Monoid m) => t a -> (a -> m) -> m
247 forMap = flip foldMap
248
249 class DropPrefix a where
250 dropPrefix :: a -> a -> a
251 instance DropPrefix Text.Text where
252 dropPrefix p t = t & Text.stripPrefix p & fromMaybe t
253 instance DropPrefix ShortText where
254 dropPrefix p t = t & ShortText.stripPrefix p & fromMaybe t
255
256 setSingle = Set.singleton
257 {-# INLINE setSingle #-}
258 setInsert = Set.insert
259 {-# INLINE setInsert #-}
260 setSize = Set.size
261 {-# INLINE setSize #-}
262 mapSize = Map.size
263 {-# INLINE mapSize #-}
264 mapLookup = Map.lookup
265 {-# INLINE mapLookup #-}
266
267 foldMapM :: (Applicative m, Foldable t, Monoid b) => (a -> m b) -> t a -> m b
268 foldMapM f = getAp <$> foldMap (Ap . f)