collections-api == 1.0.*,
collections-base-instances == 1.0.*,
containers == 0.4.*,
- containers-unicode-symbols == 0.3.*,
directory == 1.1.*,
filepath == 1.2.*,
hxt == 9.1.*,
Network.HTTP.Lucu.ContentCoding
Network.HTTP.Lucu.DefaultPage
Network.HTTP.Lucu.Interaction
+ Network.HTTP.Lucu.OrphanInstances
Network.HTTP.Lucu.Postprocess
Network.HTTP.Lucu.Preprocess
Network.HTTP.Lucu.RequestReader
-- *** MIME Type
, MIMEType(..)
- , MIMEParams(..)
+ , MIMEParams
, parseMIMEType
, mimeType
import Data.Data
import Data.Monoid.Unicode
import Language.Haskell.TH.Syntax
+import Network.HTTP.Lucu.OrphanInstances ()
import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http hiding (token)
import Network.HTTP.Lucu.Utils
-- |An entity tag consists of a weakness flag and an opaque string.
data ETag = ETag {
- -- |The weakness flag. Weak tags looks like W\/\"blahblah\" and
- -- strong tags are like \"blahblah\". See:
+ -- |The weakness flag. Weak tags looks like @W\/\"blahblah\"@
+ -- and strong tags are like @\"blahblah\"@. See:
-- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec13.html#sec13.3.3>
etagIsWeak ∷ !Bool
-- |An opaque string. Only characters from 0x20 (sp) to 0x7e (~)
lift (ETag {..})
= [| ETag {
etagIsWeak = $(lift etagIsWeak)
- , etagToken = $(liftAscii etagToken)
+ , etagToken = $(lift etagToken )
}
|]
import qualified Data.Ascii as A
import Data.Attoparsec.Char8 as P
import Data.List (intersperse)
-import qualified Data.Map as M
+import qualified Data.Map as M (Map)
import Data.Collections
import Data.Collections.BaseInstances ()
import Data.Monoid
empty
= Headers empty
{-# INLINE singleton #-}
- singleton v
- = Headers $ singleton v
+ singleton p
+ = Headers $ singleton p
{-# INLINE insertMany #-}
insertMany f (Headers m)
= Headers $ insertMany f m
= Headers $ insertManySorted f m
instance Foldable Headers (CIAscii, Ascii) where
+ {-# INLINE null #-}
+ null (Headers m) = null m
+ {-# INLINE size #-}
+ size (Headers m) = size m
{-# INLINE foldr #-}
foldr f b (Headers m) = foldr f b m
import Network.HTTP.Lucu.Implant
import Network.HTTP.Lucu.Implant.Rewrite
import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.OrphanInstances ()
import Network.HTTP.Lucu.Resource
-import Network.HTTP.Lucu.Utils
import Prelude hiding (head)
import Prelude.Unicode
decls ∷ [Q Dec]
decls | useGZip i
= [ sigD gzipEncoding [t| CIAscii |]
- , valD (varP gzipEncoding) (normalB (liftCIAscii "gzip")) []
+ , valD (varP gzipEncoding) (normalB (lift ("gzip" ∷ CIAscii))) []
]
| otherwise
= []
lastModDecl ∷ Input → Q [Dec]
lastModDecl (Input {..})
= sequence [ sigD lastModified [t| UTCTime |]
- , valD (varP lastModified) (normalB (liftUTCTime iLastMod)) []
+ , valD (varP lastModified) (normalB (lift iLastMod)) []
]
contTypeDecl ∷ Input → Q [Dec]
binDecl i@(Input {..})
| useGZip i
= sequence [ sigD gzippedData [t| L.ByteString |]
- , valD (varP gzippedData) (normalB (liftLazyByteString iGZipped)) []
+ , valD (varP gzippedData) (normalB (lift iGZipped)) []
]
| otherwise
= sequence [ sigD rawData [t| L.ByteString |]
- , valD (varP rawData) (normalB (liftLazyByteString iRawData)) []
+ , valD (varP rawData) (normalB (lift iRawData)) []
]
rules ∷ Rules
import Data.Generics.Schemes
import Data.Monoid
import Data.Monoid.Unicode
-import qualified Data.Set as S
+import qualified Data.Set as S (Set)
import Language.Haskell.TH.Syntax
import Prelude hiding (filter, foldr, lookup)
import Prelude.Unicode
{-# LANGUAGE
- CPP
- , DeriveDataTypeable
+ DeriveDataTypeable
, DoAndIfThenElse
+ , FlexibleInstances
, GeneralizedNewtypeDeriving
+ , MultiParamTypeClasses
, OverloadedStrings
, RecordWildCards
, TemplateHaskell
+ , TypeSynonymInstances
, UnicodeSyntax
#-}
-- |Parsing and printing MIME parameter values
-- (<http://tools.ietf.org/html/rfc2231>).
module Network.HTTP.Lucu.MIMEParams
- ( MIMEParams(..)
+ ( MIMEParams
, printMIMEParams
, mimeParams
)
where
-import Control.Applicative
+import Control.Applicative hiding (empty)
+import Control.Arrow
import Control.Monad hiding (mapM)
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
import Data.Bits
import qualified Data.ByteString.Char8 as BS
import Data.Char
-import Data.Data
-import Data.Foldable
-import Data.Map (Map)
-import qualified Data.Map as M
+import Data.Collections
+import Data.Collections.BaseInstances ()
+import qualified Data.Map as M (Map)
import Data.Monoid
import Data.Monoid.Unicode
-import Data.Sequence (Seq, ViewL(..))
-import qualified Data.Sequence as S
-import Data.Sequence.Unicode hiding ((∅))
+import Data.Sequence (Seq)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding
import Data.Text.Encoding.Error
-import Data.Traversable
+import Data.Typeable
import Data.Word
import Language.Haskell.TH.Syntax
+import Network.HTTP.Lucu.OrphanInstances ()
import Network.HTTP.Lucu.Parser.Http
import Network.HTTP.Lucu.Utils
-import Prelude hiding (concat, mapM, takeWhile)
+import Prelude hiding (concat, filter, foldr, lookup, mapM, null, takeWhile)
import Prelude.Unicode
-- |A 'Map' from MIME parameter attributes to values. Attributes are
-- always case-insensitive according to RFC 2045
-- (<http://tools.ietf.org/html/rfc2045#section-5.1>).
newtype MIMEParams
- = MIMEParams (Map CIAscii Text)
+ = MIMEParams (M.Map CIAscii Text)
deriving (Eq, Show, Read, Monoid, Typeable)
instance Lift MIMEParams where
- lift (MIMEParams m) = [| MIMEParams $(liftParams m) |]
- where
- liftParams ∷ Map CIAscii Text → Q Exp
- liftParams = liftMap liftCIAscii liftText
+ lift (MIMEParams m) = [| MIMEParams $(lift m) |]
+
+instance Unfoldable MIMEParams (CIAscii, Text) where
+ {-# INLINE insert #-}
+ insert p (MIMEParams m)
+ = MIMEParams $ insert p m
+ {-# INLINE empty #-}
+ empty
+ = MIMEParams empty
+ {-# INLINE singleton #-}
+ singleton p
+ = MIMEParams $ singleton p
+ {-# INLINE insertMany #-}
+ insertMany f (MIMEParams m)
+ = MIMEParams $ insertMany f m
+ {-# INLINE insertManySorted #-}
+ insertManySorted f (MIMEParams m)
+ = MIMEParams $ insertManySorted f m
+
+instance Foldable MIMEParams (CIAscii, Text) where
+ {-# INLINE null #-}
+ null (MIMEParams m) = null m
+ {-# INLINE size #-}
+ size (MIMEParams m) = size m
+ {-# INLINE foldr #-}
+ foldr f b (MIMEParams m) = foldr f b m
+
+instance Collection MIMEParams (CIAscii, Text) where
+ {-# INLINE filter #-}
+ filter f (MIMEParams m) = MIMEParams $ filter f m
+
+instance Indexed MIMEParams CIAscii Text where
+ {-# INLINE index #-}
+ index k (MIMEParams m) = index k m
+ {-# INLINE adjust #-}
+ adjust f k (MIMEParams m) = MIMEParams $ adjust f k m
+ {-# INLINE inDomain #-}
+ inDomain k (MIMEParams m) = inDomain k m
+
+instance Map MIMEParams CIAscii Text where
+ {-# INLINE lookup #-}
+ lookup k (MIMEParams m) = lookup k m
+ {-# INLINE mapWithKey #-}
+ mapWithKey f (MIMEParams m)
+ = MIMEParams $ mapWithKey f m
+ {-# INLINE unionWith #-}
+ unionWith f (MIMEParams α) (MIMEParams β)
+ = MIMEParams $ unionWith f α β
+ {-# INLINE intersectionWith #-}
+ intersectionWith f (MIMEParams α) (MIMEParams β)
+ = MIMEParams $ intersectionWith f α β
+ {-# INLINE differenceWith #-}
+ differenceWith f (MIMEParams α) (MIMEParams β)
+ = MIMEParams $ differenceWith f α β
+ {-# INLINE isSubmapBy #-}
+ isSubmapBy f (MIMEParams α) (MIMEParams β)
+ = isSubmapBy f α β
+ {-# INLINE isProperSubmapBy #-}
+ isProperSubmapBy f (MIMEParams α) (MIMEParams β)
+ = isProperSubmapBy f α β
+
+instance SortingCollection MIMEParams (CIAscii, Text) where
+ {-# INLINE minView #-}
+ minView (MIMEParams m) = second MIMEParams <$> minView m
-- |Convert MIME parameter values to an 'AsciiBuilder'.
printMIMEParams ∷ MIMEParams → AsciiBuilder
{-# INLINEABLE printMIMEParams #-}
-#if MIN_VERSION_containers(0, 4, 1)
-printMIMEParams (MIMEParams m) = M.foldlWithKey' f (∅) m
-#else
-printMIMEParams (MIMEParams m) = M.foldlWithKey f (∅) m
-#endif
+printMIMEParams = foldl' f (∅)
where
- f ∷ AsciiBuilder → CIAscii → Text → AsciiBuilder
+ f ∷ AsciiBuilder → (CIAscii, Text) → AsciiBuilder
{-# INLINE f #-}
- f ab k v = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v
+ f ab (k, v) = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v
printPair ∷ CIAscii → Text → AsciiBuilder
{-# INLINEABLE printPair #-}
decodeParams ∷ (Functor m, Monad m) ⇒ [ExtendedParam] → m MIMEParams
{-# INLINE decodeParams #-}
-decodeParams = (MIMEParams <$>) ∘ (mapM decodeSections =≪) ∘ sortBySection
+decodeParams = (MIMEParams <$>)
+ ∘ (mapM (\(k, v) → ((,) k) <$> decodeSections v) =≪)
+ ∘ sortBySection
sortBySection ∷ Monad m
⇒ [ExtendedParam]
- → m (Map CIAscii (Map Integer ExtendedParam))
+ → m (M.Map CIAscii (M.Map Integer ExtendedParam))
sortBySection = flip go (∅)
where
go ∷ Monad m
⇒ [ExtendedParam]
- → Map CIAscii (Map Integer ExtendedParam)
- → m (Map CIAscii (Map Integer ExtendedParam))
+ → M.Map CIAscii (M.Map Integer ExtendedParam)
+ → m (M.Map CIAscii (M.Map Integer ExtendedParam))
go [] m = return m
go (x:xs) m
- = case M.lookup (epName x) m of
+ = case lookup (epName x) m of
Nothing
- → let s = M.singleton (section x) x
- m' = M.insert (epName x) s m
+ → let s = singleton (section x, x)
+ m' = insert (epName x, s) m
in
go xs m'
Just s
- → case M.lookup (section x) s of
+ → case lookup (section x) s of
Nothing
- → let s' = M.insert (section x) x s
- m' = M.insert (epName x) s' m
+ → let s' = insert (section x, x ) s
+ m' = insert (epName x, s') m
in
go xs m'
Just _
, "'"
])
-decodeSections ∷ Monad m ⇒ Map Integer ExtendedParam → m Text
+decodeSections ∷ Monad m ⇒ M.Map Integer ExtendedParam → m Text
decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
where
toSeq ∷ Monad m
- ⇒ Map Integer ExtendedParam
+ ⇒ M.Map Integer ExtendedParam
→ Integer
→ Seq ExtendedParam
→ m (Seq ExtendedParam)
toSeq m expectedSect sects
- = case M.minViewWithKey m of
+ = case minView m of
Nothing
→ return sects
Just ((sect, p), m')
decodeSeq ∷ Monad m ⇒ Seq ExtendedParam → m Text
decodeSeq sects
- = case S.viewl sects of
- EmptyL
+ = case front sects of
+ Nothing
→ fail "decodeSeq: internal error: empty seq"
- InitialEncodedParam {..} :< xs
+ Just (InitialEncodedParam {..}, xs)
→ do d ← getDecoder epCharset
t ← decodeStr d epPayload
- decodeSeq' (Just d) xs $ S.singleton t
- ContinuedEncodedParam {..} :< _
+ decodeSeq' (Just d) xs $ singleton t
+ Just (ContinuedEncodedParam {..}, _)
→ fail "decodeSeq: internal error: CEP at section 0"
- AsciiParam {..} :< xs
+ Just (AsciiParam {..}, xs)
→ let t = A.toText apPayload
in
- decodeSeq' Nothing xs $ S.singleton t
+ decodeSeq' Nothing xs $ singleton t
decodeSeq' ∷ Monad m
⇒ Maybe Decoder
→ Seq Text
→ m Text
decodeSeq' decoder sects chunks
- = case S.viewl sects of
- EmptyL
+ = case front sects of
+ Nothing
→ return $ T.concat $ toList chunks
- InitialEncodedParam {..} :< _
+ Just (InitialEncodedParam {}, _)
→ fail "decodeSeq': internal error: IEP at section > 0"
- ContinuedEncodedParam {..} :< xs
+ Just (ContinuedEncodedParam {..}, xs)
→ case decoder of
Just d
→ do t ← decodeStr d epPayload
, A.toString $ A.fromCIAscii epName
, "' is encoded but its first section is not"
])
- AsciiParam {..} :< xs
+ Just (AsciiParam {..}, xs)
→ let t = A.toText apPayload
in
decodeSeq' decoder xs $ chunks ⊳ t
import Data.Typeable
import Language.Haskell.TH.Syntax
import Network.HTTP.Lucu.MIMEParams
+import Network.HTTP.Lucu.OrphanInstances ()
import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
-import Network.HTTP.Lucu.Utils
import Prelude.Unicode
-- |A media type, subtype, and parameters.
instance Lift MIMEType where
lift (MIMEType {..})
= [| MIMEType {
- mtMedia = $(liftCIAscii mtMedia)
- , mtSub = $(liftCIAscii mtSub)
+ mtMedia = $(lift mtMedia )
+ , mtSub = $(lift mtSub )
, mtParams = $(lift mtParams)
}
|]
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.OrphanInstances ()
import Network.HTTP.Lucu.Parser
-import Network.HTTP.Lucu.Utils
import Prelude.Unicode
import System.FilePath
deriving (Eq, Show, Read, Monoid, Typeable)
instance Lift ExtMap where
- lift (ExtMap m)
- = [| ExtMap $(liftMap liftText lift m) |]
+ lift (ExtMap m) = [| ExtMap $(lift m) |]
-- |'QuasiQuoter' for 'ExtMap' reading Apache @mime.types@.
--
where
import Control.Applicative hiding (many)
import Control.Applicative.Unicode hiding ((∅))
-import Control.Monad.Error
+import Control.Monad.Error (MonadError, throwError)
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii)
import qualified Data.Ascii as A
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LS
import Data.ByteString.Lazy.Search
-import Data.Foldable
-import Data.List
-import qualified Data.Map as M
+import Data.Collections
+import Data.List (intercalate)
import Data.Maybe
import Data.Monoid.Unicode
import Data.Sequence (Seq)
-import Data.Sequence.Unicode hiding ((∅))
import Data.Text (Text)
import qualified Data.Text as T
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.MIMEType.TH
import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
+import Network.HTTP.Lucu.Utils
+import Prelude hiding (lookup, mapM)
import Prelude.Unicode
-- |'FormData' represents a form value and possibly an uploaded file
partName ∷ MonadError String m ⇒ Part → m Ascii
{-# INLINEABLE partName #-}
partName (Part {..})
- = case M.lookup "name" params of
+ = case lookup "name" $ dParams ptContDispo of
Just name
→ case A.fromText name of
Just a → return a
Nothing
→ throwError $ "form-data without name: "
⧺ A.toString (printContDispo ptContDispo)
- where
- params = case dParams ptContDispo of
- MIMEParams m → m
partFileName ∷ Part → Maybe Text
-partFileName (dParams ∘ ptContDispo → MIMEParams m)
- = M.lookup "filename" m
+partFileName (ptContDispo → ContDispo {..})
+ = lookup "filename" dParams
--- /dev/null
+{-# LANGUAGE
+ RecordWildCards
+ , TemplateHaskell
+ , UnicodeSyntax
+ #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Network.HTTP.Lucu.OrphanInstances
+ (
+ )
+ where
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as Strict
+import qualified Data.ByteString.Lazy.Internal as Lazy
+import Data.CaseInsensitive (CI, FoldCase)
+import qualified Data.CaseInsensitive as CI
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Ratio
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time
+import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Syntax
+import Prelude hiding (last, mapM, null, reverse)
+import Prelude.Unicode
+
+instance Lift ByteString where
+ lift bs = [| Strict.pack $(litE $ stringL $ Strict.unpack bs) |]
+
+instance Lift Lazy.ByteString where
+ lift = Lazy.foldrChunks f [| Lazy.Empty |]
+ where
+ f ∷ ByteString → Q Exp → Q Exp
+ f bs e = [| Lazy.Chunk $(lift bs) $e |]
+
+instance Lift Ascii where
+ lift a = [| A.unsafeFromByteString $(lift $ A.toByteString a) |]
+
+instance (Lift s, FoldCase s) ⇒ Lift (CI s) where
+ lift s = [| CI.mk $(lift $ CI.original s) |]
+
+instance Lift Text where
+ lift t = [| T.pack $(litE $ stringL $ T.unpack t) |]
+
+instance (Lift k, Lift v) ⇒ Lift (Map k v) where
+ lift m
+ | M.null m = [| M.empty |]
+ | otherwise = [| M.fromDistinctAscList $(liftPairs (M.toAscList m)) |]
+ where
+ liftPairs = listE ∘ map liftPair
+ liftPair (k, v) = tupE [lift k, lift v]
+
+instance Lift UTCTime where
+ lift (UTCTime {..})
+ = [| UTCTime $(lift utctDay) $(lift utctDayTime) |]
+
+instance Lift Day where
+ lift (ModifiedJulianDay {..})
+ = [| ModifiedJulianDay $(lift toModifiedJulianDay) |]
+
+instance Lift DiffTime where
+ lift dt = [| fromRational ($n % $d) ∷ DiffTime |]
+ where
+ n, d ∷ Q Exp
+ n = lift $ numerator $ toRational dt
+ d = lift $ denominator $ toRational dt
import Data.Maybe
import Data.Monoid.Unicode
import qualified Data.Sequence as S
-import Data.Sequence.Unicode hiding ((∅))
import qualified Data.Text as T
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Resource.Tree
+import Network.HTTP.Lucu.Utils
import Network.Socket
import Prelude.Unicode
import System.IO (hPutStrLn, stderr)
import Data.ByteString (ByteString)
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
-import Data.List
-import qualified Data.Map as M
+import Data.Collections
+import Data.List (intersperse, sort)
import Data.Maybe
import Data.Monoid
import Data.Monoid.Unicode
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.MIMEParams
import Network.HTTP.Lucu.MIMEType (MIMEType(..))
import qualified Network.HTTP.Lucu.MIMEType as MT
import Network.HTTP.Lucu.MIMEType.TH
import Network.HTTP.Lucu.Utils
import Network.Socket hiding (accept)
import Network.URI hiding (path)
+import Prelude hiding (any, drop, lookup, reverse)
import Prelude.Unicode
-- |Get the string representation of the address of remote host. If
Just a → return a
Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
- readMultipartFormData (MIMEParams m)
- = case M.lookup "boundary" m of
+ readMultipartFormData m
+ = case lookup "boundary" m of
Nothing
→ abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
Just boundary
import Data.Maybe
import Data.Monoid.Unicode
import Data.Sequence (Seq)
-import Data.Sequence.Unicode hiding ((∅))
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Utils
import Network.URI hiding (path)
{-# LANGUAGE
- OverloadedStrings
- , RecordWildCards
- , TemplateHaskell
+ FlexibleContexts
+ , OverloadedStrings
, UnicodeSyntax
#-}
-- |Utility functions used internally in this package.
, splitPathInfo
, trim
- , getLastModified
+ , (⊲)
+ , (⊳)
+ , (⋈)
+ , mapM
- , liftByteString
- , liftLazyByteString
- , liftAscii
- , liftCIAscii
- , liftText
- , liftMap
- , liftUTCTime
+ , getLastModified
)
where
-import Control.Applicative
-import Control.Monad
-import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
+import Control.Applicative hiding (empty)
+import Control.Monad hiding (mapM)
+import Data.Ascii (Ascii, AsciiBuilder)
import qualified Data.Ascii as A
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as Strict
-import qualified Data.ByteString.Lazy.Internal as Lazy
import Data.Char
-import Data.List hiding (last)
-import Data.Map (Map)
-import qualified Data.Map as M
+import Data.Collections
+import Data.Collections.BaseInstances ()
import Data.Monoid.Unicode
import Data.Ratio
-import Data.Text (Text)
-import qualified Data.Text as T
import Data.Time
import Data.Time.Clock.POSIX
-import Language.Haskell.TH.Lib
-import Language.Haskell.TH.Syntax
import Network.URI
-import Prelude hiding (last)
+import Prelude hiding (last, mapM, null, reverse)
import Prelude.Unicode
import System.Directory
import System.Time (ClockTime(..))
where
f = dropWhile isSpace
+infixr 5 ⊲
+-- | (B2;) = ('<|')
+--
+-- U+22B2, NORMAL SUBGROUP OF
+(⊲) ∷ Sequence α a ⇒ a → α → α
+(⊲) = (<|)
+
+infixl 5 ⊳
+-- | (B3;) = ('|>')
+--
+-- U+22B3, CONTAINS AS NORMAL SUBGROUP
+(⊳) ∷ Sequence α a ⇒ α → a → α
+(⊳) = (|>)
+
+infixr 5 ⋈
+-- | (C8;) = ('><')
+--
+-- U+22C8, BOWTIE
+(⋈) ∷ Sequence α a ⇒ α → α → α
+(⋈) = (><)
+
+-- |Generalised @mapM@ from any 'Foldable' to 'Unfoldable'. Why isn't
+-- this in the @collections-api@?
+mapM ∷ (Foldable α a, Unfoldable β b, Functor m, Monad m)
+ ⇒ (a → m b) → α → m β
+{-# INLINE mapM #-}
+mapM = flip foldrM empty ∘ (flip ((<$>) ∘ flip insert) ∘)
+
-- |Get the modification time of a given file.
getLastModified ∷ FilePath → IO UTCTime
getLastModified = (clockTimeToUTC <$>) ∘ getModificationTime
= posixSecondsToUTCTime
$ fromRational
$ sec % 1 + picoSec % (1000 ⋅ 1000 ⋅ 1000 ⋅ 1000)
-
--- |Convert a 'ByteString' to an 'Exp' representing it as a literal.
-liftByteString ∷ ByteString → Q Exp
-liftByteString bs
- = [| Strict.pack $(litE $ stringL $ Strict.unpack bs) |]
-
--- |Convert a 'Lazy.ByteString' to an 'Exp' representing it as a
--- literal.
-liftLazyByteString ∷ Lazy.ByteString → Q Exp
-liftLazyByteString = Lazy.foldrChunks f [| Lazy.Empty |]
- where
- f ∷ ByteString → Q Exp → Q Exp
- f bs e = [| Lazy.Chunk $(liftByteString bs) $e |]
-
--- |Convert an 'Ascii' to an 'Exp' representing it as a literal.
-liftAscii ∷ Ascii → Q Exp
-liftAscii a = [| A.unsafeFromByteString $(liftByteString $ A.toByteString a) |]
-
--- |Convert a 'CIAscii' to an 'Exp' representing it as a literal.
-liftCIAscii ∷ CIAscii → Q Exp
-liftCIAscii a = [| A.toCIAscii $(liftAscii $ A.fromCIAscii a) |]
-
--- |Convert a 'Text' to an 'Exp' representing it as a literal.
-liftText ∷ Text → Q Exp
-liftText t = [| T.pack $(litE $ stringL $ T.unpack t) |]
-
--- |Convert an arbitrary 'Map' to an 'Exp' representing it as a
--- literal, using a given key lifter and a value lifter.
-liftMap ∷ Eq k ⇒ (k → Q Exp) → (v → Q Exp) → Map k v → Q Exp
-liftMap liftK liftV m
- | M.null m = [| M.empty |]
- | otherwise = [| M.fromDistinctAscList $(liftPairs (M.toAscList m)) |]
- where
- liftPairs = listE ∘ map liftPair
- liftPair (k, v) = tupE [liftK k, liftV v]
-
--- |Convert an 'UTCTime' to an 'Exp' representing it as a literal.
-liftUTCTime ∷ UTCTime → Q Exp
-liftUTCTime (UTCTime {..})
- = [| UTCTime $(liftDay utctDay) $(liftDiffTime utctDayTime) |]
-
-liftDay ∷ Day → Q Exp
-liftDay (ModifiedJulianDay {..})
- = [| ModifiedJulianDay $(lift toModifiedJulianDay) |]
-
-liftDiffTime ∷ DiffTime → Q Exp
-liftDiffTime dt = [| fromRational ($n % $d) ∷ DiffTime |]
- where
- n, d ∷ Q Exp
- n = lift $ numerator $ toRational dt
- d = lift $ denominator $ toRational dt
projects / Lucu.git / commitdiff