rfc-prelude (empty) → 0.0.0.1
raw patch · 12 files changed
+1199/−0 lines, 12 filesdep +aesondep +basedep +bifunctors
Dependencies added: aeson, base, bifunctors, bytestring, classy-prelude, containers, data-default, http-api-data, integer-logarithms, lens, monad-control, network-uri, text, text-conversions, time, time-units, transformers, tuple, unliftio, unliftio-core, uuid-types
Files
- LICENSE +7/−0
- README.md +6/−0
- package.common.yaml +103/−0
- package.yaml +37/−0
- rfc-prelude.cabal +78/−0
- src/RFC/Data/IdAnd.hs +316/−0
- src/RFC/Data/UUID.hs +77/−0
- src/RFC/Prelude.hs +181/−0
- src/RFC/Prelude/Concurrent.hs +50/−0
- src/RFC/Prelude/Instances.hs +84/−0
- src/RFC/Prelude/JSON.hs +106/−0
- src/RFC/Prelude/String.hs +154/−0
+ LICENSE view
@@ -0,0 +1,7 @@+Copyright Robert Fischer (c) 2018++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.
+ README.md view
@@ -0,0 +1,6 @@+RFC Prelude+================++This is a replacement for the default `Prelude` based off of [`Classy Prelude`](https://hackage.haskell.org/package/classy-prelude),+but with even more common functionality.+
+ package.common.yaml view
@@ -0,0 +1,103 @@+- &defaults+ author: Robert Fischer+ maintainer: smokejumperit+rfc@gmail.com+ license: MIT+ license-file: LICENSE++ flags:+ production:+ description: If true, disables failing on warnings and enables aggressive optimizations.+ manual: true+ default: false++ library:+ source-dirs:+ - './src'++ extra-source-files:+ - LICENSE+ - README.md+ - package.yaml+ - package.common.yaml++ default-extensions:+ - ApplicativeDo+ - BangPatterns+ - ConstraintKinds+ - DataKinds+ - DefaultSignatures+ - DeriveFoldable+ - DeriveFunctor+ - DeriveGeneric+ - DeriveLift+ - DeriveTraversable+ - ExistentialQuantification+ - FlexibleContexts+ - FlexibleInstances+ - FunctionalDependencies+ - GADTs+ - GeneralizedNewtypeDeriving+ - InstanceSigs+ - KindSignatures+ - LambdaCase+ - MultiParamTypeClasses+ - MultiWayIf+ - NamedFieldPuns+ - PatternSynonyms+ - RankNTypes+ - ScopedTypeVariables+ - StandaloneDeriving+ - TupleSections+ - TypeApplications+ - TypeFamilies+ - TypeFamilyDependencies+ - TypeOperators + - RebindableSyntax+ - MonadFailDesugaring+ - DisambiguateRecordFields++ ghc-options: + - -Wall+ - -Wcompat + - -Wincomplete-record-updates + - -Wincomplete-uni-patterns + - -Wredundant-constraints + - -fno-max-relevant-binds + - -fprint-potential-instances + - -fprint-explicit-foralls+ - -Wno-missing-monadfail-instances+ - -fno-warn-name-shadowing + - -fno-warn-tabs + - -fno-warn-orphans+ - -Wnoncanonical-monad-instances + - -Wall-missed-specialisations+ - -Wnoncanonical-monadfail-instances + - -Wimplicit-prelude + - -Wmissing-exported-signatures + - -Widentities+ - -j++ when:+ - condition: flag(production)+ then:+ ghc-options:+ - -feager-blackholing + - -funbox-strict-fields + - -fstatic-argument-transformation+ - -flate-dmd-anal + - -fexpose-all-unfoldings + - -fspecialise-aggressively + - -fexcess-precision + - -fmax-simplifier-iterations=15+ - -fsimplifier-phases=4+ - -fstrictness-before=3+ - -funfolding-keeness-factor=1.5+ - -funfolding-use-threshold=150+ else:+ cpp-options:+ - -DDEVELOPMENT+ ghc-options:+ - -freverse-errors+ - -Werror + - -dcore-lint + - -dcmm-lint
+ package.yaml view
@@ -0,0 +1,37 @@+name: rfc-prelude+version: 0.0.0.1+synopsis: The Prelude from the Robert Fischer Commons.+description: >+ A Prelude deriving from @Classy-Prelude@ which provides additional useful bits of + functionality and convenient names.+category: prelude+github: RobertFischer/rfc/rfc-prelude+license: MIT+license-file: LICENSE++_common: !include package.common.yaml++<<: *defaults++dependencies:+ - aeson >= 1.4+ - base >= 4.10 && < 5+ - bifunctors >= 5.5+ - bytestring >= 0.10+ - classy-prelude >= 1.4+ - containers >= 0.5+ - data-default >= 0.7+ - http-api-data >= 0.3+ - integer-logarithms >= 1.0+ - lens >= 4.16 + - monad-control >= 1.0+ - network-uri >= 2.6+ - text >= 1.2+ - text-conversions >= 0.3+ - time >= 1.8+ - time-units >= 1.0+ - transformers >= 0.5+ - tuple >= 0.3+ - unliftio >= 0.2+ - unliftio-core >= 0.1+ - uuid-types >= 1.0
+ rfc-prelude.cabal view
@@ -0,0 +1,78 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 15bad05c0ba7f3c13be13ecef62a6614d6acdfeee1978c4e17e252a250e36f00++name: rfc-prelude+version: 0.0.0.1+synopsis: The Prelude from the Robert Fischer Commons.+description: A Prelude deriving from @Classy-Prelude@ which provides additional useful bits of functionality and convenient names.+category: prelude+homepage: https://github.com/RobertFischer/rfc#readme+bug-reports: https://github.com/RobertFischer/rfc/issues+author: Robert Fischer+maintainer: smokejumperit+rfc@gmail.com+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ LICENSE+ package.common.yaml+ package.yaml+ README.md++source-repository head+ type: git+ location: https://github.com/RobertFischer/rfc+ subdir: rfc-prelude++flag production+ description: If true, disables failing on warnings and enables aggressive optimizations.+ manual: True+ default: False++library+ exposed-modules:+ RFC.Data.IdAnd+ RFC.Data.UUID+ RFC.Prelude+ RFC.Prelude.Concurrent+ RFC.Prelude.Instances+ RFC.Prelude.JSON+ RFC.Prelude.String+ other-modules:+ Paths_rfc_prelude+ hs-source-dirs:+ ./src+ default-extensions: ApplicativeDo BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns PatternSynonyms RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators RebindableSyntax MonadFailDesugaring DisambiguateRecordFields+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-max-relevant-binds -fprint-potential-instances -fprint-explicit-foralls -Wno-missing-monadfail-instances -fno-warn-name-shadowing -fno-warn-tabs -fno-warn-orphans -Wnoncanonical-monad-instances -Wall-missed-specialisations -Wnoncanonical-monadfail-instances -Wimplicit-prelude -Wmissing-exported-signatures -Widentities -j+ build-depends:+ aeson >=1.4+ , base >=4.10 && <5+ , bifunctors >=5.5+ , bytestring >=0.10+ , classy-prelude >=1.4+ , containers >=0.5+ , data-default >=0.7+ , http-api-data >=0.3+ , integer-logarithms >=1.0+ , lens >=4.16+ , monad-control >=1.0+ , network-uri >=2.6+ , text >=1.2+ , text-conversions >=0.3+ , time >=1.8+ , time-units >=1.0+ , transformers >=0.5+ , tuple >=0.3+ , unliftio >=0.2+ , unliftio-core >=0.1+ , uuid-types >=1.0+ if flag(production)+ ghc-options: -feager-blackholing -funbox-strict-fields -fstatic-argument-transformation -flate-dmd-anal -fexpose-all-unfoldings -fspecialise-aggressively -fexcess-precision -fmax-simplifier-iterations=15 -fsimplifier-phases=4 -fstrictness-before=3 -funfolding-keeness-factor=1.5 -funfolding-use-threshold=150+ else+ ghc-options: -freverse-errors -Werror -dcore-lint -dcmm-lint+ cpp-options: -DDEVELOPMENT+ default-language: Haskell2010
+ src/RFC/Data/IdAnd.hs view
@@ -0,0 +1,316 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+++module RFC.Data.IdAnd+ ( idAndsToMap+ , IdAnd(..)+ , idAndToId+ , idAndToValue+ , valuesToIdAnd+ , idAndToTuple+ , tupleToIdAnd+ , idAndToPair+ , RefMap+ , refMapElems+ , refMapToMap+ , refMapIds+ , toRefMap+ , emptyRefMap+ , refMapUUIDs+ , refMapProxy+ , idProxy+ ) where++import RFC.Prelude+++import Data.Aeson as JSON+import qualified Data.Map as Map+import Data.Proxy ( Proxy (..) )++#ifdef VERSION_aeson+#if MIN_VERSION_aeson(1,0,0)+ -- Don't need the backflips for maps+#else+import Data.Aeson.Types ( Parser, typeMismatch )+import qualified Data.HashMap.Lazy as HashMap+import qualified Data.UUID.Types as UUID+#endif+#endif++-- TODO Make this check more precise+#ifdef VERSION_servant_doc+import qualified Data.List as List+import qualified Data.UUID.Types as UUID+import Servant.Docs+#endif+#ifdef VERSION_swagger2+import Control.Lens hiding ( (.=) )+import Data.Swagger+#endif++newtype Id a = Id { idToUUID :: UUID }+ deriving (Eq, Ord, Show, Generic, Typeable)++-- |Represents something which has an ID.+newtype IdAnd a = IdAnd (Id a, a)+ deriving (Eq, Ord, Show, Generic, Typeable)++type RefMap a = Map.Map (Id a) (IdAnd a)++idProxy :: Id a -> Proxy a+idProxy _ = Proxy+{-# INLINE idProxy #-}++refMapProxy :: RefMap a -> Proxy a+refMapProxy _ = Proxy+{-# INLINE refMapProxy #-}++emptyRefMap :: RefMap a+emptyRefMap = Map.empty+{-# INLINE emptyRefMap #-}++refMapElems :: RefMap a -> [IdAnd a]+refMapElems = Map.elems+{-# INLINE refMapElems #-}++refMapUUIDs :: RefMap a -> [UUID]+refMapUUIDs = fmap idToUUID . refMapIds+{-# INLINE refMapUUIDs #-}++refMapIds :: RefMap a -> [Id a]+refMapIds = Map.keys+{-# INLINE refMapIds #-}++refMapToMap :: RefMap a -> Map.Map UUID (IdAnd a)+refMapToMap = Map.mapKeys idToUUID+{-# INLINE refMapToMap #-}++toRefMap :: [IdAnd a] -> RefMap a+toRefMap = Map.fromList . fmap (\idAnd@(IdAnd(id,_)) -> (id,idAnd))+{-# INLINEABLE toRefMap #-}++idAndToValue :: IdAnd a -> a+idAndToValue (IdAnd(_,a)) = a+{-# INLINE idAndToValue #-}++idAndToId :: IdAnd a -> Id a+idAndToId (IdAnd(id,_)) = id+{-# INLINE idAndToId #-}++tupleToIdAnd :: (UUID, a) -> IdAnd a+tupleToIdAnd (id,a) = IdAnd (Id id, a)+{-# INLINE tupleToIdAnd #-}++valuesToIdAnd :: UUID -> a -> IdAnd a+valuesToIdAnd id a = IdAnd(Id id,a)+{-# INLINE valuesToIdAnd #-}++idAndToTuple :: IdAnd a -> (UUID, a)+idAndToTuple (IdAnd (Id id,val)) = (id,val)+{-# INLINE idAndToTuple #-}++idAndToPair :: IdAnd a -> (Id a, IdAnd a)+idAndToPair idAnd@(IdAnd (id,_)) = (id, idAnd)+{-# INLINE idAndToPair #-}++idAndsToMap :: [IdAnd a] -> RefMap a+idAndsToMap list = Map.fromList $ idAndToPair <$> list+{-# INLINEABLE idAndsToMap #-}++instance (FromJSON a) => FromJSON (IdAnd a) where+ parseJSON = JSON.withObject "IdAnd" $ \o -> do+ id <- o .: "id"+ value <- o .: "value"+ return $ IdAnd(Id id, value)+ {-# INLINEABLE parseJSON #-}++instance (ToJSON a) => ToJSON (IdAnd a) where+ toJSON (IdAnd (Id id,value)) = object [ "id".=id, "value".=value ]+ {-# INLINEABLE toJSON #-}++instance (FromJSON a) => FromJSON (Id a) where+ parseJSON = fmap Id . parseJSON+ {-# INLINE parseJSON #-}++instance (ToJSON a) => ToJSON (Id a) where+ toJSON (Id a) = toJSON a+ {-# INLINE toJSON #-}++#ifdef VERSION_aeson+#if MIN_VERSION_aeson(1,0,0)+ -- Have Mpa instances automatically created+#else+instance (FromJSON a) => FromJSON (Map UUID (IdAnd a)) where+ parseJSON (Object obj) =+ Map.fromList <$> listInParser+ where+ objList :: [(Text, Value)]+ objList = HashMap.toList obj+ die :: Text -> Parser UUID+ die k = fail . cs $ "Could not parse UUID: " <> k+ mapMKey :: Text -> Parser UUID+ mapMKey k = maybe (die k) return $ UUID.fromText k+ mapMVal :: Value -> Parser (IdAnd a)+ mapMVal = parseJSON+ mapPair :: (Text,Value) -> Parser (UUID, IdAnd a)+ mapPair = bimapM mapMKey mapMVal+ parserList :: [Parser (UUID, IdAnd a)]+ parserList = mapPair <$> objList+ listInParser :: Parser [(UUID, IdAnd a)]+ listInParser = sequence parserList++ parseJSON invalid = typeMismatch "Map UUID (IdAnd a)" invalid+++instance (ToJSON a) => ToJSON (Map UUID (IdAnd a)) where+ toJSON =+ Object . HashMap.fromList . fmap (\(k,v) -> (UUID.toText k, toJSON v)) . Map.toList++#endif+#endif++#ifdef VERSION_swagger2+instance (ToSchema a, ToJSON a, ToSample a) => ToSchema (IdAnd a) where+ declareNamedSchema _ = do+ NamedSchema{..} <- declareNamedSchema (Proxy :: Proxy a)+ let aMaybeName = _namedSchemaName+ aSchema <- declareSchemaRef (Proxy :: Proxy a)+ idSchema <- declareSchemaRef (Proxy :: Proxy UUID)+ let maybeSample = safeHead $ toSamples (Proxy :: Proxy (IdAnd a))+ return . NamedSchema (fmap (\name -> "IdAnd " <> name) aMaybeName) $+ mempty+ & type_ .~ SwaggerObject+ & properties .~ [("id", idSchema), ("value", aSchema)]+ & required .~ ["id", "value"]+ & example .~ (toJSON . snd <$> maybeSample)+#endif++#ifdef VERSION_servant_doc+uuidList :: [UUID]+uuidList = List.cycle $ fromMaybe UUID.nil . UUID.fromString <$>+ [ "4fc2ffac-9100-41d6-94e1-c33a545e9ba2"+ , "1046948e-f8c7-4985-a008-fec4938696f4"+ , "83162802-598f-4de3-bd35-6c3fc0433965"+ , "1f628272-cfd8-4d43-ab00-ace5085164cc"+ , "64de6be2-4ca7-4ab7-ba3b-42d5dd0b79e7"+ , "20799832-f67d-4fd7-9435-58f3452f680d"+ , "a65c9782-863f-47cb-a2d4-438b8ade9e14"+ , "6e76c9a0-31f2-4bc7-a7b4-a2bb4a4dc03f"+ , "cc8b25ad-b596-4922-801a-2daeab69fbbf"+ , "59f44f8b-16e2-4839-b455-a1df01c704a5"+ , "7d8423c2-60a5-480f-b8b4-732b832bc80f"+ , "4b9f6e8c-c6c7-47f8-b1b6-13c987c17396"+ , "ae80805a-93bd-4f03-9c1e-d1ef0225b914"+ , "21ec1b66-97b7-47d4-9f08-2bb32ebf8a6f"+ , "799cdc04-aa86-45f9-91ae-24a7b9ea5302"+ , "babde8aa-055f-4936-b693-a32659f7ca63"+ , "99bde639-8ae1-40f5-a447-13531530f06e"+ , "67e7b91c-561f-4307-ae79-f5d7cc37fbe4"+ , "4a158750-2074-4056-9314-77d082f567d2"+ , "acc114a2-3307-4b52-80fb-36db3878b487"+ , "ec2a6366-b693-4b30-a888-de4a7e577c95"+ , "01ee4efb-6ffc-412d-aedc-c0a49a606918"+ , "25c8288d-68c1-4b5b-98a3-8af6932db9dc"+ , "7bc8dd7d-95e7-4bb1-bae9-fe2fb9e60ec9"+ , "9e6614a2-dc4f-4f97-9531-bfdbbdf70f15"+ , "fd0e77a8-fcdd-4c52-8b41-31fb4b137a46"+ , "b0395674-5b36-4ea7-98c3-a65c879cb580"+ , "0a4f6d8e-a72c-428d-8fbb-616510e1c772"+ , "4a01469f-285a-471c-9381-6ebeba00d4d9"+ , "5312022d-be32-4865-8d9b-cda95179ea2e"+ , "f2f72c71-77fd-4df2-a0fe-426f9749b96c"+ , "7cf30079-d3e1-4215-bbde-7ed81db1b6f6"+ , "31e491e4-0e41-45b2-994a-d18063c218ba"+ , "8b364c18-9e46-4776-ac78-ffa4e200104b"+ , "3e5b0676-8258-4e55-a3af-233d5ffac4c7"+ , "90f3d59f-42b8-476f-af4f-30abe465f510"+ , "46ad2bc5-f1bb-47e5-b336-8465eca1c3e1"+ , "8bfd88b5-f0c8-4e80-a25b-509c3d70f72e"+ , "eb9f9756-9431-4a0f-8df4-641f161f9450"+ , "99237a8c-14ae-4da3-a1d1-ee09add55746"+ , "3d474e6c-3402-46f6-8451-be3d6143890a"+ , "60745f1b-d0a3-4754-b958-e1067527b5c4"+ , "bd6dbf99-6c68-4ce4-a34b-daa3c4766487"+ , "ce81cc21-fba5-4b0b-8464-52ac5f4e6fd0"+ , "2c42e8b6-89db-4ea6-87c0-1a63e8908b91"+ , "6bfa8e14-dadd-4866-ae89-c51582622e68"+ , "9e100253-f807-40d1-9eea-73e7b50be390"+ , "ace8ebeb-9302-4a86-b29a-ec3a8aeaa73d"+ , "7c380f96-a427-46bc-af93-f4451d6fc072"+ , "e91a4d88-9565-4392-883e-e1afbf7b4e1d"+ , "1c9534e9-97d6-4fc8-b072-e536fc80e16a"+ , "30adcd09-9bcc-4b8f-be73-8d9d63b9254b"+ , "a27aed7a-0074-4535-8776-573890d4bbe8"+ , "a1342012-e505-4e4b-a245-08b04cb7a36f"+ , "cff3c2d5-01a4-4ccd-bf4c-4f7d6ccef6a6"+ , "10eb2b44-7b9b-4822-9b0b-ee152a506f99"+ , "f434e085-8c73-4832-ba99-e18a0a42a77f"+ , "7f029d88-22b0-4c4f-bee5-b8de9bd4b787"+ , "e71d3104-dee1-4926-8b29-c96955e46fa8"+ , "833bf188-d160-4dfc-a2ff-cb63b273a7dc"+ , "fbe1a7ca-4b5f-4eaf-a064-43de857625de"+ , "2d2daa9c-109c-456a-b94f-c55dd440d938"+ , "785db7db-5221-4ebf-86de-c91e5b3d5438"+ , "e504b605-07f8-4da2-bb5b-a86cdb9d117e"+ , "05cf172b-312b-4078-9bd8-77215b12d0b0"+ , "2b77b9f1-dfbe-4e8a-b710-25df48c2b8c7"+ , "ec402b1f-226e-481b-8e11-e52337a36481"+ , "54ef2193-197e-41b5-83ab-c0e516432f84"+ , "2d7115d1-89a9-4b83-856e-2dc8b6d5db26"+ , "84ea6913-0106-4ac1-9b84-ba621fc4b345"+ , "eb7a5343-9761-42b0-8258-4b658a36138e"+ , "64661121-b968-4122-89a3-de5be06f88a8"+ , "97cba1d1-528a-417a-86da-bb950d8480cb"+ , "af308922-76d8-47f4-ae97-0f2943b8952d"+ , "6dfb66ca-16c0-4029-bcde-2727f27832a0"+ , "66f9f38c-1f15-4e4e-a852-3be361a4a850"+ , "4ba8818f-c57c-4164-8fef-d38c5bf20da8"+ , "bad4a978-d1a1-40af-a5f2-e0d93888e423"+ , "3699f74a-f216-4c64-b8b2-9beb5c67f5ae"+ , "3c1e5beb-45be-4ead-b42a-4aca4927340d"+ , "5f1e6582-b8ee-44ac-b0db-2e93548b7a38"+ , "c7e39c12-5f9a-402c-abf8-9ee3b7726638"+ , "65407ef2-34a8-4a3c-b638-809125f4a4b4"+ , "542ffd56-a2b3-4548-a308-0946fc748f0b"+ , "cfeef25b-d9f7-4c1f-a9ca-6705df94b70d"+ , "181a9c36-e45a-4b48-bf7a-8a7c17208a40"+ , "ca4df7e6-4693-4854-87a9-689ccb5642be"+ , "1d0ade67-4063-4cc3-aa91-72339432a531"+ , "8e9dcc80-80a2-43ea-969d-53a7e278a022"+ , "73bc56a1-7d1d-41f4-9254-42a1656c7558"+ , "92cdb456-85a1-4fa0-8603-35b9da3a7361"+ , "be181705-4382-41dd-96a5-a61f05cd1059"+ , "fb2c419c-ea3a-4691-a45a-bcd875154f1d"+ , "bbe1a0d3-5615-47df-81ca-b52e066f01e1"+ , "c45f6fcd-b032-4039-9c23-0185f52f5722"+ , "8c250ca1-3a13-401d-8907-49db8f8fd1b1"+ , "958f7a5c-0938-414a-a280-daed6227abeb"+ , "b1bf5322-4729-497e-a227-7ca40d3c3360"+ , "0636f9aa-c831-4882-8af5-a63c0081f683"+ , "3e79509a-c7ce-45a3-8e2a-87d99711612f"+ ]++instance (ToSample a) => ToSample (IdAnd a) where+ toSamples _ =+ zipWith idAndify uuidList $ toSamples Proxy+ where+ idAndify uuid (desc, a) = (desc, IdAnd (Id uuid,a))++instance (ToSample a) => ToSample (RefMap a) where+ toSamples _ = singleSample .+ Map.fromList . zipWith idAndify uuidList $ toSamples Proxy+ where+ idAndify uuid (_, a) = (Id uuid, IdAnd (Id uuid,a))++#endif++
+ src/RFC/Data/UUID.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}++module RFC.Data.UUID+ ( module Data.UUID.Types+ ) where++import ClassyPrelude hiding ( fail )+import Control.Monad.Fail ( MonadFail, fail )+import qualified Data.Text as T+import Data.UUID.Types+import qualified Data.UUID.Types as UUID+import RFC.Prelude.String++#ifdef VERSION_aeson+#if MIN_VERSION_aeson(1,1,0)+-- UUID has ToJSON and FromJSON after Aeson 1.1.0+#else+import Data.Aeson.Types ( FromJSON (..), ToJSON (..), Value (String), typeMismatch )+#endif+#endif++#ifdef VERSION_servant_docs+import Servant.API.Capture+import Servant.Docs+#endif++#ifdef VERSION_servant_docs+instance ToCapture (Capture "id" UUID) where+ toCapture _ = DocCapture "id" "UUID identifier"++instance ToSample UUID where+ toSamples _ = samples . catMaybes $ UUID.fromString <$>+ [ "cf41ac06-3f70-479c-a2ed-d618a5e6dee2"+ , "26998bb3-d6c6-4f63-8a36-6b81eb6e6de9"+ , "6176b857-e461-4f34-a6a6-aeb8cbf7ffdf"+ , "26009820-d2d1-4360-87e0-aa73db3c0433"+ ]+#endif++#ifdef VERSION_aeson+#if MIN_VERSION_aeson(1,1,0)+-- UUID has ToJSON and FromJSON after Aeson 1.1.0+#else+instance ToJSON UUID where+ toJSON = String . T.pack . show+ {-# INLINE toJSON #-}++instance FromJSON UUID where+ parseJSON json@(String t) =+ case UUID.fromText t of+ Just uuid -> pure uuid+ Nothing -> typeMismatch "UUID" json+ parseJSON unknown = typeMismatch "UUID" unknown+ {-# INLINE parseJSON #-}+#endif+#endif++instance {-# OVERLAPPING #-} ToText UUID where+ toText = UUID.toText+ {-# INLINE toText #-}++instance {-# OVERLAPS #-} (MonadFail m) => FromText (m UUID) where+ {-# SPECIALISE instance FromText (Maybe UUID) #-}+ {-# SPECIALISE instance FromText ([UUID]) #-}+ {-# SPECIALISE instance FromText (IO UUID) #-}+ fromText :: Text -> m UUID+ fromText text =+ case UUID.fromText text of+ Nothing -> fail $ "Could not parse UUID: " <> (T.unpack text)+ Just x -> return x+ {-# INLINE fromText #-}+
+ src/RFC/Prelude.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++module RFC.Prelude+ ( module RFC.Prelude+ , module RFC.Data.UUID+ , module GHC.Generics+ , module Text.Read+ , module Data.Time.Units+ , module Data.Function+ , module Data.Typeable+ , module Control.Monad+ , module Data.Bitraversable+ , module Data.Bifunctor+ , module Data.Bifoldable+ , module Data.Default+ , module ClassyPrelude+ , module Control.Monad.Trans.Control+ , module Data.Word+ , module Data.Semigroup+ , module Control.Monad.Fail+ , module Data.Time.Clock+ , module UnliftIO+ , module GHC.Exts+ , module Data.Proxy+ , module Data.Ratio+ , module Data.Tuple.Curry+ , module Data.Either+ , module Data.Int+ , module RFC.Prelude.Instances+ , module RFC.Prelude.JSON+ , module RFC.Prelude.String+ , module RFC.Prelude.Concurrent+ ) where++import ClassyPrelude hiding+ ( Day, fail, fromList, map, readMay, toList, unpack, (++) )+import Control.Monad ( forever, void, (<=<), (>=>) )+import Control.Monad.Fail ( MonadFail, fail )+import Control.Monad.Trans.Control+import Data.Bifoldable+import Data.Bifunctor+import Data.Bitraversable+import Data.Char as Char+import Data.Default+import Data.Either ( Either (..) )+import qualified Data.Foldable as Foldable+import Data.Function ( (&) )+import Data.Int+import qualified Data.List as List+import Data.Proxy ( Proxy (..) )+import Data.Ratio ( Ratio, Rational )+import Data.Semigroup+import Data.Time.Clock+import Data.Time.Units+import Data.Tuple.Curry ( curryN, uncurryN )+import Data.Typeable ( TypeRep, typeOf )+import Data.Word ( Word16 )+import GHC.Exts ( IsList (..), fromListN )+import GHC.Generics ( Generic )+import Math.NumberTheory.Logarithms ( integerLog2 )+import RFC.Data.UUID ( UUID )+import RFC.Prelude.Concurrent+import RFC.Prelude.Instances+import RFC.Prelude.JSON+import RFC.Prelude.String+import Text.Read ( Read, read, readMaybe )+import UnliftIO++#ifdef VERSION_exceptions+import Control.Monad.Catch+#endif++{-# ANN module "HLint: ignore Use if" #-}++readMay :: (ToText input, Read output) => input -> Maybe output+readMay = readMaybe . fromText . toText+{-# INLINEABLE readMay #-}+{-# SPECIALIZE INLINE readMay :: (Read output) => StrictText -> Maybe output #-}+{-# SPECIALIZE INLINE readMay :: (Read output) => String -> Maybe output #-}++-- | Unwraps an 'Either', returning a default value if it is a 'Left'.+fromRight :: b -> Either a b -> b+fromRight _ (Right b) = b+fromRight b (Left _) = b+{-# INLINE fromRight #-}++-- | Unwraps an 'Either', returning a default value if it is a 'Right'.+fromLeft :: a -> Either a b -> a+fromLeft a (Right _) = a+fromLeft _ (Left a) = a+{-# INLINE fromLeft #-}++-- | An equivalent to 'maybe' for 'Right'.+right :: x -> (b -> x) -> Either a b -> x+right _ f (Right b) = f b+right x _ (Left _) = x+{-# INLINE right #-}+{-# SPECIALIZE INLINE right :: x -> (String -> x) -> Either a String -> x #-}++-- | An equivalent to 'maybe' for 'Left'.+left :: x -> (a -> x) -> Either a b -> x+left _ f (Left a) = f a+left x _ (Right _) = x+{-# INLINE left #-}+{-# SPECIALIZE INLINE left :: x -> (String -> x) -> Either String b -> x #-}++-- | Our implementation of if, which is pretty much exactly what you would suspect.+ifThenElse :: Bool -> a -> a -> a+ifThenElse test true false =+ case test of+ True -> true+ False -> false+{-# INLINE ifThenElse #-}++charIsUpper :: Char -> Bool+charIsUpper = Char.isUpper+{-# INLINE charIsUpper #-}++charIsLower :: Char -> Bool+charIsLower = Char.isLower+{-# INLINE charIsLower #-}++uniq :: (Eq a) => [a] -> [a]+uniq = List.nub+{-# INLINE uniq #-}++safeHead :: (MonadFail m, Foldable f) => f a -> m a+safeHead xs =+ case Foldable.toList xs of+ [] -> fail "Attempted to head an empty list"+ (x:_) -> return x+{-# INLINE safeHead #-}+{-# SPECIALIZE INLINE safeHead :: [a] -> Maybe a #-}+{-# SPECIALIZE INLINE safeHead :: [a] -> IO a #-}++lg :: Integer -> Integer+lg z+ | z > 0 = toInteger $ integerLog2 z+ | z == 0 = 0+ | otherwise = toInteger $ integerLog2 (-1 * z)+{-# INLINE lg #-}++lg' :: (Integral z, Integral z') => z -> z'+lg' = fromInteger . lg . toInteger+{-# INLINEABLE lg' #-}+{-# SPECIALIZE INLINE lg' :: Integer -> Integer #-}+{-# SPECIALIZE INLINE lg' :: (Integral z') => Integer -> z' #-}+{-# SPECIALIZE INLINE lg' :: (Integral z ) => z -> Int #-}+{-# SPECIALIZE INLINE lg' :: (Integral z ) => z -> Integer #-}+{-# SPECIALIZE INLINE lg' :: Word -> Word #-}++isSingleton :: (Foldable f) => f a -> Bool+isSingleton xs =+ case Foldable.toList xs of+ [_] -> True+ _ -> False+{-# INLINEABLE isSingleton #-}+{-# SPECIALIZE INLINE isSingleton :: [a] -> Bool #-}+{-# SPECIALIZE INLINE isSingleton :: Seq a -> Bool #-}++fmap2 :: (Functor f, Functor g) => (a -> b) -> f(g a) -> f(g b)+fmap2 f x = fmap f <$> x+{-# INLINE fmap2 #-}+{-# SPECIALIZE INLINE fmap2 :: Functor g => (a->b) -> [g a] -> [g b] #-}+{-# SPECIALIZE INLINE fmap2 :: Functor f => (a->b) -> f [a] -> f [b] #-}+{-# SPECIALIZE INLINE fmap2 :: Functor g => (a->b) -> IO (g a) -> IO (g b) #-}+{-# SPECIALIZE INLINE fmap2 :: Functor f => (a->b) -> f (IO a) -> f (IO b) #-}+{-# SPECIALIZE INLINE fmap2 :: Functor g => (a->b) -> Maybe (g a) -> Maybe (g b) #-}+{-# SPECIALIZE INLINE fmap2 :: Functor f => (a->b) -> f (Maybe a) -> f (Maybe b) #-}++infixl 4 <$$>+(<$$>) :: (Functor f, Functor g) => (a -> b) -> f(g a) -> f(g b)+(<$$>) = fmap2+{-# INLINE (<$$>) #-}+{-# SPECIALIZE INLINE (<$$>) :: Functor g => (a->b) -> [g a] -> [g b] #-}+{-# SPECIALIZE INLINE (<$$>) :: Functor f => (a->b) -> f [a] -> f [b] #-}+{-# SPECIALIZE INLINE (<$$>) :: Functor g => (a->b) -> IO (g a) -> IO (g b) #-}+{-# SPECIALIZE INLINE (<$$>) :: Functor f => (a->b) -> f (IO a) -> f (IO b) #-}+{-# SPECIALIZE INLINE (<$$>) :: Functor g => (a->b) -> Maybe (g a) -> Maybe (g b) #-}+{-# SPECIALIZE INLINE (<$$>) :: Functor f => (a->b) -> f (Maybe a) -> f (Maybe b) #-}
+ src/RFC/Prelude/Concurrent.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}++module RFC.Prelude.Concurrent+ ( module RFC.Prelude.Concurrent+ , module Control.Monad.IO.Unlift+ , module UnliftIO.Concurrent+ , module UnliftIO.Async+ , module Control.Monad.Trans.Control+ ) where++import ClassyPrelude+import Control.Monad.IO.Unlift+import Control.Monad.Trans.Control+import Data.Foldable ( foldrM )+import UnliftIO.Async+import UnliftIO.Concurrent++-- |Executes all the IO actions simultaneously and returns the original data structure with the arguments replaced+-- by the results of the execution.+doConcurrently :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a)+doConcurrently = mapConcurrently id+{-# SPECIALIZE INLINE doConcurrently :: (MonadUnliftIO m) => [m a] -> m [a] #-}+{-# SPECIALIZE INLINE doConcurrently :: [IO a] -> IO [a] #-}+{-# INLINE doConcurrently #-}++-- |Executes all the IO actions simulataneously and discards the results.+doConcurrently_ :: (Foldable f, MonadUnliftIO m) => f (m a) -> m ()+doConcurrently_ = mapConcurrently_ id+{-# SPECIALIZE INLINE doConcurrently_ :: (MonadUnliftIO m) => [m a] -> m () #-}+{-# SPECIALIZE INLINE doConcurrently_ :: [IO a] -> IO () #-}+{-# INLINE doConcurrently_ #-}++-- |Executes all the IO actions simultaneously and then filters the results based on the filter function.+filterConcurrently :: (Traversable t, Applicative t, Semigroup (t a), Monoid (t a), MonadUnliftIO m) => (a -> Bool) -> t (m a) -> m (t a)+filterConcurrently test actions = do+ !asyncActions <- mapM async actions+ foldrM foldImpl mempty asyncActions+ where+ foldImpl !promise results = do+ result <- wait promise+ return $ case test result of+ True -> (pure result) <> results+ False -> results+{-# INLINABLE filterConcurrently #-}+{-# SPECIALIZE INLINE filterConcurrently :: (MonadUnliftIO m) => (a -> Bool) -> [m a] -> m [a] #-}+{-# SPECIALIZE INLINE filterConcurrently :: (a -> Bool) -> [IO a] -> IO [a] #-}
+ src/RFC/Prelude/Instances.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module RFC.Prelude.Instances+ ( module RFC.Prelude.Instances+ ) where++import ClassyPrelude+import Control.Monad.Fail+import Data.Semigroup+import GHC.Conc++#ifdef VERSION_data_default+import Data.Default+#endif++#ifdef VERSION_exceptions+import Control.Monad.Catch+#endif++#ifdef VERSION_mtl+import Control.Monad.Except ( ExceptT (..) )+#endif++{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-}++type Boolean = Bool -- I keep forgetting which Haskell uses....++newtype Failed = Failed String+ deriving (Show, Eq, Ord, Generic, Typeable)+instance Exception Failed++instance {-# OVERLAPPABLE #-} (Monad m, MonadIO m) => MonadFail m where+ fail = throwIO . Failed+ {-# INLINE fail #-}++#ifdef VERSION_exceptions+instance {-# OVERLAPPABLE #-} MonadThrow m => MonadFail m where+ fail = throwM . Failed+ {-# INLINE fail #-}+#endif++instance {-# OVERLAPPING #-} MonadFail STM where+ fail _ = retry+ {-# INLINE fail #-}++instance {-# OVERLAPPING #-} MonadFail (Either String) where+ fail = Left+ {-# INLINE fail #-}++instance {-# OVERLAPPING #-} MonadFail Option where+ fail _ = Option Nothing+ {-# INLINE fail #-}++#ifdef VERSION_data_default+instance {-# OVERLAPPABLE #-} (Semigroup m, Default m) => Monoid m where+ mempty = def+ mappend = (<>)+ {-# INLINE mempty #-}++instance {-# OVERLAPPABLE #-} (Monoid m) => Default m where+ def = mempty+ {-# INLINE def #-}+#endif++#ifdef VERSION_unliftio_core+#ifdef VERSION_mtl+-- HOLY BALLS this was a pain in the ass to get to compile...+instance {-# OVERLAPPABLE #-} (Exception e, MonadUnliftIO m) => MonadUnliftIO (ExceptT e m) where+ askUnliftIO = f <$> (lift $ askUnliftIO)+ where+ f innerUIO = UnliftIO $ \(ExceptT m) -> ((unliftIO innerUIO) m >>= \case+ Left e -> throwIO e+ Right a -> return a+ )+#endif+#endif
+ src/RFC/Prelude/JSON.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}++module RFC.Prelude.JSON+( jsonOptions+, deriveJSON+, FromJSON(..)+, ToJSON(..)+, eitherDecode+, decodeEither+, eitherDecode'+, decodeEither'+, decodeOrDie+, DecodeError+, Value(..)+, encode+, decode+, module Data.Aeson.Types+) where++import ClassyPrelude+import Data.Aeson as JSON+import Data.Aeson.Parser as JSONParser+import Data.Aeson.TH ( deriveJSON )+import Data.Aeson.Types ( Options (..), SumEncoding (..), Value (..) )+import Data.Char+import RFC.Prelude.String+import Web.HttpApiData++-- How we go about executing the parser+#ifdef VERSION_aeson+#if MIN_VERSION_aeson(1,0,0)+import Data.Aeson.Text as JSON+import qualified Data.Aeson.Types as JSONTypes+#else+import qualified Data.Aeson.Encode as JSON+import Data.Attoparsec.ByteString as JSON+import Data.Either ( either )+#endif+#endif++#ifdef VERSION_swagger2+import qualified Data.Swagger as Swag+#endif++jsonOptions :: Options+jsonOptions = defaultOptions+ { sumEncoding = ObjectWithSingleField+ , unwrapUnaryRecords = True+ , fieldLabelModifier = flm+ , constructorTagModifier = ctm+ }+ where+ ctm [] = []+ ctm (c:cs) = (charToLower c):cs+ flm = flm' . span isLower+ flm' (cs, []) = cs+ flm' (_, cs) = lowerFirst cs+ lowerFirst [] = []+ lowerFirst (c:cs) = (charToLower c):cs++decodeEither :: (FromJSON a) => LazyByteString -> Either String a+decodeEither = eitherDecode++decodeEither' :: (FromJSON a) => LazyByteString -> Either String a+decodeEither' = eitherDecode'++#ifdef VERSION_aeson+newtype DecodeError = DecodeError (LazyByteString, String) deriving (Show,Eq,Ord,Generic,Typeable)+instance Exception DecodeError++decodeOrDie :: (FromJSON a, MonadIO m) => LazyByteString -> m a+decodeOrDie input =+ case decodeEither' input of+ Left err -> throwIO $ DecodeError (input, err)+ Right a -> return a++instance FromHttpApiData JSON.Value where+ parseUrlPiece text =+ case parsed of+ Nothing -> Left $ (toText "Could not parse JSON: ") <> text+ (Just value) -> Right value+ where+ textBs = toUTF8 text+ parser = JSONParser.value'+ parsed =+#if MIN_VERSION_aeson(1,0,0)+ JSONParser.decodeStrictWith parser JSONTypes.Success textBs+#else+ either (const Nothing) Just $ JSON.parseOnly parser textBs+#endif++instance ToHttpApiData JSON.Value where+ toUrlPiece =+#if MIN_VERSION_aeson(1,0,0)+ fromText . toText . JSON.encodeToLazyText+#else+ fromText . toText . JSON.encodeToTextBuilder+#endif++#ifdef VERSION_swagger2+instance Swag.ToSchema Value where+ declareNamedSchema _ = return . Swag.NamedSchema (Just $ cs "Value") $ mempty+#endif++#endif
+ src/RFC/Prelude/String.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+++module RFC.Prelude.String+ ( module RFC.Prelude.String+ , module Data.Text.Conversions+ ) where++import ClassyPrelude hiding ( fail )+import Control.Monad.Fail ( MonadFail, fail )+import qualified Data.ByteString as SB+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Short as Sbs+import Data.String ( String )+import qualified Data.Text as ST+import Data.Text.Conversions+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Builder as LTBuilder+import Network.URI ( URI (..), parseURIReference, uriToString )+import RFC.Prelude.Instances ()++#if VERSION_servant_docs+import Servant.Docs+#endif++{-# ANN module "HLint: ignore Use String" #-}++type LazyText = LT.Text+type StrictText = ST.Text+type LazyByteString = LB.ByteString+type StrictByteString = SB.ByteString+type ShortByteString = Sbs.ShortByteString+type LazyTextBuilder = LTBuilder.Builder++toStrictText :: (ToText a) => a -> StrictText+toStrictText = toText+{-# SPECIALIZE INLINE toStrictText :: String -> StrictText #-}+{-# SPECIALIZE INLINE toStrictText :: LazyText -> StrictText #-}+{-# SPECIALIZE INLINE toStrictText :: StrictText -> StrictText #-}++toLazyText :: (ToText a) => a -> LazyText+toLazyText = LT.fromStrict . toText+{-# INLINE toLazyText #-}+{-# SPECIALIZE INLINE toLazyText :: String -> LazyText #-}+{-# SPECIALIZE INLINE toLazyText :: StrictText -> LazyText #-}+{-# SPECIALIZE INLINE toLazyText :: LazyText -> LazyText #-}++toUTF8 :: (ToText a, FromText (UTF8 b)) => a -> b+toUTF8 = unUTF8 . fromText . toText+{-# INLINE toUTF8 #-}+{-# SPECIALIZE INLINE toUTF8 :: String-> LazyByteString #-}+{-# SPECIALIZE INLINE toUTF8 :: StrictText -> LazyByteString #-}+{-# SPECIALIZE INLINE toUTF8 :: LazyText -> LazyByteString #-}+{-# SPECIALIZE INLINE toUTF8 :: String-> StrictByteString #-}+{-# SPECIALIZE INLINE toUTF8 :: StrictText -> StrictByteString #-}+{-# SPECIALIZE INLINE toUTF8 :: LazyText -> StrictByteString #-}+{-# SPECIALIZE INLINE toUTF8 :: String-> ShortByteString #-}+{-# SPECIALIZE INLINE toUTF8 :: StrictText -> ShortByteString #-}+{-# SPECIALIZE INLINE toUTF8 :: LazyText -> ShortByteString #-}++fromUTF8 :: (DecodeText f (UTF8 a), FromText b) => a -> f b+fromUTF8 = decodeConvertText . UTF8+{-# INLINE fromUTF8 #-}+{-# SPECIALIZE INLINE fromUTF8 :: LazyByteString -> Maybe String #-}+{-# SPECIALIZE INLINE fromUTF8 :: LazyByteString -> Maybe StrictText #-}+{-# SPECIALIZE INLINE fromUTF8 :: LazyByteString -> Maybe LazyText #-}+{-# SPECIALIZE INLINE fromUTF8 :: StrictByteString -> Maybe String #-}+{-# SPECIALIZE INLINE fromUTF8 :: StrictByteString -> Maybe StrictText #-}+{-# SPECIALIZE INLINE fromUTF8 :: StrictByteString -> Maybe LazyText #-}+{-# SPECIALIZE INLINE fromUTF8 :: ShortByteString -> Maybe String #-}+{-# SPECIALIZE INLINE fromUTF8 :: ShortByteString -> Maybe StrictText #-}+{-# SPECIALIZE INLINE fromUTF8 :: ShortByteString -> Maybe LazyText #-}++instance {-# OVERLAPPING #-} FromText (UTF8 ShortByteString) where+ fromText = UTF8 . Sbs.toShort . encodeUtf8+ {-# INLINE fromText #-}++instance {-# INCOHERENT #-} (MonadFail m, Show (UTF8 a), DecodeText Maybe (UTF8 a)) => DecodeText m (UTF8 a) where+ {-# SPECIALIZE instance DecodeText IO (UTF8 ShortByteString) #-}+ {-# SPECIALIZE instance DecodeText [] (UTF8 ShortByteString) #-}+ decodeText arg =+ case decodeText arg of+ Nothing ->+ fail $ "Unable to decode text: " <> show arg+ Just x ->+ return x+ {-# INLINE decodeText #-}++emptyString :: (FromText a) => a+emptyString = fromText $ toText ""+{-# INLINE emptyString #-}+{-# SPECIALIZE INLINE emptyString :: String #-}+{-# SPECIALIZE INLINE emptyString :: LazyText #-}+{-# SPECIALIZE INLINE emptyString :: StrictText #-}++emptyUTF8 :: (FromText (UTF8 a)) => a+emptyUTF8 = unUTF8 . fromText $ toText ""+{-# INLINE emptyUTF8 #-}++instance {-# OVERLAPPING #-} ToText Char where+ toText c = toText [c]+ {-# INLINE toText #-}++instance {-# OVERLAPPABLE #-} (FromText a) => FromText (UTF8 a) where+ {-# SPECIALISE instance FromText (UTF8 StrictText) #-}+ {-# SPECIALISE instance FromText (UTF8 LazyText) #-}+ {-# SPECIALISE instance FromText (UTF8 String) #-}+ fromText = UTF8 . fromText+ {-# INLINE fromText #-}++instance {-# OVERLAPPABLE #-} (ToText a) => ToText (UTF8 a) where+ {-# SPECIALISE instance ToText (UTF8 StrictText) #-}+ {-# SPECIALISE instance ToText (UTF8 LazyText) #-}+ {-# SPECIALISE instance ToText (UTF8 String) #-}+ toText = toText . unUTF8+ {-# INLINE toText #-}++instance {-# OVERLAPPING #-} ToText URI where+ toText uri = toText $ uriToString id uri ""+ {-# INLINE toText #-}++instance {-# OVERLAPS #-} (MonadFail f) => FromText (f URI) where+ {-# SPECIALIZE instance FromText (Maybe URI) #-}+ {-# SPECIALIZE instance FromText (IO URI) #-}+ fromText txt =+ let str = fromText txt in+ case parseURIReference str of+ Nothing -> fail $ "Could not parse URI: " <> str+ Just uri -> return uri+ {-# INLINE fromText #-}++#if VERSION_servant_docs++instance ToSample StrictText where+ toSamples _ = singleSample $ toText "This is arbitrary text"++instance ToSample LazyText where+ toSamples _ = singleSample $ toText "This is arbitrary text"++#endif+++instance {-# OVERLAPPING #-} ToText LazyTextBuilder where+ toText = toText . LTBuilder.toLazyText+ {-# INLINE toText #-}+