diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## FLAC 0.2.1 + +* Maintenance release with more modern and minimal dependencies. + ## FLAC 0.2.0 * Got rid of `data-default-class` dependency. Now default values for various diff --git a/Codec/Audio/FLAC/Metadata.hs b/Codec/Audio/FLAC/Metadata.hs --- a/Codec/Audio/FLAC/Metadata.hs +++ b/Codec/Audio/FLAC/Metadata.hs @@ -1,6 +1,14 @@ +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + -- | -- Module : Codec.Audio.FLAC.Metadata --- Copyright : © 2016–2019 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -21,10 +29,9 @@ -- -- > import Codec.Audio.FLAC.Metadata -- > import Control.Monad.IO.Class (MonadIO (..)) --- > import Data.Default.Class -- > -- > main :: IO () --- > main = runFlacMeta def "/path/to/my/file.flac" $ do +-- > main = runFlacMeta defaultMetaSettings "/path/to/my/file.flac" $ do -- > retrieve SampleRate >>= liftIO . print -- > retrieve (VorbisComment Artist) >>= liftIO . print -- @@ -34,10 +41,9 @@ -- The next example shows how to set a couple of tags: -- -- > import Codec.Audio.FLAC.Metadata --- > import Data.Default.Class -- > -- > main :: IO () --- > main = runFlacMeta def "/path/to/my/file.flac" $ do +-- > main = runFlacMeta defaultMetaSettings "/path/to/my/file.flac" $ do -- > VorbisComment Artist =-> Just "Alexander Scriabin" -- > VorbisComment Title =-> Just "Sonata №9 “Black Mass”, Op. 68" -- > VorbisComment Date =-> Nothing @@ -58,67 +64,56 @@ -- not possible to choose other interface (such as level 0 and 1). However, -- this should not be of any concern to the end-user, as the level 2 -- supports more functionality than the other levels. - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstrainedClassMethods #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} - -#if MIN_VERSION_base(4,9,0) -{-# LANGUAGE UndecidableInstances #-} -#else -{-# OPTIONS_GHC -fno-warn-missing-methods #-} -#endif - module Codec.Audio.FLAC.Metadata ( -- * Metadata manipulation API - FlacMeta - , MetaSettings (..) - , defaultMetaSettings - , MetaException (..) - , MetaChainStatus (..) - , runFlacMeta + FlacMeta, + MetaSettings (..), + defaultMetaSettings, + MetaException (..), + MetaChainStatus (..), + runFlacMeta, + -- * Meta values - , MetaValue (..) - , MinBlockSize (..) - , MaxBlockSize (..) - , MinFrameSize (..) - , MaxFrameSize (..) - , SampleRate (..) - , Channels (..) - , ChannelMask (..) - , BitsPerSample (..) - , TotalSamples (..) - , FileSize (..) - , BitRate (..) - , MD5Sum (..) - , Duration (..) - , Application (..) - , ApplicationId - , mkApplicationId - , unApplicationId - , SeekTable (..) - , SeekPoint (..) - , VorbisVendor (..) - , VorbisComment (..) - , VorbisField (..) - , CueSheet (..) - , Picture (..) - , PictureType (..) - , PictureData (..) + MetaValue (..), + MinBlockSize (..), + MaxBlockSize (..), + MinFrameSize (..), + MaxFrameSize (..), + SampleRate (..), + Channels (..), + ChannelMask (..), + BitsPerSample (..), + TotalSamples (..), + FileSize (..), + BitRate (..), + MD5Sum (..), + Duration (..), + Application (..), + ApplicationId, + mkApplicationId, + unApplicationId, + SeekTable (..), + SeekPoint (..), + VorbisVendor (..), + VorbisComment (..), + VorbisField (..), + CueSheet (..), + Picture (..), + PictureType (..), + PictureData (..), + -- * Extra functionality - , wipeVorbisComment - , wipeApplications - , wipeSeekTable - , wipeCueSheets - , wipePictures + wipeVorbisComment, + wipeApplications, + wipeSeekTable, + wipeCueSheets, + wipePictures, + -- * Debugging and testing - , MetadataType (..) - , getMetaChain - , isMetaChainModified ) + MetadataType (..), + getMetaChain, + isMetaChainModified, + ) where import Codec.Audio.FLAC.Metadata.Internal.Level2Interface @@ -128,31 +123,24 @@ import Codec.Audio.Wave import Control.Monad import Control.Monad.Catch -import Control.Monad.Except import Control.Monad.Reader import Data.Bool (bool) import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as B8 import Data.Char (toUpper) import Data.IORef +import Data.Kind (Constraint, Type) import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE import Data.Maybe (fromJust, listToMaybe) import Data.Set (Set) +import Data.Set qualified as E import Data.Text (Text) import Data.Vector (Vector) +import Data.Vector qualified as V import Foreign hiding (void) -import Numeric.Natural -import System.IO -import qualified Data.ByteString.Char8 as B8 -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E -import qualified Data.Vector as V - -#if MIN_VERSION_base(4,9,0) -import Data.Kind (Constraint) import GHC.TypeLits -#else -import GHC.Exts (Constraint) -#endif +import System.IO ---------------------------------------------------------------------------- -- Metadata manipulation API @@ -160,65 +148,67 @@ -- | An opaque monad for reading and writing of FLAC metadata. The monad is -- the home for 'retrieve' and @('=->')@ functions and can be run with -- 'runFlacMeta'. - -newtype FlacMeta a = FlacMeta { unFlacMeta :: Inner a } - deriving ( Functor - , Applicative - , Monad - , MonadIO - , MonadThrow - , MonadCatch - , MonadMask ) +newtype FlacMeta a = FlacMeta {unFlacMeta :: Inner a} + deriving + ( Functor, + Applicative, + Monad, + MonadIO, + MonadThrow, + MonadCatch, + MonadMask + ) -- | A non-public shortcut for the inner monad stack of 'FlacMeta'. - type Inner a = ReaderT Context IO a -- | The context that 'Inner' passes around. - data Context = Context - { metaChain :: MetaChain -- ^ Metadata chain - , metaModified :: IORef Bool -- ^ “Modified” flag - , metaFileSize :: Natural -- ^ Size of target file + { -- | Metadata chain + metaChain :: MetaChain, + -- | “Modified” flag + metaModified :: IORef Bool, + -- | Size of target file + metaFileSize :: Natural } -- | Settings that control how metadata is written in FLAC file. - data MetaSettings = MetaSettings - { metaAutoVacuum :: !Bool - -- ^ Whether to traverse all metadata blocks just before padding sorting + { -- | Whether to traverse all metadata blocks just before padding sorting -- (if enabled, see 'metaSortPadding') and writing data to a file, -- deleting all metadata blocks that appear to be empty, e.g. vorbis -- comment block without any comments (tags) in it. Default value: -- 'True'. - , metaSortPadding :: !Bool - -- ^ Whether to attempt to sort and consolidate all padding at the end + metaAutoVacuum :: !Bool, + -- | Whether to attempt to sort and consolidate all padding at the end -- of metadata section. The main purpose of this is that the padding can -- be truncated if necessary to get more space so we can overwrite -- metadata blocks in place instead of overwriting the entire FLAC file. -- Default value: 'True'. - , metaUsePadding :: !Bool - -- ^ This setting enables truncation of last padding metadata block if + metaSortPadding :: !Bool, + -- | This setting enables truncation of last padding metadata block if -- it allows to overwrite metadata in place instead of overwriting the -- entire file. Default value: 'True'. - , metaPreserveFileStats :: !Bool - -- ^ If 'True', the owner and modification time will be preserved even + metaUsePadding :: !Bool, + -- | If 'True', the owner and modification time will be preserved even -- if a new FLAC file is written (this is for the cases when we need to -- write entire FLAC file and thus a copy of the file is written). -- Default value: 'True'. - } deriving (Show, Read, Eq, Ord) + metaPreserveFileStats :: !Bool + } + deriving (Show, Read, Eq, Ord) -- | Default 'MetaSettings'. -- -- @since 0.2.0 - defaultMetaSettings :: MetaSettings -defaultMetaSettings = MetaSettings - { metaAutoVacuum = True - , metaSortPadding = True - , metaUsePadding = True - , metaPreserveFileStats = True - } +defaultMetaSettings = + MetaSettings + { metaAutoVacuum = True, + metaSortPadding = True, + metaUsePadding = True, + metaPreserveFileStats = True + } -- | Run an action that manipulates FLAC metadata. 'MetaSettings' control -- subtle and rather low-level details of metadata editing, just pass 'def' @@ -233,18 +223,22 @@ -- -- If a problem occurs, 'MetaException' is thrown with attached -- 'MetaChainStatus' that should help investigating what went wrong. - -runFlacMeta :: MonadIO m - => MetaSettings -- ^ Settings to use - -> FilePath -- ^ File to operate on - -> FlacMeta a -- ^ Actions to perform - -> m a -- ^ The result +runFlacMeta :: + (MonadIO m) => + -- | Settings to use + MetaSettings -> + -- | File to operate on + FilePath -> + -- | Actions to perform + FlacMeta a -> + -- | The result + m a runFlacMeta MetaSettings {..} path m = liftIO . withChain $ \metaChain -> do metaModified <- newIORef False metaFileSize <- fromIntegral <$> withFile path ReadMode hFileSize flip runReaderT Context {..} $ do liftBool (chainRead metaChain path) - result <- unFlacMeta m + result <- unFlacMeta m modified <- liftIO (readIORef metaModified) when modified $ do when metaAutoVacuum applyVacuum @@ -263,121 +257,95 @@ -- which is also useful. For example, 'Duration' and 'BitRate' are not read -- from FLAC file metadata directly, but defined in terms of other -- attributes. - class MetaValue a where - -- | Type of data that corresponds to this metadata value. For example -- 'SampleRate' is represented by 'Word32' value in this library, and so -- @'MetaType' 'SampleRate' ~ 'Word32'@. - - type MetaType a :: * + type MetaType a :: Type -- | Associated type of the kind 'Constraint' that controls whether a -- particular piece of metadata is writable or not. - type MetaWritable a :: Constraint -- | Given value that determines what to read, read it and return. Some -- metadata may be missing, in that case the function typically returns a -- value wrapped in 'Maybe'. - retrieve :: a -> FlacMeta (MetaType a) -- | Given a value that determines what to write and a value to write, -- add\/replace a piece of metadata information. This is how you edit - -- metadata. To delete something, set it to 'Nothing' (well, it should be + -- metadata. To delete something, set it to 'Nothing' (it should be -- something that /can be missing/, for example you cannot delete the -- 'SampleRate' attribute). If 'MetaWritable' is defined, this method must -- be defined as well. - - (=->) :: MetaWritable a => a -> MetaType a -> FlacMeta () + (=->) :: (MetaWritable a) => a -> MetaType a -> FlacMeta () _ =-> _ = error "Codec.Audio.FLAC.Metadata.(=->) is not defined" infix 1 =-> -#if MIN_VERSION_base(4,9,0) type NotWritable = 'Text "This attribute is not writable." -#endif -- | Minimal block size in samples used in the stream. -- -- __Read-only__ attribute represented as a 'Word32'. - data MinBlockSize = MinBlockSize instance MetaValue MinBlockSize where type MetaType MinBlockSize = Word32 -#if MIN_VERSION_base(4,9,0) type MetaWritable MinBlockSize = TypeError NotWritable -#endif retrieve MinBlockSize = inStreamInfo getMinBlockSize -- | Maximal block size in samples used in the stream. Equality of minimum -- block size and maximum block size implies a fixed-blocksize stream. -- -- __Read-only__ attribute represented as a 'Word32'. - data MaxBlockSize = MaxBlockSize instance MetaValue MaxBlockSize where type MetaType MaxBlockSize = Word32 -#if MIN_VERSION_base(4,9,0) type MetaWritable MaxBlockSize = TypeError NotWritable -#endif retrieve MaxBlockSize = inStreamInfo getMaxBlockSize -- | Minimal frame size in bytes used in the stream. May be 0 to imply the -- value is not known. -- -- __Read-only__ attribute represented as a 'Word32'. - data MinFrameSize = MinFrameSize instance MetaValue MinFrameSize where type MetaType MinFrameSize = Word32 -#if MIN_VERSION_base(4,9,0) type MetaWritable MinFrameSize = TypeError NotWritable -#endif retrieve MinFrameSize = inStreamInfo getMinFrameSize -- | Maximal frame size in bytes used in the stream. May be 0 to imply the -- value is not known. -- -- __Read-only__ attribute represented as a 'Word32'. - data MaxFrameSize = MaxFrameSize instance MetaValue MaxFrameSize where type MetaType MaxFrameSize = Word32 -#if MIN_VERSION_base(4,9,0) type MetaWritable MaxFrameSize = TypeError NotWritable -#endif retrieve MaxFrameSize = inStreamInfo getMaxFrameSize -- | Sample rate in Hz. -- -- __Read-only__ attribute represented as a 'Word32'. - data SampleRate = SampleRate instance MetaValue SampleRate where type MetaType SampleRate = Word32 -#if MIN_VERSION_base(4,9,0) type MetaWritable SampleRate = TypeError NotWritable -#endif retrieve SampleRate = inStreamInfo getSampleRate -- | Number of channels. FLAC supports from 1 to 8 channels. -- -- __Read-only__ attribute represented as a 'Word32'. - data Channels = Channels instance MetaValue Channels where type MetaType Channels = Word32 -#if MIN_VERSION_base(4,9,0) type MetaWritable Channels = TypeError NotWritable -#endif retrieve Channels = inStreamInfo getChannels -- | Channel mask specifying which speaker positions are present. This is @@ -385,14 +353,11 @@ -- in the FLAC specification. -- -- __Read-only__ attribute represented as @'Set' 'SpeakerPosition'@. - data ChannelMask = ChannelMask instance MetaValue ChannelMask where type MetaType ChannelMask = Set SpeakerPosition -#if MIN_VERSION_base(4,9,0) type MetaWritable ChannelMask = TypeError NotWritable -#endif retrieve ChannelMask = toChannelMask <$> retrieve Channels -- | Bits per sample (sample depth). FLAC supports from 4 to 32 bits per @@ -400,14 +365,11 @@ -- bits per sample. -- -- __Read-only__ attribute represented as a 'Word32'. - data BitsPerSample = BitsPerSample instance MetaValue BitsPerSample where type MetaType BitsPerSample = Word32 -#if MIN_VERSION_base(4,9,0) type MetaWritable BitsPerSample = TypeError NotWritable -#endif retrieve BitsPerSample = inStreamInfo getBitsPerSample -- | Total number of samples in audio stream. “Samples” means inter-channel @@ -416,40 +378,31 @@ -- number of total samples is unknown. -- -- __Read-only__ attribute represented as a 'Word64'. - data TotalSamples = TotalSamples instance MetaValue TotalSamples where type MetaType TotalSamples = Word64 -#if MIN_VERSION_base(4,9,0) type MetaWritable TotalSamples = TypeError NotWritable -#endif retrieve TotalSamples = inStreamInfo getTotalSamples -- | File size in bytes. -- -- __Read-only__ attribute represented as a 'Natural'. - data FileSize = FileSize instance MetaValue FileSize where type MetaType FileSize = Natural -#if MIN_VERSION_base(4,9,0) type MetaWritable FileSize = TypeError NotWritable -#endif retrieve FileSize = FlacMeta (asks metaFileSize) -- | Bit rate in kilo-bits per second (kbps). -- -- __Read-only__ attribute represented as a 'Word32'. - data BitRate = BitRate instance MetaValue BitRate where type MetaType BitRate = Word32 -#if MIN_VERSION_base(4,9,0) type MetaWritable BitRate = TypeError NotWritable -#endif retrieve BitRate = do fileSize <- fromIntegral <$> retrieve FileSize duration <- retrieve Duration @@ -461,30 +414,24 @@ -- not result in an invalid bitstream. -- -- __Read-only__ attribute represented as a 'ByteString' of length 16. - data MD5Sum = MD5Sum instance MetaValue MD5Sum where type MetaType MD5Sum = ByteString -#if MIN_VERSION_base(4,9,0) type MetaWritable MD5Sum = TypeError NotWritable -#endif retrieve MD5Sum = inStreamInfo getMd5Sum -- | Duration in seconds. -- -- __Read-only__ attribute represented as a 'Double'. - data Duration = Duration instance MetaValue Duration where type MetaType Duration = Double -#if MIN_VERSION_base(4,9,0) type MetaWritable Duration = TypeError NotWritable -#endif retrieve Duration = do totalSamples <- fromIntegral <$> retrieve TotalSamples - sampleRate <- fromIntegral <$> retrieve SampleRate + sampleRate <- fromIntegral <$> retrieve SampleRate return (totalSamples / sampleRate) -- | Application metadata. The 'ApplicationId' argument to 'Application' @@ -496,7 +443,6 @@ -- . -- -- __Writable__ optional attribute represented as a @'Maybe' 'ByteString'@. - data Application = Application ApplicationId instance MetaValue Application where @@ -522,7 +468,6 @@ -- -- __Writable__ optional attribute represented as a @'Maybe' ('Vector' -- 'SeekPoint')@. - data SeekTable = SeekTable instance MetaValue SeekTable where @@ -543,12 +488,11 @@ -- | Vorbis “vendor” comment. When “Vorbis Comment” metadata block is -- present, the “vendor” entry is always in there, so when you delete it (by --- @'VorbisVendor' '=->' 'Nothing'@), you really set it to an empty string +-- @'VorbisVendor' '=->' 'Nothing'@), you really set it to the empty string -- (which is enough to trigger auto vacuum feature if no other entries are -- detected, see 'metaAutoVacuum'). -- -- __Writable__ optional attribute represented as a @'Maybe' 'Text'@. - data VorbisVendor = VorbisVendor instance MetaValue VorbisVendor where @@ -577,59 +521,80 @@ -- fields. The library also supports the standard ReplayGain comments. -- -- __Writable__ optional attribute represented as a @'Maybe' 'Text'@. - data VorbisComment = VorbisComment VorbisField -- | Enumeration of all supported filed names to index vorbis comment -- entries. - data VorbisField - = Title -- ^ Track\/work name. - | Version -- ^ The version field may be used to differentiate - -- multiple versions of the same track title in a - -- single collection (e.g. remix info). - | Album -- ^ The collection name to which this track belongs. - | TrackNumber -- ^ The track number of this piece if part of a - -- specific larger collection or album. - | TrackTotal -- ^ Total number of tracks in the collection this - -- track belongs to. - | DiscNumber -- ^ Disc number in a multi-disc release. - | DiscTotal -- ^ Total number of discs in a multi-disc release. - | Artist -- ^ The artist generally considered responsible for - -- the work. In popular music this is usually the - -- performing band or singer. For classical music it - -- would be the composer. For an audio book it would - -- be the author of the original text. - | Performer -- ^ The artist(s) who performed the work. In - -- classical music this would be the conductor, - -- orchestra, soloists. In an audio book it would be - -- the actor who did the reading. In popular music - -- this is typically the same as the 'Artist' and is - -- omitted. - | Copyright -- ^ Copyright attribution, e.g., “2001 Nobody's - -- Band” or “1999 Jack Moffitt”. - | License -- ^ License information, e.g., “All Rights - -- Reserved”, “Any Use Permitted”, a URL to a license - -- such as a Creative Commons license or the EFF Open - -- Audio License, etc. - | Organization -- ^ Name of the organization producing the track - -- (i.e. the “record label”). - | Description -- ^ A short text description of the contents. - | Genre -- ^ A short text indication of music genre. - | Date -- ^ Date the track was recorded, usually year. - | Location -- ^ Location where track was recorded. - | Contact -- ^ Contact information for the creators or - -- distributors of the track. This could be a URL, an - -- email address, the physical address of the - -- producing label. - | ISRC -- ^ ISRC number for the track, see - -- . - | Rating -- ^ Rating, usually mapped as 1–5 stars with actual - -- values “20”, “40”, “60”, “80”, “100” stored. - | RGTrackPeak -- ^ Replay gain track peak, e.g. “0.99996948”. - | RGTrackGain -- ^ Replay gain track gain, e.g. “-7.89 dB”. - | RGAlbumPeak -- ^ Replay gain album peak, e.g. “0.99996948”. - | RGAlbumGain -- ^ Replay gain album gain, e.g. “-7.89 dB”. + = -- | Track\/work name. + Title + | -- | The version field may be used to differentiate + -- multiple versions of the same track title in a + -- single collection (e.g. remix info). + Version + | -- | The collection name to which this track belongs. + Album + | -- | The track number of this piece if part of a + -- specific larger collection or album. + TrackNumber + | -- | Total number of tracks in the collection this + -- track belongs to. + TrackTotal + | -- | Disc number in a multi-disc release. + DiscNumber + | -- | Total number of discs in a multi-disc release. + DiscTotal + | -- | The artist generally considered responsible for + -- the work. In popular music this is usually the + -- performing band or singer. For classical music it + -- would be the composer. For an audio book it would + -- be the author of the original text. + Artist + | -- | The artist(s) who performed the work. In + -- classical music this would be the conductor, + -- orchestra, soloists. In an audio book it would be + -- the actor who did the reading. In popular music + -- this is typically the same as the 'Artist' and is + -- omitted. + Performer + | -- | Copyright attribution, e.g., “2001 Nobody's + -- Band” or “1999 Jack Moffitt”. + Copyright + | -- | License information, e.g., “All Rights + -- Reserved”, “Any Use Permitted”, a URL to a license + -- such as a Creative Commons license or the EFF Open + -- Audio License, etc. + License + | -- | Name of the organization producing the track + -- (i.e. the “record label”). + Organization + | -- | A short text description of the contents. + Description + | -- | A short text indication of music genre. + Genre + | -- | Date the track was recorded, usually year. + Date + | -- | Location where track was recorded. + Location + | -- | Contact information for the creators or + -- distributors of the track. This could be a URL, an + -- email address, the physical address of the + -- producing label. + Contact + | -- | ISRC number for the track, see + -- . + ISRC + | -- | Rating, usually mapped as 1–5 stars with actual + -- values “20”, “40”, “60”, “80”, “100” stored. + Rating + | -- | Replay gain track peak, e.g. “0.99996948”. + RGTrackPeak + | -- | Replay gain track gain, e.g. “-7.89 dB”. + RGTrackGain + | -- | Replay gain album peak, e.g. “0.99996948”. + RGAlbumPeak + | -- | Replay gain album gain, e.g. “-7.89 dB”. + RGAlbumGain deriving (Show, Read, Eq, Ord, Bounded, Enum) instance MetaValue VorbisComment where @@ -656,7 +621,6 @@ -- to manipulate 'CueSheetData' and 'CueTrack's. -- -- __Writable__ optional attribute represented as a @'Maybe' 'CueSheetData'@. - data CueSheet = CueSheet instance MetaValue CueSheet where @@ -686,7 +650,6 @@ -- with 'PictureData' easier using the @Juicy-Pixels@ library. -- -- __Writable__ optional attribute represented as a @'Maybe' 'PictureData'@. - data Picture = Picture PictureType instance MetaValue Picture where @@ -709,7 +672,6 @@ -- Extra functionality -- | Delete all “Vorbis comment” metadata blocks. - wipeVorbisComment :: FlacMeta () wipeVorbisComment = void . FlacMeta . withMetaBlock VorbisCommentBlock $ \i -> do @@ -717,7 +679,6 @@ setModified -- | Delete all “Application” metadata blocks. - wipeApplications :: FlacMeta () wipeApplications = void . FlacMeta . withMetaBlock ApplicationBlock $ \i -> do @@ -725,7 +686,6 @@ setModified -- | Delete all “Seek table” metadata blocks. - wipeSeekTable :: FlacMeta () wipeSeekTable = void . FlacMeta . withMetaBlock SeekTableBlock $ \i -> do @@ -733,7 +693,6 @@ setModified -- | Delete all “CUE sheet” metadata blocks. - wipeCueSheets :: FlacMeta () wipeCueSheets = void . FlacMeta . withMetaBlock CueSheetBlock $ \i -> do @@ -741,7 +700,6 @@ setModified -- | Delete all “Picture” metadata blocks. - wipePictures :: FlacMeta () wipePictures = void . FlacMeta . withMetaBlock PictureBlock $ \i -> do @@ -753,7 +711,6 @@ -- | Return a list of all 'MetadataType's of metadata blocks detected in -- order. - getMetaChain :: FlacMeta (NonEmpty MetadataType) getMetaChain = FlacMeta $ do chain <- asks metaChain @@ -762,7 +719,6 @@ -- | Return 'True' if actions in current 'FlacMeta' context have modified -- FLAC metadata. If so, the FLAC file will be updated to reflect these -- changes on the way out from the 'FlacMeta' monad. - isMetaChainModified :: FlacMeta Bool isMetaChainModified = FlacMeta (asks metaModified >>= liftIO . readIORef) @@ -772,7 +728,6 @@ -- | A helper that takes a function that extracts something from 'Metadata' -- block. It finds the 'StreamInfoBlock', gets 'Metadata' from it and -- applies given function to get the final value. - inStreamInfo :: (Metadata -> IO a) -> FlacMeta a inStreamInfo f = FlacMeta . fmap fromJust . withMetaBlock StreamInfoBlock $ @@ -784,34 +739,40 @@ -- was found, 'Nothing' otherwise. If there are several blocks of the given -- type, action will be performed for each of them, but only the first -- result will be returned. - -withMetaBlock - :: MetadataType -- ^ Type of block to find - -> (MetaIterator -> Inner a) -- ^ What to do if such block found - -> Inner (Maybe a) -- ^ Result in 'Just' if block was found +withMetaBlock :: + -- | Type of block to find + MetadataType -> + -- | What to do if such block found + (MetaIterator -> Inner a) -> + -- | Result in 'Just' if block was found + Inner (Maybe a) withMetaBlock = withMetaBlockGen noCheck where noCheck _ = return True -- | Just like 'withMetaBlock', but creates a new block of requested type if -- no block of such type can be found. - -withMetaBlock' - :: MetadataType -- ^ Type of block to find - -> (MetaIterator -> Inner a) -- ^ What to do if such block found - -> Inner a -- ^ Result +withMetaBlock' :: + -- | Type of block to find + MetadataType -> + -- | What to do if such block found + (MetaIterator -> Inner a) -> + -- | Result + Inner a withMetaBlock' = withMetaBlockGen' noCheck noSet where noCheck _ = return True - noSet _ = return () + noSet _ = return () -- | The same as 'withMetaBlock' but it searches for a block of type -- 'ApplicationBlock' that has specified application id. - -withApplicationBlock - :: ApplicationId -- ^ Application id to find - -> (MetaIterator -> Inner a) -- ^ What to do if such block found - -> Inner (Maybe a) -- ^ Result in 'Just' if block was found +withApplicationBlock :: + -- | Application id to find + ApplicationId -> + -- | What to do if such block found + (MetaIterator -> Inner a) -> + -- | Result in 'Just' if block was found + Inner (Maybe a) withApplicationBlock givenId = withMetaBlockGen idCheck ApplicationBlock where @@ -819,35 +780,41 @@ -- | Just like 'withApplicationBlock', but creates a new 'ApplicationBlock' -- with given id if no such block can be found. - -withApplicationBlock' - :: ApplicationId -- ^ Application id to find - -> (MetaIterator -> Inner a) -- ^ What to do if such block found - -> Inner a -- ^ Result +withApplicationBlock' :: + -- | Application id to find + ApplicationId -> + -- | What to do if such block found + (MetaIterator -> Inner a) -> + -- | Result + Inner a withApplicationBlock' givenId = withMetaBlockGen' idCheck setId ApplicationBlock where - idCheck = fmap (== givenId) . liftIO . getApplicationId + idCheck = fmap (== givenId) . liftIO . getApplicationId setId block = liftIO (setApplicationId block givenId) -- | The same as 'withMetaBlock', but it searches for a block of type -- 'PictureBlock' that has specific 'PictureType'. - -withPictureBlock - :: PictureType -- ^ Picture type to find - -> (MetaIterator -> Inner a) -- ^ What to do if such block found - -> Inner (Maybe a) -- ^ Result in 'Just' if block was found +withPictureBlock :: + -- | Picture type to find + PictureType -> + -- | What to do if such block found + (MetaIterator -> Inner a) -> + -- | Result in 'Just' if block was found + Inner (Maybe a) withPictureBlock givenType = withMetaBlockGen typeCheck PictureBlock where typeCheck = fmap (== givenType) . liftIO . getPictureType -- | Just like 'withPictureBlock', but creates a new 'PictureBlock' with -- given 'PictureType' if no such block can be found. - -withPictureBlock' - :: PictureType -- ^ Picture type to find - -> (MetaIterator -> Inner a) -- ^ What to do if such block found - -> Inner a -- ^ Result in 'Just' +withPictureBlock' :: + -- | Picture type to find + PictureType -> + -- | What to do if such block found + (MetaIterator -> Inner a) -> + -- | Result in 'Just' + Inner a withPictureBlock' givenType = withMetaBlockGen' typeCheck setType PictureBlock where @@ -855,12 +822,15 @@ setType block = liftIO (setPictureType block givenType) -- | A generic building block for 'withMetaBlock'-like helpers. - -withMetaBlockGen - :: (Metadata -> Inner Bool) -- ^ Additional check on 'Metadata' block - -> MetadataType -- ^ Type of block to find - -> (MetaIterator -> Inner a) -- ^ What to do if such block found - -> Inner (Maybe a) -- ^ Result in 'Just' if block was found +withMetaBlockGen :: + -- | Additional check on 'Metadata' block + (Metadata -> Inner Bool) -> + -- | Type of block to find + MetadataType -> + -- | What to do if such block found + (MetaIterator -> Inner a) -> + -- | Result in 'Just' if block was found + Inner (Maybe a) withMetaBlockGen check givenType f = do chain <- asks metaChain fmap listToMaybe . withIterator chain $ \i -> do @@ -875,20 +845,19 @@ else return Nothing -- | A generic building block for 'withMetaBlock''-like helpers. - -withMetaBlockGen' - :: (Metadata -> Inner Bool) - -- ^ Additional check on 'Metadata' block - -> (Metadata -> Inner ()) - -- ^ Set parameters of newly created block before calling the main callback - -> MetadataType - -- ^ Type of block to find - -> (MetaIterator -> Inner a) - -- ^ What to do if such block found (main callback) - -> Inner a +withMetaBlockGen' :: + -- | Additional check on 'Metadata' block + (Metadata -> Inner Bool) -> + -- | Set parameters of newly created block before calling the main callback + (Metadata -> Inner ()) -> + -- | Type of block to find + MetadataType -> + -- | What to do if such block found (main callback) + (MetaIterator -> Inner a) -> + Inner a withMetaBlockGen' check setParam givenType f = do chain <- asks metaChain - res <- withMetaBlockGen check givenType f + res <- withMetaBlockGen check givenType f case res of Nothing -> fmap head . withIterator chain $ \i -> do actual <- liftIO (iteratorGetBlockType i) @@ -896,30 +865,28 @@ then let acquire = liftMaybe (objectNew givenType) release = liftIO . objectDelete - in do - bracketOnError acquire release $ \block -> do - setParam block - liftBool (iteratorInsertBlockAfter i block) - Just <$> f i + in do + bracketOnError acquire release $ \block -> do + setParam block + liftBool (iteratorInsertBlockAfter i block) + Just <$> f i else return Nothing Just x -> return x -- | Go through all metadata blocks and delete empty ones. - applyVacuum :: Inner () applyVacuum = do chain <- asks metaChain void . withIterator chain $ \i -> do blockType <- liftIO (iteratorGetBlockType i) - block <- liftIO (iteratorGetBlock i) - empty <- liftIO (isMetaBlockEmpty blockType block) + block <- liftIO (iteratorGetBlock i) + empty <- liftIO (isMetaBlockEmpty blockType block) when empty $ liftBool (iteratorDeleteBlock i) return Nothing -- | Determine if a given 'Metadata' block is empty. - -isMetaBlockEmpty :: MonadIO m => MetadataType -> Metadata -> m Bool +isMetaBlockEmpty :: (MonadIO m) => MetadataType -> Metadata -> m Bool isMetaBlockEmpty SeekTableBlock block = V.null <$> liftIO (getSeekPoints block) isMetaBlockEmpty VorbisCommentBlock block = @@ -928,33 +895,28 @@ -- | Lift an action that may return 'Nothing' on failure into 'Inner' monad -- taking care of error reporting. - liftMaybe :: IO (Maybe a) -> Inner a liftMaybe m = liftIO m >>= maybe throwStatus return -- | Lift an action that returns 'False' on failure into 'Inner' monad -- taking care of error reporting. - liftBool :: IO Bool -> Inner () liftBool m = liftIO m >>= bool throwStatus (return ()) -- | Get 'MetaChainStatus' and throw it immediately. - throwStatus :: Inner a throwStatus = do - chain <- asks metaChain + chain <- asks metaChain status <- liftIO (chainStatus chain) throwM (MetaGeneralProblem status) -- | Specify that the metadata chain has been modified. - setModified :: Inner () setModified = do modified <- asks metaModified liftIO (writeIORef modified True) -- | Map 'VorbisField' to its ASCII name in the form of a 'ByteString'. - vorbisFieldName :: VorbisField -> ByteString vorbisFieldName RGTrackPeak = "REPLAYGAIN_TRACK_PEAK" vorbisFieldName RGTrackGain = "REPLAYGAIN_TRACK_GAIN" @@ -964,16 +926,15 @@ -- | Map the number of channels to a 'Set' of 'SpeakerPosition's as per FLAC -- specification. - toChannelMask :: Word32 -> Set SpeakerPosition toChannelMask n = case n of 0 -> E.empty 1 -> speakerMono 2 -> speakerStereo - 3 -> E.fromList [SpeakerFrontLeft,SpeakerFrontRight,SpeakerFrontCenter] + 3 -> E.fromList [SpeakerFrontLeft, SpeakerFrontRight, SpeakerFrontCenter] 4 -> speakerQuad 5 -> E.insert SpeakerFrontCenter speakerQuad 6 -> speaker5_1 7 -> E.insert SpeakerBackCenter speaker5_1Surround 8 -> speaker7_1Surround - x -> E.fromList $ take (fromIntegral x) [minBound..maxBound] + x -> E.fromList $ take (fromIntegral x) [minBound .. maxBound] diff --git a/Codec/Audio/FLAC/Metadata/CueSheet.hs b/Codec/Audio/FLAC/Metadata/CueSheet.hs --- a/Codec/Audio/FLAC/Metadata/CueSheet.hs +++ b/Codec/Audio/FLAC/Metadata/CueSheet.hs @@ -1,6 +1,6 @@ -- | -- Module : Codec.Audio.FLAC.Metadata.CueSheet --- Copyright : © 2016–2019 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -8,12 +8,12 @@ -- Portability : portable -- -- This module exports the 'CueSheetData' and 'CueTrack' data types, which --- are rarely needed, and thus should not “contaminate” the --- "Codec.Audio.Metadata" module with potentially conflicting names. - +-- are rarely needed, and thus should not congest the "Codec.Audio.Metadata" +-- module with potentially conflicting names. module Codec.Audio.FLAC.Metadata.CueSheet - ( CueSheetData (..) - , CueTrack (..) ) + ( CueSheetData (..), + CueTrack (..), + ) where import Codec.Audio.FLAC.Metadata.Internal.Types diff --git a/Codec/Audio/FLAC/Metadata/Internal/Level2Interface.hs b/Codec/Audio/FLAC/Metadata/Internal/Level2Interface.hs --- a/Codec/Audio/FLAC/Metadata/Internal/Level2Interface.hs +++ b/Codec/Audio/FLAC/Metadata/Internal/Level2Interface.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE LambdaCase #-} + -- | -- Module : Codec.Audio.FLAC.Metadata.Internal.Level2Interface --- Copyright : © 2016–2019 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -11,25 +15,22 @@ -- FLAC metadata interface, see: -- -- . - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE LambdaCase #-} - module Codec.Audio.FLAC.Metadata.Internal.Level2Interface ( -- * Chain - withChain - , chainStatus - , chainRead - , chainWrite - , chainSortPadding + withChain, + chainStatus, + chainRead, + chainWrite, + chainSortPadding, + -- * Iterator - , withIterator - , iteratorGetBlockType - , iteratorGetBlock - , iteratorSetBlock - , iteratorDeleteBlock - , iteratorInsertBlockAfter ) + withIterator, + iteratorGetBlockType, + iteratorGetBlock, + iteratorSetBlock, + iteratorDeleteBlock, + iteratorInsertBlockAfter, + ) where import Codec.Audio.FLAC.Metadata.Internal.Types @@ -47,16 +48,15 @@ -- -- If memory for the chain cannot be allocated, corresponding -- 'MetaException' is raised. - withChain :: (MetaChain -> IO a) -> IO a withChain f = bracket chainNew (mapM_ chainDelete) $ \case - Nothing -> throwM - (MetaGeneralProblem MetaChainStatusMemoryAllocationError) + Nothing -> + throwM + (MetaGeneralProblem MetaChainStatusMemoryAllocationError) Just x -> f x -- | Create a new 'MetaChain'. In the case of memory allocation problem -- 'Nothing' is returned. - chainNew :: IO (Maybe MetaChain) chainNew = maybePtr <$> c_chain_new @@ -65,7 +65,6 @@ -- | Free a 'MetaChain' instance. Delete the object pointed to by -- 'MetaChain'. - chainDelete :: MetaChain -> IO () chainDelete = c_chain_delete @@ -74,7 +73,6 @@ -- | Check status of a given 'MetaChain'. This can be used to find out what -- went wrong. It also resets status to 'MetaChainStatusOK'. - chainStatus :: MetaChain -> IO MetaChainStatus chainStatus = fmap toEnum' . c_chain_status @@ -83,7 +81,6 @@ -- | Read all metadata from a FLAC file into the chain. Return 'False' if -- something went wrong. - chainRead :: MetaChain -> FilePath -> IO Bool chainRead chain path = withCString path (c_chain_read chain) @@ -91,12 +88,15 @@ c_chain_read :: MetaChain -> CString -> IO Bool -- | Write all metadata out to the FLAC file. - -chainWrite - :: MetaChain -- ^ The chain to write - -> Bool -- ^ Whether to use padding - -> Bool -- ^ Whether to preserve file stats - -> IO Bool -- ^ 'False' if something went wrong +chainWrite :: + -- | The chain to write + MetaChain -> + -- | Whether to use padding + Bool -> + -- | Whether to preserve file stats + Bool -> + -- | 'False' if something went wrong + IO Bool chainWrite chain usePadding preserveStats = c_chain_write chain (fromEnum' usePadding) (fromEnum' preserveStats) @@ -111,7 +111,6 @@ -- -- NOTE: this function does not write to the FLAC file, it only modifies the -- chain. - chainSortPadding :: MetaChain -> IO () chainSortPadding = c_chain_sort_padding @@ -129,19 +128,23 @@ -- -- If memory for the iterator cannot be allocated, corresponding -- 'MetaException' is raised. - -withIterator :: (MonadMask m, MonadIO m) - => MetaChain -- ^ Metadata chain to traverse - -> (MetaIterator -> m (Maybe a)) -- ^ Action to perform on each block - -> m [a] -- ^ Accumulated results +withIterator :: + (MonadMask m, MonadIO m) => + -- | Metadata chain to traverse + MetaChain -> + -- | Action to perform on each block + (MetaIterator -> m (Maybe a)) -> + -- | Accumulated results + m [a] withIterator chain f = bracket acquire release action where acquire = liftIO iteratorNew release = mapM_ (liftIO . iteratorDelete) action mi = case mi of - Nothing -> throwM - (MetaGeneralProblem MetaChainStatusMemoryAllocationError) + Nothing -> + throwM + (MetaGeneralProblem MetaChainStatusMemoryAllocationError) Just i -> do liftIO (iteratorInit i chain) let go thisNext = @@ -151,13 +154,12 @@ let next = liftIO (iteratorNext i) >>= go case res of Nothing -> next - Just x -> (x :) <$> next + Just x -> (x :) <$> next else return [] go True -- | Create a new iterator. Return 'Nothing' if there was a problem with -- memory allocation. - iteratorNew :: IO (Maybe MetaIterator) iteratorNew = maybePtr <$> c_iterator_new @@ -166,7 +168,6 @@ -- | Free an iterator instance. Delete the object pointed to by -- 'MetaIterator'. - iteratorDelete :: MetaIterator -> IO () iteratorDelete = c_iterator_delete @@ -175,11 +176,12 @@ -- | Initialize the iterator to point to the first metadata block in the -- given chain. - -iteratorInit - :: MetaIterator -- ^ Existing iterator - -> MetaChain -- ^ Existing initialized chain - -> IO () +iteratorInit :: + -- | Existing iterator + MetaIterator -> + -- | Existing initialized chain + MetaChain -> + IO () iteratorInit = c_iterator_init foreign import ccall unsafe "FLAC__metadata_iterator_init" @@ -187,7 +189,6 @@ -- | Move the iterator forward one metadata block, returning 'False' if -- already at the end. - iteratorNext :: MetaIterator -> IO Bool iteratorNext = c_iterator_next @@ -196,7 +197,6 @@ -- | Get the type of the metadata block at the current position. Useful for -- fast searching. - iteratorGetBlockType :: MetaIterator -> IO MetadataType iteratorGetBlockType = fmap toEnum' . c_iterator_get_block_type @@ -204,7 +204,6 @@ c_iterator_get_block_type :: MetaIterator -> IO CUInt -- | Get metadata block at the current position. - iteratorGetBlock :: MetaIterator -> IO Metadata iteratorGetBlock = c_iterator_get_block @@ -213,7 +212,6 @@ -- | Write given 'Metadata' block at the position pointed to by -- 'MetaIterator' replacing an existing block. - iteratorSetBlock :: MetaIterator -> Metadata -> IO Bool iteratorSetBlock = c_iterator_set_block @@ -221,10 +219,11 @@ c_iterator_set_block :: MetaIterator -> Metadata -> IO Bool -- | Remove the current block from the chain. - -iteratorDeleteBlock - :: MetaIterator -- ^ Iterator that determines the position - -> IO Bool -- ^ 'False' if something went wrong +iteratorDeleteBlock :: + -- | Iterator that determines the position + MetaIterator -> + -- | 'False' if something went wrong + IO Bool iteratorDeleteBlock block = c_iterator_delete_block block False foreign import ccall unsafe "FLAC__metadata_iterator_delete_block" @@ -237,7 +236,6 @@ -- will be left pointing to the new block. -- -- The function returns 'False' if something went wrong. - iteratorInsertBlockAfter :: MetaIterator -> Metadata -> IO Bool iteratorInsertBlockAfter = c_iterator_insert_block_after diff --git a/Codec/Audio/FLAC/Metadata/Internal/Level2Interface/Helpers.hs b/Codec/Audio/FLAC/Metadata/Internal/Level2Interface/Helpers.hs --- a/Codec/Audio/FLAC/Metadata/Internal/Level2Interface/Helpers.hs +++ b/Codec/Audio/FLAC/Metadata/Internal/Level2Interface/Helpers.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + -- | -- Module : Codec.Audio.FLAC.Metadata.Internal.Level2Interface.Helpers --- Copyright : © 2016–2019 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -10,47 +15,47 @@ -- Wrappers around helpers for working with level 2 FLAC metadata interface. -- -- The functions from this module are not safe, one only should attempt --- calling them when 'Metadata' contains metadata of correct type. - -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} - +-- calling them when 'Metadata' contains metadata of the correct type. module Codec.Audio.FLAC.Metadata.Internal.Level2Interface.Helpers ( -- * Stream info - getMinBlockSize - , getMaxBlockSize - , getMinFrameSize - , getMaxFrameSize - , getSampleRate - , getChannels - , getBitsPerSample - , getTotalSamples - , getMd5Sum + getMinBlockSize, + getMaxBlockSize, + getMinFrameSize, + getMaxFrameSize, + getSampleRate, + getChannels, + getBitsPerSample, + getTotalSamples, + getMd5Sum, + -- * Application - , getApplicationId - , getApplicationData - , setApplicationId - , setApplicationData + getApplicationId, + getApplicationData, + setApplicationId, + setApplicationData, + -- * Seek table - , getSeekPoints - , setSeekPoints + getSeekPoints, + setSeekPoints, + -- * Vorbis comment - , getVorbisVendor - , setVorbisVendor - , getVorbisComment - , setVorbisComment - , deleteVorbisComment - , isVorbisCommentEmpty + getVorbisVendor, + setVorbisVendor, + getVorbisComment, + setVorbisComment, + deleteVorbisComment, + isVorbisCommentEmpty, + -- * CUE sheet - , getCueSheetData - , setCueSheetData + getCueSheetData, + setCueSheetData, + -- * Picture - , getPictureType - , getPictureData - , setPictureType - , setPictureData ) + getPictureType, + getPictureData, + setPictureType, + setPictureData, + ) where import Codec.Audio.FLAC.Metadata.Internal.Object @@ -60,28 +65,26 @@ import Control.Monad.Catch import Data.Bool (bool) import Data.ByteString (ByteString) +import Data.ByteString qualified as B import Data.List (uncons) +import Data.List.NonEmpty qualified as NE import Data.Maybe (isJust) -import Data.Monoid ((<>)) import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Text.Foreign qualified as T import Data.Vector (Vector, (!)) +import Data.Vector qualified as V +import Data.Vector.Mutable qualified as VM import Data.Word import Foreign import Foreign.C.String import Foreign.C.Types -import qualified Data.ByteString as B -import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Foreign as T -import qualified Data.Vector as V -import qualified Data.Vector.Mutable as VM ---------------------------------------------------------------------------- -- Stream info -- | Get min block size. - getMinBlockSize :: Metadata -> IO Word32 getMinBlockSize = fmap fromIntegral . c_get_min_blocksize @@ -89,7 +92,6 @@ c_get_min_blocksize :: Metadata -> IO CUInt -- | Get max block size. - getMaxBlockSize :: Metadata -> IO Word32 getMaxBlockSize = fmap fromIntegral . c_get_max_blocksize @@ -97,7 +99,6 @@ c_get_max_blocksize :: Metadata -> IO CUInt -- | Get min frame size. - getMinFrameSize :: Metadata -> IO Word32 getMinFrameSize = fmap fromIntegral . c_get_min_framesize @@ -105,7 +106,6 @@ c_get_min_framesize :: Metadata -> IO Word32 -- | Get max frame size. - getMaxFrameSize :: Metadata -> IO Word32 getMaxFrameSize = fmap fromIntegral . c_get_max_framesize @@ -113,7 +113,6 @@ c_get_max_framesize :: Metadata -> IO Word32 -- | Get sample rate. - getSampleRate :: Metadata -> IO Word32 getSampleRate = fmap fromIntegral . c_get_sample_rate @@ -121,7 +120,6 @@ c_get_sample_rate :: Metadata -> IO CUInt -- | Get number of channels. - getChannels :: Metadata -> IO Word32 getChannels = fmap fromIntegral . c_get_channels @@ -129,7 +127,6 @@ c_get_channels :: Metadata -> IO CUInt -- | Get number of bits per sample. - getBitsPerSample :: Metadata -> IO Word32 getBitsPerSample = fmap fromIntegral . c_get_bits_per_sample @@ -137,7 +134,6 @@ c_get_bits_per_sample :: Metadata -> IO CUInt -- | Get total number of samples. - getTotalSamples :: Metadata -> IO Word64 getTotalSamples = c_get_total_samples @@ -145,7 +141,6 @@ c_get_total_samples :: Metadata -> IO Word64 -- | Get MD5 sum of original audio data. - getMd5Sum :: Metadata -> IO ByteString getMd5Sum block = do md5SumPtr <- c_get_md5sum block @@ -158,7 +153,6 @@ -- Application -- | Get application id from given 'Metadata' block. - getApplicationId :: Metadata -> IO ApplicationId getApplicationId block = do idPtr <- c_get_application_id block @@ -168,18 +162,16 @@ c_get_application_id :: Metadata -> IO CString -- | Get data from given application metadata block. - getApplicationData :: Metadata -> IO ByteString getApplicationData block = alloca $ \sizePtr -> do dataPtr <- c_get_application_data block sizePtr - size <- fromIntegral <$> peek sizePtr + size <- fromIntegral <$> peek sizePtr B.packCStringLen (dataPtr, size) foreign import ccall unsafe "FLAC__metadata_get_application_data" c_get_application_data :: Metadata -> Ptr CUInt -> IO CString -- | Set application id for given metadata block. - setApplicationId :: Metadata -> ApplicationId -> IO () setApplicationId block appId = B.useAsCString (unApplicationId appId) (c_set_application_id block) @@ -188,7 +180,6 @@ c_set_application_id :: Metadata -> CString -> IO () -- | Set application data for given metadata block. - setApplicationData :: Metadata -> ByteString -> IO Bool setApplicationData block data' = B.useAsCString data' $ \dataPtr -> do @@ -202,11 +193,10 @@ -- Seek table -- | Get seek table as a 'Vector' of 'SeekPoint's. - getSeekPoints :: Metadata -> IO (Vector SeekPoint) getSeekPoints block = do size <- fromIntegral <$> c_get_seek_points_num block - v <- VM.new size + v <- VM.new size let go n = when (n < size) $ do ptr <- c_get_seek_point block (fromIntegral n) @@ -226,7 +216,6 @@ -- | Set seek table represented by a given 'Vector' of 'SeekPoint's. Return -- 'False' in case of trouble. - setSeekPoints :: Metadata -> Vector SeekPoint -> IO Bool setSeekPoints block seekPoints = do let size = fromIntegral (V.length seekPoints) @@ -237,7 +226,9 @@ if n < size then do let SeekPoint {..} = seekPoints ! fromIntegral n - c_set_seek_point block (fromIntegral n) + c_set_seek_point + block + (fromIntegral n) seekPointSampleNumber seekPointStreamOffset seekPointFrameSamples @@ -246,7 +237,7 @@ legal <- objectSeektableIsLegal block unless legal $ throwM MetaInvalidSeekTable - in go 0 >> return True + in go 0 >> return True else return False foreign import ccall unsafe "FLAC__metadata_set_seek_point" @@ -256,18 +247,16 @@ -- Vorbis comment -- | Get Vorbis vendor. - getVorbisVendor :: Metadata -> IO Text getVorbisVendor block = alloca $ \sizePtr -> do vendorPtr <- c_get_vorbis_vendor block sizePtr - size <- fromIntegral <$> peek sizePtr + size <- fromIntegral <$> peek sizePtr T.peekCStringLen (vendorPtr, size) foreign import ccall unsafe "FLAC__metadata_get_vorbis_vendor" c_get_vorbis_vendor :: Metadata -> Ptr Word32 -> IO CString -- | Set Vorbis vendor. - setVorbisVendor :: Metadata -> Text -> IO Bool setVorbisVendor block vendor = T.withCStringLen vendor $ \(vendorPtr, size) -> @@ -277,22 +266,21 @@ c_set_vorbis_vendor :: Metadata -> CString -> Word32 -> IO Bool -- | Get vorbis comment by name. - getVorbisComment :: ByteString -> Metadata -> IO (Maybe Text) getVorbisComment name block = alloca $ \sizePtr -> B.useAsCString name $ \namePtr -> do - commentPtr <- c_get_vorbis_comment block namePtr sizePtr + commentPtr <- c_get_vorbis_comment block namePtr sizePtr commentSize <- fromIntegral <$> peek sizePtr if commentPtr == nullPtr then return Nothing - else Just . T.drop 1 . T.dropWhile (/= '=') . T.decodeUtf8 - <$> B.packCStringLen (commentPtr, commentSize) + else + Just . T.drop 1 . T.dropWhile (/= '=') . T.decodeUtf8 + <$> B.packCStringLen (commentPtr, commentSize) foreign import ccall unsafe "FLAC__metadata_get_vorbis_comment" c_get_vorbis_comment :: Metadata -> CString -> Ptr Word32 -> IO CString -- | Set (replace or insert if necessary) a vorbis comment. - setVorbisComment :: ByteString -> Text -> Metadata -> IO Bool setVorbisComment name value block = T.withCStringLen (T.decodeUtf8 name <> "=" <> value) $ @@ -304,7 +292,6 @@ -- | Delete a vorbis comment by name. If it doesn't exist, nothing will -- happen. - deleteVorbisComment :: ByteString -> Metadata -> IO Bool deleteVorbisComment name block = B.useAsCString name (c_delete_vorbis_comment block) @@ -313,7 +300,6 @@ c_delete_vorbis_comment :: Metadata -> CString -> IO Bool -- | Determine a vorbis comment metadata block can be considered empty. - isVorbisCommentEmpty :: Metadata -> IO Bool isVorbisCommentEmpty = c_is_vorbis_comment_empty @@ -325,13 +311,12 @@ -- | Get CUE sheet from 'Metadata' block assuming that it's a -- 'CueSheetBlock'. - getCueSheetData :: Metadata -> IO CueSheetData getCueSheetData block = do - cueCatalog <- c_get_cue_sheet_mcn block >>= B.packCString - cueLeadIn <- c_get_cue_sheet_lead_in block - cueIsCd <- c_get_cue_sheet_is_cd block - numTracks <- c_get_cue_sheet_num_tracks block + cueCatalog <- c_get_cue_sheet_mcn block >>= B.packCString + cueLeadIn <- c_get_cue_sheet_lead_in block + cueIsCd <- c_get_cue_sheet_is_cd block + numTracks <- c_get_cue_sheet_num_tracks block (cueTracks, cueLeadOutTrack) <- case numTracks of 0 -> @@ -340,9 +325,9 @@ throwM (MetaInvalidCueSheet "Cannot read CUE sheet without tracks") 1 -> ([],) <$> getCueSheetTrack block 0 _ -> do - ts <- mapM (getCueSheetTrack block) [0..numTracks - 2] + ts <- mapM (getCueSheetTrack block) [0 .. numTracks - 2] t' <- getCueSheetTrack block (numTracks - 1) - return (ts,t') + return (ts, t') return CueSheetData {..} foreign import ccall unsafe "FLAC__metadata_get_cue_sheet_mcn" @@ -358,31 +343,33 @@ c_get_cue_sheet_num_tracks :: Metadata -> IO Word8 -- | Peek a single 'CueSheetTrack' at given index. - getCueSheetTrack :: Metadata -> Word8 -> IO CueTrack getCueSheetTrack block n = do cueTrackOffset <- c_get_cue_sheet_track_offset block n - cueTrackIsrc <- c_get_cue_sheet_track_isrc block n >>= B.packCString - cueTrackAudio <- c_get_cue_sheet_track_audio block n + cueTrackIsrc <- c_get_cue_sheet_track_isrc block n >>= B.packCString + cueTrackAudio <- c_get_cue_sheet_track_audio block n cueTrackPreEmphasis <- c_get_cue_sheet_track_preemphasis block n - numIndices <- c_get_cue_sheet_track_num_indices block n - (cueTrackPregapIndex, cueTrackIndices) <- if numIndices == 0 - then throwM (MetaInvalidCueSheet "Cannot read CUE track without indices") - else do - hasPregap <- c_get_cue_sheet_track_has_pregap_index block n - let pregapOne :: Num a => a - pregapOne = if hasPregap then 1 else 0 - range = - if numIndices > pregapOne - then [pregapOne..numIndices - 1] - else [] - pregapIndex <- if hasPregap - then Just <$> c_get_cue_sheet_track_index block n 0 - else return Nothing - trackIndices <- mapM - (c_get_cue_sheet_track_index block n) - (NE.fromList range) - return (pregapIndex, trackIndices) + numIndices <- c_get_cue_sheet_track_num_indices block n + (cueTrackPregapIndex, cueTrackIndices) <- + if numIndices == 0 + then throwM (MetaInvalidCueSheet "Cannot read CUE track without indices") + else do + hasPregap <- c_get_cue_sheet_track_has_pregap_index block n + let pregapOne :: (Num a) => a + pregapOne = if hasPregap then 1 else 0 + range = + if numIndices > pregapOne + then [pregapOne .. numIndices - 1] + else [] + pregapIndex <- + if hasPregap + then Just <$> c_get_cue_sheet_track_index block n 0 + else return Nothing + trackIndices <- + mapM + (c_get_cue_sheet_track_index block n) + (NE.fromList range) + return (pregapIndex, trackIndices) return CueTrack {..} foreign import ccall unsafe "FLAC__metadata_get_cue_sheet_track_offset" @@ -407,28 +394,28 @@ c_get_cue_sheet_track_index :: Metadata -> Word8 -> Word8 -> IO Word64 -- | Set 'CueSheetData' in given 'Metadata' block of type 'CueSheetBlock'. - setCueSheetData :: Metadata -> CueSheetData -> IO Bool setCueSheetData block CueSheetData {..} = do B.useAsCStringLen cueCatalog $ \(mcnPtr, mcnSize) -> c_set_cue_sheet_mcn block mcnPtr (fromIntegral mcnSize) c_set_cue_sheet_lead_in block cueLeadIn - c_set_cue_sheet_is_cd block cueIsCd + c_set_cue_sheet_is_cd block cueIsCd let numTracks = fromIntegral (length cueTracks + 1) res <- objectCueSheetResizeTracks block numTracks - goodOutcome <- if res - then - let go ts = - case uncons ts of - Nothing -> - setCueSheetTrack block cueLeadOutTrack (numTracks - 1) 170 - Just ((t,n),ts') -> do - res' <- setCueSheetTrack block t n (n + 1) - if res' - then go ts' - else return False - in go (zip cueTracks [0..]) - else return False + goodOutcome <- + if res + then + let go ts = + case uncons ts of + Nothing -> + setCueSheetTrack block cueLeadOutTrack (numTracks - 1) 170 + Just ((t, n), ts') -> do + res' <- setCueSheetTrack block t n (n + 1) + if res' + then go ts' + else return False + in go (zip cueTracks [0 ..]) + else return False when goodOutcome $ do res' <- objectCueSheetIsLegal block cueIsCd case res' of @@ -446,7 +433,6 @@ c_set_cue_sheet_is_cd :: Metadata -> Bool -> IO () -- | Poke a 'CueTrack' at a specified index. - setCueSheetTrack :: Metadata -> CueTrack -> Word8 -> Word8 -> IO Bool setCueSheetTrack block CueTrack {..} n n' = do c_set_cue_sheet_track_offset block n cueTrackOffset @@ -455,15 +441,15 @@ c_set_cue_sheet_track_isrc block n isrcPtr (fromIntegral isrcSize) c_set_cue_sheet_track_audio block n cueTrackAudio c_set_cue_sheet_track_pre_emphasis block n cueTrackPreEmphasis - let pregapOne :: Num a => a + let pregapOne :: (Num a) => a pregapOne = if isJust cueTrackPregapIndex then 1 else 0 numIndices = fromIntegral (NE.length cueTrackIndices + pregapOne) goodOutcome <- objectCueSheetTrackResizeIndices block n numIndices when goodOutcome $ do forM_ cueTrackPregapIndex $ \offset -> c_set_cue_sheet_track_index block n 0 0 offset - let range = zip [pregapOne..] [1..] - forM_ (NE.zip cueTrackIndices (NE.fromList range)) $ \(offset, (i,i')) -> + let range = zip [pregapOne ..] [1 ..] + forM_ (NE.zip cueTrackIndices (NE.fromList range)) $ \(offset, (i, i')) -> c_set_cue_sheet_track_index block n i i' offset return goodOutcome @@ -490,7 +476,6 @@ -- | Get type of picture assuming that given 'Metadata' block is a -- 'PictureBlock'. - getPictureType :: Metadata -> IO PictureType getPictureType = fmap toEnum' . c_get_picture_type @@ -498,17 +483,16 @@ c_get_picture_type :: Metadata -> IO CUInt -- | Get picture data from a given 'Metadata' block. - getPictureData :: Metadata -> IO PictureData getPictureData block = do - pictureMimeType <- c_get_picture_mime_type block >>= peekCStringText + pictureMimeType <- c_get_picture_mime_type block >>= peekCStringText pictureDescription <- c_get_picture_description block >>= peekCStringText - pictureWidth <- c_get_picture_width block - pictureHeight <- c_get_picture_height block - pictureDepth <- c_get_picture_depth block - pictureColors <- c_get_picture_colors block - pictureData <- alloca $ \dataSizePtr -> do - dataPtr <- c_get_picture_data block dataSizePtr + pictureWidth <- c_get_picture_width block + pictureHeight <- c_get_picture_height block + pictureDepth <- c_get_picture_depth block + pictureColors <- c_get_picture_colors block + pictureData <- alloca $ \dataSizePtr -> do + dataPtr <- c_get_picture_data block dataSizePtr dataSize <- fromIntegral <$> peek dataSizePtr B.packCStringLen (dataPtr, dataSize) return PictureData {..} @@ -536,7 +520,6 @@ -- | Set 'PictureType' to a given 'Metadata' block that should be a -- 'PictureBlock'. - setPictureType :: Metadata -> PictureType -> IO () setPictureType block pictureType = c_set_picture_type block (fromEnum' pictureType) @@ -545,22 +528,23 @@ c_set_picture_type :: Metadata -> CUInt -> IO () -- | Set 'PictureData' in given 'Metadata' block of type 'PictureBlock'. - setPictureData :: Metadata -> PictureData -> IO Bool setPictureData block PictureData {..} = do - c_set_picture_width block pictureWidth + c_set_picture_width block pictureWidth c_set_picture_height block pictureHeight - c_set_picture_depth block pictureDepth + c_set_picture_depth block pictureDepth c_set_picture_colors block pictureColors - goodOutcome <- shortcutFalse - [ objectPictureSetMimeType block pictureMimeType - , objectPictureSetDescription block pictureDescription - , objectPictureSetData block pictureData ] + goodOutcome <- + shortcutFalse + [ objectPictureSetMimeType block pictureMimeType, + objectPictureSetDescription block pictureDescription, + objectPictureSetData block pictureData + ] when goodOutcome $ do - res <- objectPictureIsLegal block - case res of - Nothing -> return () - Just msg -> throwM (MetaInvalidPicture msg) + res <- objectPictureIsLegal block + case res of + Nothing -> return () + Just msg -> throwM (MetaInvalidPicture msg) return goodOutcome foreign import ccall unsafe "FLAC__metadata_set_picture_width" @@ -578,7 +562,6 @@ -- | Execute a collection of actions that return 'False' on failure. As soon -- as failure is reported, stop the execution and return 'False'. Return -- 'True' in the case of success. - shortcutFalse :: [IO Bool] -> IO Bool -shortcutFalse [] = return True -shortcutFalse (m:ms) = m >>= bool (return False) (shortcutFalse ms) +shortcutFalse [] = return True +shortcutFalse (m : ms) = m >>= bool (return False) (shortcutFalse ms) diff --git a/Codec/Audio/FLAC/Metadata/Internal/Object.hs b/Codec/Audio/FLAC/Metadata/Internal/Object.hs --- a/Codec/Audio/FLAC/Metadata/Internal/Object.hs +++ b/Codec/Audio/FLAC/Metadata/Internal/Object.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + -- | -- Module : Codec.Audio.FLAC.Metadata.Internal.Object --- Copyright : © 2016–2019 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -10,34 +12,31 @@ -- Wrappers for the functions to work with metadata objects, see: -- -- . - -{-# LANGUAGE ForeignFunctionInterface #-} - module Codec.Audio.FLAC.Metadata.Internal.Object - ( objectNew - , objectDelete - , objectSeektableResizePoints - , objectSeektableIsLegal - , objectCueSheetResizeTracks - , objectCueSheetTrackResizeIndices - , objectCueSheetIsLegal - , objectPictureSetMimeType - , objectPictureSetDescription - , objectPictureSetData - , objectPictureIsLegal ) + ( objectNew, + objectDelete, + objectSeektableResizePoints, + objectSeektableIsLegal, + objectCueSheetResizeTracks, + objectCueSheetTrackResizeIndices, + objectCueSheetIsLegal, + objectPictureSetMimeType, + objectPictureSetDescription, + objectPictureSetData, + objectPictureIsLegal, + ) where import Codec.Audio.FLAC.Metadata.Internal.Types import Codec.Audio.FLAC.Util import Data.ByteString (ByteString) +import Data.ByteString.Unsafe qualified as B import Data.Text (Text) import Foreign import Foreign.C.String import Foreign.C.Types -import qualified Data.ByteString.Unsafe as B -- | Create a new metadata object given its type. - objectNew :: MetadataType -> IO (Maybe Metadata) objectNew = fmap maybePtr . c_object_new . fromEnum' @@ -45,7 +44,6 @@ c_object_new :: CUInt -> IO Metadata -- | Free a metadata object. - objectDelete :: Metadata -> IO () objectDelete = c_object_delete @@ -53,7 +51,6 @@ c_object_delete :: Metadata -> IO () -- | Resize the seekpoint array. In case of trouble return 'False'. - objectSeektableResizePoints :: Metadata -> Word32 -> IO Bool objectSeektableResizePoints block newSize = c_object_seektable_resize_points block (fromIntegral newSize) @@ -63,7 +60,6 @@ -- | Check a seek table to see if it conforms to the FLAC specification. -- Return 'False' if the seek table is illegal. - objectSeektableIsLegal :: Metadata -> IO Bool objectSeektableIsLegal = c_object_seektable_is_legal @@ -71,7 +67,6 @@ c_object_seektable_is_legal :: Metadata -> IO Bool -- | Resize the track array. - objectCueSheetResizeTracks :: Metadata -> Word8 -> IO Bool objectCueSheetResizeTracks block n = c_object_cuesheet_resize_tracks block (fromIntegral n) @@ -80,7 +75,6 @@ c_object_cuesheet_resize_tracks :: Metadata -> CUInt -> IO Bool -- | Resize a track's index point array. - objectCueSheetTrackResizeIndices :: Metadata -> Word8 -> Word8 -> IO Bool objectCueSheetTrackResizeIndices block n i = c_object_cuesheet_track_resize_indices block (fromIntegral n) (fromIntegral i) @@ -91,7 +85,6 @@ -- | Check a CUE sheet to see if it conforms to the FLAC specification. If -- something is wrong, the explanation is returned in 'Just', otherwise -- 'Nothing' is returned. - objectCueSheetIsLegal :: Metadata -> Bool -> IO (Maybe Text) objectCueSheetIsLegal block checkCdda = alloca $ \cstrPtr -> do res <- c_object_cuesheet_is_legal block checkCdda cstrPtr @@ -104,7 +97,6 @@ -- | Check a picture and return description of what is wrong, otherwise -- 'Nothing'. - objectPictureIsLegal :: Metadata -> IO (Maybe Text) objectPictureIsLegal block = alloca $ \cstrPtr -> do res <- c_object_picture_is_legal block cstrPtr @@ -116,7 +108,6 @@ c_object_picture_is_legal :: Metadata -> Ptr CString -> IO Bool -- | Set the MIME type of a given picture block. - objectPictureSetMimeType :: Metadata -> Text -> IO Bool objectPictureSetMimeType block mimeType = withCStringText mimeType $ \cstr -> @@ -126,7 +117,6 @@ c_object_picture_set_mime_type :: Metadata -> CString -> Bool -> IO Bool -- | Set the description of a given picture block. - objectPictureSetDescription :: Metadata -> Text -> IO Bool objectPictureSetDescription block desc = withCStringText desc $ \cstr -> @@ -136,7 +126,6 @@ c_object_picture_set_description :: Metadata -> CString -> Bool -> IO Bool -- | Set the picture data of a given picture block. - objectPictureSetData :: Metadata -> ByteString -> IO Bool objectPictureSetData block data' = B.unsafeUseAsCStringLen data' $ \(dataPtr, dataSize) -> diff --git a/Codec/Audio/FLAC/Metadata/Internal/Types.hs b/Codec/Audio/FLAC/Metadata/Internal/Types.hs --- a/Codec/Audio/FLAC/Metadata/Internal/Types.hs +++ b/Codec/Audio/FLAC/Metadata/Internal/Types.hs @@ -1,6 +1,6 @@ -- | -- Module : Codec.Audio.FLAC.Metadata.Internal.Types --- Copyright : © 2016–2019 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -8,118 +8,119 @@ -- Portability : portable -- -- Mostly non-public metadata-specific helper types. - module Codec.Audio.FLAC.Metadata.Internal.Types - ( MetaChain (..) - , MetaIterator (..) - , Metadata (..) - , MetadataType (..) - , MetaChainStatus (..) - , MetaException (..) - , ApplicationId - , mkApplicationId - , unApplicationId - , SeekPoint (..) - , CueSheetData (..) - , CueTrack (..) - , PictureType (..) - , PictureData (..) ) + ( MetaChain (..), + MetaIterator (..), + Metadata (..), + MetadataType (..), + MetaChainStatus (..), + MetaException (..), + ApplicationId, + mkApplicationId, + unApplicationId, + SeekPoint (..), + CueSheetData (..), + CueTrack (..), + PictureType (..), + PictureData (..), + ) where import Control.Exception (Exception) import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.ByteString.Char8 qualified as B8 import Data.List.NonEmpty (NonEmpty (..)) -import Data.Monoid ((<>)) import Data.String (IsString (..)) import Data.Text (Text) import Data.Void import Foreign -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -- | An opaque newtype wrapper around @'Ptr' 'Void'@, serves to represent a -- pointer to a metadata chain. - newtype MetaChain = MetaChain (Ptr Void) -- | The same as 'MetaChain', this one is for pointers to metadata iterator. - newtype MetaIterator = MetaIterator (Ptr Void) -- | The same as 'MetaChain', this one for pointers to metadata structure -- itself. - newtype Metadata = Metadata (Ptr Void) -- | Enumeration of all known metadata blocks. - data MetadataType - = StreamInfoBlock -- ^ Stream info block (general data like sample rate) - | PaddingBlock -- ^ Padding block - | ApplicationBlock -- ^ Application block - | SeekTableBlock -- ^ Seek table block - | VorbisCommentBlock -- ^ Vorbis comment block, a.k.a. FLAC tags - | CueSheetBlock -- ^ Cue sheet block - | PictureBlock -- ^ Picture block - | UndefinedBlock -- ^ Undefined block + = -- | Stream info block (general data like sample rate) + StreamInfoBlock + | -- | Padding block + PaddingBlock + | -- | Application block + ApplicationBlock + | -- | Seek table block + SeekTableBlock + | -- | Vorbis comment block, a.k.a. FLAC tags + VorbisCommentBlock + | -- | Cue sheet block + CueSheetBlock + | -- | Picture block + PictureBlock + | -- | Undefined block + UndefinedBlock deriving (Show, Read, Eq, Ord, Bounded, Enum) -- | Enumeration of meta chain statuses. - data MetaChainStatus - = MetaChainStatusOK - -- ^ The chain is in the normal OK state. - | MetaChainStatusIllegalInput - -- ^ The data passed into a function violated the function's usage + = -- | The chain is in the normal OK state. + MetaChainStatusOK + | -- | The data passed into a function violated the function's usage -- criteria. - | MetaChainStatusErrorOpeningFile - -- ^ The chain could not open the target file. - | MetaChainStatusNotFlacFile - -- ^ The chain could not find the FLAC signature at the start of the + MetaChainStatusIllegalInput + | -- | The chain could not open the target file. + MetaChainStatusErrorOpeningFile + | -- | The chain could not find the FLAC signature at the start of the -- file. - | MetaChainStatusNotWritable - -- ^ The chain tried to write to a file that was not writable. - | MetaChainStatusBadMetadata - -- ^ The chain encountered input that does not conform to the FLAC + MetaChainStatusNotFlacFile + | -- | The chain tried to write to a file that was not writable. + MetaChainStatusNotWritable + | -- | The chain encountered input that does not conform to the FLAC -- metadata specification. - | MetaChainStatusReadError - -- ^ The chain encountered an error while reading the FLAC file. - | MetaChainStatusSeekError - -- ^ The chain encountered an error while seeking in the FLAC file. - | MetaChainStatusWriteError - -- ^ The chain encountered an error while writing the FLAC file. - | MetaChainStatusRenameError - -- ^ The chain encountered an error renaming the FLAC file. - | MetaChainStatusUnlinkError - -- ^ The chain encountered an error removing the temporary file. - | MetaChainStatusMemoryAllocationError - -- ^ Memory allocation failed. - | MetaChainStatusInternalError - -- ^ The caller violated an assertion or an unexpected error occurred. - | MetaChainStatusInvalidCallbacks - -- ^ One or more of the required callbacks was NULL. - | MetaChainStatusReadWriteMismatch - -- ^ This error occurs when read and write methods do not match (i.e. + MetaChainStatusBadMetadata + | -- | The chain encountered an error while reading the FLAC file. + MetaChainStatusReadError + | -- | The chain encountered an error while seeking in the FLAC file. + MetaChainStatusSeekError + | -- | The chain encountered an error while writing the FLAC file. + MetaChainStatusWriteError + | -- | The chain encountered an error renaming the FLAC file. + MetaChainStatusRenameError + | -- | The chain encountered an error removing the temporary file. + MetaChainStatusUnlinkError + | -- | Memory allocation failed. + MetaChainStatusMemoryAllocationError + | -- | The caller violated an assertion or an unexpected error occurred. + MetaChainStatusInternalError + | -- | One or more of the required callbacks was NULL. + MetaChainStatusInvalidCallbacks + | -- | This error occurs when read and write methods do not match (i.e. -- when if you read with callbacks, you should also use function that -- writes with callbacks). - | MetaChainStatusWrongWriteCall - -- ^ Should not ever happen when you use this binding. + MetaChainStatusReadWriteMismatch + | -- | Should not ever happen when you use this binding. + MetaChainStatusWrongWriteCall deriving (Show, Read, Eq, Ord, Bounded, Enum) -- | The exception that is thrown when manipulation of FLAC metadata fails -- for some reason. - data MetaException - = MetaGeneralProblem MetaChainStatus - -- ^ General failure, see the attached 'MetaChainStatus'. - | MetaInvalidSeekTable - -- ^ Invalid seek table was passed to be written. - | MetaInvalidCueSheet Text - -- ^ Invalid CUE sheet was passed to be written. The reason why the data + = -- | General failure, see the attached 'MetaChainStatus'. + MetaGeneralProblem MetaChainStatus + | -- | Invalid seek table was passed to be written. + MetaInvalidSeekTable + | -- | Invalid CUE sheet was passed to be written. The reason why the data -- was invalid is attached. - | MetaInvalidPicture Text - -- ^ Invalid picture data was passed to be written. The reason why the + MetaInvalidCueSheet Text + | -- | Invalid picture data was passed to be written. The reason why the -- data was invalid is attached. + MetaInvalidPicture Text deriving (Eq, Show, Read) instance Exception MetaException @@ -129,7 +130,6 @@ -- values of this type using Haskell string literals with -- @OverloadedStrings@ or with the 'mkApplicationId' smart constructor. -- Extract the inner 'ByteString' with 'unApplicationId'. - newtype ApplicationId = ApplicationId ByteString deriving (Eq, Ord) @@ -142,40 +142,37 @@ -- | Application id must be four bytes long. If it's too short, null bytes -- will be appended to it to make it four bytes long. If it's too long, it -- will be truncated. - mkApplicationId :: ByteString -> ApplicationId -mkApplicationId appId = ApplicationId $ - B.take 4 (appId <> B.replicate 4 0x00) +mkApplicationId appId = + ApplicationId $ + B.take 4 (appId <> B.replicate 4 0x00) -- | Get 'ByteString' from 'ApplicationId'. - unApplicationId :: ApplicationId -> ByteString unApplicationId (ApplicationId appId) = appId -- | Single point in a seek table metadata block. - data SeekPoint = SeekPoint - { seekPointSampleNumber :: !Word64 - -- ^ The sample number of the target frame - , seekPointStreamOffset :: !Word64 - -- ^ The offset in bytes of the target frame with respect to beginning + { -- | The sample number of the target frame + seekPointSampleNumber :: !Word64, + -- | The offset in bytes of the target frame with respect to beginning -- of the first frame - , seekPointFrameSamples :: !Word32 - -- ^ The number of samples in the target frame - } deriving (Eq, Ord, Show, Read) + seekPointStreamOffset :: !Word64, + -- | The number of samples in the target frame + seekPointFrameSamples :: !Word32 + } + deriving (Eq, Ord, Show, Read) -- | CUE sheet as stored in FLAC metadata. This differs from traditional CUE -- sheets stored in “.cue” files (see -- to work with those). - data CueSheetData = CueSheetData - { cueCatalog :: !ByteString - -- ^ Media catalog number, in ASCII printable characters 0x20-0x7e. In + { -- | Media catalog number, in ASCII printable characters 0x20-0x7e. In -- general, the media catalog number may be 0 to 128 bytes long; any -- unused characters will be right-padded with NUL characters. For -- CD-DA, this is a thirteen digit number. - , cueLeadIn :: !Word64 - -- ^ The number of lead-in samples. This field has meaning only for + cueCatalog :: !ByteString, + -- | The number of lead-in samples. This field has meaning only for -- CD-DA CUE sheets; for other uses it should be 0. For CD-DA, the -- lead-in is the TRACK 00 area where the table of contents is stored; -- more precisely, it is the number of samples from the first sample of @@ -188,83 +185,110 @@ -- stored here is the number of samples up to the first index point of -- the first track, not necessarily to INDEX 01 of the first track; even -- the first track may have INDEX 00 data. - , cueIsCd :: !Bool - -- ^ 'True' if CUE sheet corresponds to a Compact Disc, else 'False'. - , cueTracks :: ![CueTrack] - -- ^ Collection of actual tracks in the CUE sheet, see 'CueTrack'. - , cueLeadOutTrack :: !CueTrack - -- ^ The obligatory lead-out track, will be written with the index 170. - } deriving (Eq, Ord, Show, Read) + cueLeadIn :: !Word64, + -- | 'True' if CUE sheet corresponds to a Compact Disc, else 'False'. + cueIsCd :: !Bool, + -- | Collection of actual tracks in the CUE sheet, see 'CueTrack'. + cueTracks :: ![CueTrack], + -- | The obligatory lead-out track, will be written with the index 170. + cueLeadOutTrack :: !CueTrack + } + deriving (Eq, Ord, Show, Read) -- | Single track in a CUE sheet. - data CueTrack = CueTrack - { cueTrackOffset :: !Word64 - -- ^ Track offset in samples, relative to the beginning of the FLAC + { -- | Track offset in samples, relative to the beginning of the FLAC -- audio stream. It is the offset to the first index point of the track. -- (Note how this differs from CD-DA, where the track's offset in the -- TOC is that of the track's INDEX 01 even if there is an INDEX 00.) -- For CD-DA, the offset must be evenly divisible by 588 samples (588 -- samples = 44100 samples\/sec * 1\/75th of a sec). - , cueTrackIsrc :: !ByteString - -- ^ Track ISRC, empty if not present. This is a 12-digit alphanumeric + cueTrackOffset :: !Word64, + -- | Track ISRC, empty if not present. This is a 12-digit alphanumeric -- code, the @cue-sheet@ package has corresponding type with smart -- constructor and validation, but for now we don't want to depend on -- that package. - , cueTrackAudio :: !Bool - -- ^ 'True' for audio tracks, 'False' for non-audio tracks. - , cueTrackPreEmphasis :: !Bool - -- ^ 'False' for no pre-emphasis, 'True' for pre-emphasis. - , cueTrackPregapIndex :: !(Maybe Word64) - -- ^ INDEX 00 (pregap) offset, see 'cueTrackIndices' for more info about + cueTrackIsrc :: !ByteString, + -- | 'True' for audio tracks, 'False' for non-audio tracks. + cueTrackAudio :: !Bool, + -- | 'False' for no pre-emphasis, 'True' for pre-emphasis. + cueTrackPreEmphasis :: !Bool, + -- | INDEX 00 (pregap) offset, see 'cueTrackIndices' for more info about -- indices. - , cueTrackIndices :: !(NonEmpty Word64) - -- ^ Track's index points. Offset in samples, relative to the track + cueTrackPregapIndex :: !(Maybe Word64), + -- | Track's index points. Offset in samples, relative to the track -- offset, of the index point. For CD-DA, the offset must be evenly -- divisible by 588 samples (588 samples = 44100 samples\/sec * 1\/75th -- of a sec). Note that the offset is from the beginning of the track, -- not the beginning of the audio data. - } deriving (Eq, Ord, Show, Read) + cueTrackIndices :: !(NonEmpty Word64) + } + deriving (Eq, Ord, Show, Read) -- | Type of picture FLAC metadata can contain. There may be several -- metadata blocks containing pictures of different types. - data PictureType - = PictureOther -- ^ Other - | PictureFileIconStandard -- ^ 32×32 pixels file icon (PNG only) - | PictureFileIcon -- ^ Other file icon - | PictureFrontCover -- ^ Cover (front) - | PictureBackCover -- ^ Cover (back) - | PictureLeafletPage -- ^ Leaflet page - | PictureMedia -- ^ Media (e.g. label side of CD) - | PictureLeadArtist -- ^ Lead artist\/lead performer\/soloist - | PictureArtist -- ^ Artist\/performer - | PictureConductor -- ^ Conductor - | PictureBand -- ^ Band\/orchestra - | PictureComposer -- ^ Composer - | PictureLyricist -- ^ Lyricist\/text writer - | PictureRecordingLocation -- ^ Recording location - | PictureDuringRecording -- ^ During recording - | PictureDuringPerformance -- ^ During performance - | PictureVideoScreenCapture -- ^ Movie\/video screen capture - | PictureFish -- ^ A bright coloured fish - | PictureIllustration -- ^ Illustration - | PictureBandLogotype -- ^ Band\/artist logotype - | PicturePublisherLogotype -- ^ Publisher\/studio logotype + = -- | Other + PictureOther + | -- | 32×32 pixels file icon (PNG only) + PictureFileIconStandard + | -- | Other file icon + PictureFileIcon + | -- | Cover (front) + PictureFrontCover + | -- | Cover (back) + PictureBackCover + | -- | Leaflet page + PictureLeafletPage + | -- | Media (e.g. label side of CD) + PictureMedia + | -- | Lead artist\/lead performer\/soloist + PictureLeadArtist + | -- | Artist\/performer + PictureArtist + | -- | Conductor + PictureConductor + | -- | Band\/orchestra + PictureBand + | -- | Composer + PictureComposer + | -- | Lyricist\/text writer + PictureLyricist + | -- | Recording location + PictureRecordingLocation + | -- | During recording + PictureDuringRecording + | -- | During performance + PictureDuringPerformance + | -- | Movie\/video screen capture + PictureVideoScreenCapture + | -- | A bright coloured fish + PictureFish + | -- | Illustration + PictureIllustration + | -- | Band\/artist logotype + PictureBandLogotype + | -- | Publisher\/studio logotype + PicturePublisherLogotype deriving (Show, Read, Eq, Ord, Bounded, Enum) -- | Representation of picture contained in a FLAC metadata block. - data PictureData = PictureData - { pictureMimeType :: !Text - -- ^ The picture's MIME data. For best compatibility with players, use + { -- | The picture's MIME data. For best compatibility with players, use -- picture data of MIME type @image\/jpeg@ or @image\/png@. - , pictureDescription :: !Text -- ^ Picture's description. - , pictureWidth :: !Word32 -- ^ Picture's width in pixels. - , pictureHeight :: !Word32 -- ^ Picture's height in pixels. - , pictureDepth :: !Word32 -- ^ Picture's color depth in bits-per-pixel. - , pictureColors :: !Word32 - -- ^ For indexed palettes (like GIF), picture's number of colors (the + pictureMimeType :: !Text, + -- | Picture's description. + pictureDescription :: !Text, + -- | Picture's width in pixels. + pictureWidth :: !Word32, + -- | Picture's height in pixels. + pictureHeight :: !Word32, + -- | Picture's color depth in bits-per-pixel. + pictureDepth :: !Word32, + -- | For indexed palettes (like GIF), picture's number of colors (the -- number of palette entries), or 0 for non-indexed (i.e. 2 ^ depth). - , pictureData :: !ByteString -- ^ Binary picture data. - } deriving (Eq, Ord, Show, Read) + pictureColors :: !Word32, + -- | Binary picture data. + pictureData :: !ByteString + } + deriving (Eq, Ord, Show, Read) diff --git a/Codec/Audio/FLAC/StreamDecoder.hs b/Codec/Audio/FLAC/StreamDecoder.hs --- a/Codec/Audio/FLAC/StreamDecoder.hs +++ b/Codec/Audio/FLAC/StreamDecoder.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE RecordWildCards #-} + -- | -- Module : Codec.Audio.FLAC.StreamDecoder --- Copyright : © 2016–2019 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -12,8 +14,7 @@ -- === How to use this module -- -- Just call the 'decodeFlac' function with 'DecoderSettings', input and --- output file names. The 'decodeFlac' function can produce vanilla WAVE and --- RF64. +-- output file names. The 'decodeFlac' function can produce WAVE and RF64. -- -- === Low-level details -- @@ -25,16 +26,14 @@ -- Decoding speed is equal to that of @flac@ command line tool. Memory -- consumption is minimal and remains constant regardless of the size of -- file to decode. - -{-# LANGUAGE RecordWildCards #-} - module Codec.Audio.FLAC.StreamDecoder - ( DecoderSettings (..) - , defaultDecoderSettings - , DecoderException (..) - , DecoderInitStatus (..) - , DecoderState (..) - , decodeFlac ) + ( DecoderSettings (..), + defaultDecoderSettings, + DecoderException (..), + DecoderInitStatus (..), + DecoderState (..), + decodeFlac, + ) where import Codec.Audio.FLAC.Metadata @@ -54,51 +53,55 @@ import System.IO -- | Parameters of the stream decoder. - data DecoderSettings = DecoderSettings - { decoderMd5Checking :: !Bool - -- ^ If 'True', the decoder will compute the MD5 signature of the + { -- | If 'True', the decoder will compute the MD5 signature of the -- unencoded audio data while decoding and compare it to the signature -- from the STREAMINFO block. Default value: 'False'. - , decoderWaveFormat :: !WaveFormat - -- ^ This specifies WAVE format in which to save the decoded file. You + decoderMd5Checking :: !Bool, + -- | This specifies WAVE format in which to save the decoded file. You -- can choose between 'WaveVanilla' and 'WaveRF64'; choose the latter if -- uncompressed file is expected to be longer than 4 Gb. Default value: -- 'WaveVanilla'. - } deriving (Show, Read, Eq, Ord) + decoderWaveFormat :: !WaveFormat + } + deriving (Show, Read, Eq, Ord) -- | Default 'DecoderSettings'. -- -- @since 0.2.0 - defaultDecoderSettings :: DecoderSettings -defaultDecoderSettings = DecoderSettings - { decoderMd5Checking = False - , decoderWaveFormat = WaveVanilla - } +defaultDecoderSettings = + DecoderSettings + { decoderMd5Checking = False, + decoderWaveFormat = WaveVanilla + } -- | Decode a FLAC file to WAVE. -- -- 'DecoderException' is thrown when underlying FLAC decoder reports a -- problem. - -decodeFlac :: MonadIO m - => DecoderSettings -- ^ Decoder settings - -> FilePath -- ^ File to decode - -> FilePath -- ^ Where to save the resulting WAVE file - -> m () +decodeFlac :: + (MonadIO m) => + -- | Decoder settings + DecoderSettings -> + -- | File to decode + FilePath -> + -- | Where to save the resulting WAVE file + FilePath -> + m () decodeFlac DecoderSettings {..} ipath' opath' = liftIO . withDecoder $ \d -> do ipath <- makeAbsolute ipath' opath <- makeAbsolute opath' liftInit (decoderSetMd5Checking d decoderMd5Checking) (maxBlockSize, wave) <- runFlacMeta defaultMetaSettings ipath $ do - let waveFileFormat = decoderWaveFormat - waveDataOffset = 0 - waveDataSize = 0 - waveOtherChunks = [] + let waveFileFormat = decoderWaveFormat + waveDataOffset = 0 + waveDataSize = 0 + waveOtherChunks = [] waveSampleRate <- retrieve SampleRate - waveSampleFormat <- SampleFormatPcmInt . fromIntegral - <$> retrieve BitsPerSample + waveSampleFormat <- + SampleFormatPcmInt . fromIntegral + <$> retrieve BitsPerSample waveChannelMask <- retrieve ChannelMask waveSamplesTotal <- retrieve TotalSamples maxBlockSize <- fromIntegral <$> retrieve MaxBlockSize @@ -132,22 +135,21 @@ -- Helpers -- | Execute an initializing action that returns 'False' on failure and take --- care of error reporting. In the case of trouble, @'DecoderInitFailed' --- 'DecoderInitStatusAlreadyInitialized'@ is thrown. - +-- care of error reporting. +-- +-- Throws @'DecoderInitFailed' 'DecoderInitStatusAlreadyInitialized'@. liftInit :: IO Bool -> IO () liftInit m = liftIO m >>= bool t (return ()) where t = throwIO (DecoderInitFailed DecoderInitStatusAlreadyInitialized) -- | Execute an action that returns 'False' on failure into taking care of --- error reporting. In the case of trouble @'EncoderFailed'@ with encoder --- status attached is thrown. - +-- error reporting. +-- +-- Throws @'EncoderFailed'@. liftBool :: Decoder -> IO Bool -> IO () liftBool encoder m = liftIO m >>= bool (throwState encoder) (return ()) -- | Get 'DecoderState' from a given 'Decoder' and throw it immediately. - throwState :: Decoder -> IO a throwState = decoderGetState >=> throwIO . DecoderFailed diff --git a/Codec/Audio/FLAC/StreamDecoder/Internal.hs b/Codec/Audio/FLAC/StreamDecoder/Internal.hs --- a/Codec/Audio/FLAC/StreamDecoder/Internal.hs +++ b/Codec/Audio/FLAC/StreamDecoder/Internal.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE LambdaCase #-} + -- | -- Module : Codec.Audio.FLAC.StreamDecoder.Internal --- Copyright : © 2016–2019 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -8,18 +11,15 @@ -- Portability : portable -- -- Low-level Haskell wrapper around FLAC stream decoder API. - -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE LambdaCase #-} - module Codec.Audio.FLAC.StreamDecoder.Internal - ( withDecoder - , decoderSetMd5Checking - , decoderGetState - , decoderGetBlockSize - , decoderProcessSingle - , decoderProcessUntilEndOfMetadata - , decoderFinish ) + ( withDecoder, + decoderSetMd5Checking, + decoderGetState, + decoderGetBlockSize, + decoderProcessSingle, + decoderProcessUntilEndOfMetadata, + decoderFinish, + ) where import Codec.Audio.FLAC.StreamDecoder.Internal.Types @@ -33,16 +33,15 @@ -- -- If memory for the encoder cannot be allocated, corresponding -- 'DecoderException' is raised. - withDecoder :: (Decoder -> IO a) -> IO a withDecoder f = bracket decoderNew (mapM_ decoderDelete) $ \case - Nothing -> throwM - (DecoderFailed DecoderStateMemoryAllocationError) + Nothing -> + throwM + (DecoderFailed DecoderStateMemoryAllocationError) Just x -> f x -- | Create a new stream decoder instance with the default settings. In the -- case of memory allocation problem 'Nothing' is returned. - decoderNew :: IO (Maybe Decoder) decoderNew = maybePtr <$> c_decoder_new @@ -50,7 +49,6 @@ c_decoder_new :: IO Decoder -- | Free a decoder instance. - decoderDelete :: Decoder -> IO () decoderDelete = c_decoder_delete @@ -60,7 +58,6 @@ -- | Set MD5 signature checking. If 'True' the decoder will compute the MD5 -- signature of the unencoded audio data while decoding and compare it to -- the signature from the stream info block. - decoderSetMd5Checking :: Decoder -> Bool -> IO Bool decoderSetMd5Checking = c_decoder_set_md5_checking @@ -68,7 +65,6 @@ c_decoder_set_md5_checking :: Decoder -> Bool -> IO Bool -- | Get the current decoder state. - decoderGetState :: Decoder -> IO DecoderState decoderGetState = fmap toEnum' . c_decoder_get_state @@ -77,7 +73,6 @@ -- | Get frame size as a number of inter-channel samples of last decoded -- frame. - decoderGetBlockSize :: Decoder -> IO Word32 decoderGetBlockSize = fmap fromIntegral . c_decoder_get_blocksize @@ -85,7 +80,6 @@ c_decoder_get_blocksize :: Decoder -> IO CUInt -- | Process one audio frame. Return 'False' on failure. - decoderProcessSingle :: Decoder -> IO Bool decoderProcessSingle = c_decoder_process_single @@ -94,7 +88,6 @@ -- | Decode until the end of the metadata. We use this to skip to the audio -- stream. - decoderProcessUntilEndOfMetadata :: Decoder -> IO Bool decoderProcessUntilEndOfMetadata = c_decoder_process_until_end_of_metadata @@ -103,7 +96,6 @@ -- | Finish the decoding process and release resources (also resets decoder -- and its settings). Return 'False' in the case of trouble. - decoderFinish :: Decoder -> IO Bool decoderFinish = c_decoder_finish diff --git a/Codec/Audio/FLAC/StreamDecoder/Internal/Helpers.hs b/Codec/Audio/FLAC/StreamDecoder/Internal/Helpers.hs --- a/Codec/Audio/FLAC/StreamDecoder/Internal/Helpers.hs +++ b/Codec/Audio/FLAC/StreamDecoder/Internal/Helpers.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + -- | -- Module : Codec.Audio.FLAC.StreamDecoder.Internal.Helpers --- Copyright : © 2016–2019 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -8,11 +10,9 @@ -- Portability : portable -- -- Wrappers around helpers written to help work with the stream decoder. - -{-# LANGUAGE ForeignFunctionInterface #-} - module Codec.Audio.FLAC.StreamDecoder.Internal.Helpers - ( decoderInitHelper ) + ( decoderInitHelper, + ) where import Codec.Audio.FLAC.StreamDecoder.Internal.Types @@ -25,23 +25,26 @@ -- | Initialize decoder to decode FLAC file and register buffer where -- decoded audio data will go (which must be big enough). Return -- 'DecoderInitStatus'. - -decoderInitHelper - :: Decoder -- ^ 'Decoder' to use - -> FilePath -- ^ FLAC file to decode - -> Ptr Void -- ^ Buffer where to write decoded audio data - -> IO DecoderInitStatus - -- ^ Sample rate, bits per sample, channels +decoderInitHelper :: + -- | 'Decoder' to use + Decoder -> + -- | FLAC file to decode + FilePath -> + -- | Buffer where to write decoded audio data + Ptr Void -> + -- | Sample rate, bits per sample, channels + IO DecoderInitStatus decoderInitHelper decoder ipath buffer = withCString ipath $ \ipathPtr -> - toEnum' <$> c_decoder_init_helper - decoder -- stream decoder - ipathPtr -- name of FLAC file to decode - buffer -- output buffer + toEnum' + <$> c_decoder_init_helper + decoder -- stream decoder + ipathPtr -- name of FLAC file to decode + buffer -- output buffer foreign import ccall unsafe "FLAC__stream_decoder_init_helper" - c_decoder_init_helper - :: Decoder - -> CString - -> Ptr Void - -> IO CUInt + c_decoder_init_helper :: + Decoder -> + CString -> + Ptr Void -> + IO CUInt diff --git a/Codec/Audio/FLAC/StreamDecoder/Internal/Types.hs b/Codec/Audio/FLAC/StreamDecoder/Internal/Types.hs --- a/Codec/Audio/FLAC/StreamDecoder/Internal/Types.hs +++ b/Codec/Audio/FLAC/StreamDecoder/Internal/Types.hs @@ -1,6 +1,6 @@ -- | -- Module : Codec.Audio.FLAC.StreamDecoder.Internal.Types --- Copyright : © 2016–2019 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -8,13 +8,13 @@ -- Portability : portable -- -- Mostly non-public stream decoder-specific helper types. - module Codec.Audio.FLAC.StreamDecoder.Internal.Types - ( Decoder (..) - , DecoderInitStatus (..) - , DecoderState (..) - , DecoderException (..) - , ChannelAssignment (..) ) + ( Decoder (..), + DecoderInitStatus (..), + DecoderState (..), + DecoderException (..), + ChannelAssignment (..), + ) where import Control.Exception @@ -23,71 +23,70 @@ -- | An opaque newtype wrapper around @'Ptr' 'Void'@, serves to represent -- point to decoder instance. - newtype Decoder = Decoder (Ptr Void) -- | Status of decoder initialization process. - data DecoderInitStatus - = DecoderInitStatusOK - -- ^ Initialization was successful. - | DecoderInitStatusUnsupportedContainer - -- ^ The library was not compiled with support for the given container + = -- | Initialization was successful. + DecoderInitStatusOK + | -- | The library was not compiled with support for the given container -- format. - | DecoderInitStatusInvalidCallbacks - -- ^ A required callback was not supplied. - | DecoderInitStatusMemoryAllocationError - -- ^ An error occurred allocating memory. - | DecoderInitStatusErrorOpeningFile - -- ^ fopen() failed. - | DecoderInitStatusAlreadyInitialized - -- ^ Initialization was attempted on already initialized decoder. + DecoderInitStatusUnsupportedContainer + | -- | A required callback was not supplied. + DecoderInitStatusInvalidCallbacks + | -- | An error occurred allocating memory. + DecoderInitStatusMemoryAllocationError + | -- | fopen() failed. + DecoderInitStatusErrorOpeningFile + | -- | Initialization was attempted on already initialized decoder. + DecoderInitStatusAlreadyInitialized deriving (Show, Read, Eq, Ord, Bounded, Enum) -- | Enumeration of decoder states. - data DecoderState - = DecoderStateSearchForMetadata - -- ^ The decoder is ready to search for metadata. - | DecoderStateReadMetadata - -- ^ The decoder is ready to or is in the process of reading metadata. - | DecoderStateSearchForFrameSync - -- ^ The decoder is ready to or is in the process of searching for the + = -- | The decoder is ready to search for metadata. + DecoderStateSearchForMetadata + | -- | The decoder is ready to or is in the process of reading metadata. + DecoderStateReadMetadata + | -- | The decoder is ready to or is in the process of searching for the -- frame sync code. - | DecoderStateReadFrame - -- ^ The decoder is ready to or is in the process of reading a frame. - | DecoderStateEndOfStream - -- ^ The decoder has reached the end of the stream. - | DecoderStateOggError - -- ^ An error occurred in the underlying Ogg layer. - | DecoderStateSeekError - -- ^ An error occurred while seeking. The decoder must be flushed or + DecoderStateSearchForFrameSync + | -- | The decoder is ready to or is in the process of reading a frame. + DecoderStateReadFrame + | -- | The decoder has reached the end of the stream. + DecoderStateEndOfStream + | -- | An error occurred in the underlying Ogg layer. + DecoderStateOggError + | -- | An error occurred while seeking. The decoder must be flushed or -- reset before decoding can continue. - | DecoderStateAborted - -- ^ The decoder was aborted by the read callback. - | DecoderStateMemoryAllocationError - -- ^ An error occurred allocating memory. The decoder is in an invalid + DecoderStateSeekError + | -- | The decoder was aborted by the read callback. + DecoderStateAborted + | -- | An error occurred allocating memory. The decoder is in an invalid -- state and can no longer be used. - | DecoderStateUnititialized - -- ^ The decoder is in the uninitialized state. + DecoderStateMemoryAllocationError + | -- | The decoder is in the uninitialized state. + DecoderStateUnititialized deriving (Show, Read, Eq, Ord, Bounded, Enum) -- | Exception that is thrown when decoding fails for some reason. - data DecoderException - = DecoderInitFailed DecoderInitStatus - -- ^ Decoder initialization failed. - | DecoderFailed DecoderState - -- ^ Decoder failed. + = -- | Decoder initialization failed. + DecoderInitFailed DecoderInitStatus + | -- | Decoder failed. + DecoderFailed DecoderState deriving (Eq, Show, Read) instance Exception DecoderException -- | An enumeration of the available channel assignments. - data ChannelAssignment - = ChannelAssignmentIndependent -- ^ Independent channels - | ChannelAssignmentLeftSide -- ^ Left+side stereo - | ChannelAssignmentRightSide -- ^ Right+side stereo - | ChannelAssignmentMidSide -- ^ Mid+side stereo + = -- | Independent channels + ChannelAssignmentIndependent + | -- | Left+side stereo + ChannelAssignmentLeftSide + | -- | Right+side stereo + ChannelAssignmentRightSide + | -- | Mid+side stereo + ChannelAssignmentMidSide deriving (Show, Read, Eq, Ord, Bounded, Enum) diff --git a/Codec/Audio/FLAC/StreamEncoder.hs b/Codec/Audio/FLAC/StreamEncoder.hs --- a/Codec/Audio/FLAC/StreamEncoder.hs +++ b/Codec/Audio/FLAC/StreamEncoder.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE RecordWildCards #-} + -- | -- Module : Codec.Audio.FLAC.StreamEncoder --- Copyright : © 2016–2019 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -12,8 +14,7 @@ -- === How to use this module -- -- Just call the 'encodeFlac' function with 'EncoderSettings', input and --- output file names. The 'encodeFlac' function only encodes vanilla WAVE --- and RF64. +-- output file names. The 'encodeFlac' function only encodes WAVE and RF64. -- -- === Low-level details -- @@ -25,16 +26,14 @@ -- Encoding speed is equal to that of @flac@ command line tool. Memory -- consumption is minimal and remains constant regardless of size of file to -- decode. - -{-# LANGUAGE RecordWildCards #-} - module Codec.Audio.FLAC.StreamEncoder - ( EncoderSettings (..) - , defaultEncoderSettings - , EncoderException (..) - , EncoderInitStatus (..) - , EncoderState (..) - , encodeFlac ) + ( EncoderSettings (..), + defaultEncoderSettings, + EncoderException (..), + EncoderInitStatus (..), + EncoderState (..), + encodeFlac, + ) where import Codec.Audio.FLAC.StreamEncoder.Internal @@ -59,47 +58,45 @@ -- specifying 'Nothing' (default), or use something specific by passing a -- value inside 'Just'. Thorough understanding of the FLAC format is -- necessary to achieve good results, though. - data EncoderSettings = EncoderSettings - { encoderCompression :: !Word32 - -- ^ Compression level [0..8], default is 5. - , encoderBlockSize :: !Word32 - -- ^ Block size, default is 0. - , encoderVerify :: !Bool - -- ^ Verify result (slower), default is 'False'. - , encoderDoMidSideStereo :: !(Maybe Bool) - -- ^ Enable mid-side encoding on stereo input. The number of channels + { -- | Compression level [0..8], default is 5. + encoderCompression :: !Word32, + -- | Block size, default is 0. + encoderBlockSize :: !Word32, + -- | Verify result (slower), default is 'False'. + encoderVerify :: !Bool, + -- | Enable mid-side encoding on stereo input. The number of channels -- must be 2 for this to have any effect. Default value: 'Nothing'. - , encoderLooseMidSideStereo :: !(Maybe Bool) - -- ^ Set to 'True' to enable adaptive switching between mid-side and + encoderDoMidSideStereo :: !(Maybe Bool), + -- | Set to 'True' to enable adaptive switching between mid-side and -- left-right encoding on stereo input. Set to 'False' to use exhaustive -- searching. Setting this to 'True' requires 'encoderDoMidSideStereo' -- to also be set to 'True' in order to have any effect. Default value: -- 'Nothing'. - , encoderApodization :: !(Maybe (NonEmpty ApodizationFunction)) - -- ^ Sets the apodization function(s) the encoder will use when + encoderLooseMidSideStereo :: !(Maybe Bool), + -- | Sets the apodization function(s) the encoder will use when -- windowing audio data for LPC analysis. Up to 32 functions are kept, -- the rest are dropped. Import -- "Codec.Audio.FLAC.StreamEncoder.Apodization" to bring apodization -- functions in scope. Default value: 'Nothing'. - , encoderMaxLpcOrder :: !(Maybe Word32) - -- ^ Set maximum LPC order, or 0 to use the fixed predictors. Default + encoderApodization :: !(Maybe (NonEmpty ApodizationFunction)), + -- | Set maximum LPC order, or 0 to use the fixed predictors. Default -- value: 'Nothing'. - , encoderQlpCoeffPrecision :: !(Maybe Word32) - -- ^ Set the precision in bits of the quantized linear predictor + encoderMaxLpcOrder :: !(Maybe Word32), + -- | Set the precision in bits of the quantized linear predictor -- coefficients, or 0 to let the encoder select it based on the -- blocksize. Default value: 'Nothing'. - , encoderDoQlpCoeffPrecisionSearch :: !(Maybe Bool) - -- ^ Set to 'False' to use only the specified quantized linear predictor + encoderQlpCoeffPrecision :: !(Maybe Word32), + -- | Set to 'False' to use only the specified quantized linear predictor -- coefficient precision, or 'True' to search neighboring precision -- values and use the best one. Default value: 'Nothing'. - , encoderDoExhaustiveModelSearch :: !(Maybe Bool) - -- ^ Set to 'False' to let the encoder estimate the best model order + encoderDoQlpCoeffPrecisionSearch :: !(Maybe Bool), + -- | Set to 'False' to let the encoder estimate the best model order -- based on the residual signal energy, or 'True' to force the encoder -- to evaluate all order models and select the best. Default value: -- 'Nothing'. - , encoderResidualPartitionOrders :: !(Maybe (Word32, Word32)) - -- ^ Set the minimum and maximum partition order to search when coding + encoderDoExhaustiveModelSearch :: !(Maybe Bool), + -- | Set the minimum and maximum partition order to search when coding -- the residual. The partition order determines the context size in the -- residual. The context size will be approximately @blocksize / (2 ^ -- order)@. Set both min and max values to 0 to force a single context, @@ -107,26 +104,28 @@ -- Otherwise, set a min and max order, and the encoder will search all -- orders, using the mean of each context for its Rice parameter, and -- use the best. Default: 'Nothing'. - } deriving (Show, Read, Eq, Ord) + encoderResidualPartitionOrders :: !(Maybe (Word32, Word32)) + } + deriving (Show, Read, Eq, Ord) -- | Default 'EncoderSettings'. -- -- @since 0.2.0 - defaultEncoderSettings :: EncoderSettings -defaultEncoderSettings = EncoderSettings - { encoderCompression = 5 - , encoderBlockSize = 0 - , encoderVerify = False - , encoderDoMidSideStereo = Nothing - , encoderLooseMidSideStereo = Nothing - , encoderApodization = Nothing - , encoderMaxLpcOrder = Nothing - , encoderQlpCoeffPrecision = Nothing - , encoderDoQlpCoeffPrecisionSearch = Nothing - , encoderDoExhaustiveModelSearch = Nothing - , encoderResidualPartitionOrders = Nothing - } +defaultEncoderSettings = + EncoderSettings + { encoderCompression = 5, + encoderBlockSize = 0, + encoderVerify = False, + encoderDoMidSideStereo = Nothing, + encoderLooseMidSideStereo = Nothing, + encoderApodization = Nothing, + encoderMaxLpcOrder = Nothing, + encoderQlpCoeffPrecision = Nothing, + encoderDoQlpCoeffPrecisionSearch = Nothing, + encoderDoExhaustiveModelSearch = Nothing, + encoderResidualPartitionOrders = Nothing + } -- | Encode a WAVE file or RF64 file to native FLAC. -- @@ -140,46 +139,58 @@ -- * Number of channels may be only 1–8 inclusive. -- * Supported values for bits per sample are 4–24 inclusive. -- * Acceptable sample rate lies in the range 1–655350 inclusive. - -encodeFlac :: MonadIO m - => EncoderSettings -- ^ Encoder settings - -> FilePath -- ^ File to encode - -> FilePath -- ^ Where to save the resulting FLAC file - -> m () +encodeFlac :: + (MonadIO m) => + -- | Encoder settings + EncoderSettings -> + -- | File to encode + FilePath -> + -- | Where to save the resulting FLAC file + FilePath -> + m () encodeFlac EncoderSettings {..} ipath' opath' = liftIO . withEncoder $ \e -> do ipath <- makeAbsolute ipath' opath <- makeAbsolute opath' - wave <- readWaveFile ipath + wave <- readWaveFile ipath case waveSampleFormat wave of SampleFormatPcmInt _ -> return () fmt -> throwIO (EncoderInvalidSampleFormat fmt) - let channels = fromIntegral (waveChannels wave) + let channels = fromIntegral (waveChannels wave) bitsPerSample = fromIntegral (waveBitsPerSample wave) - sampleRate = waveSampleRate wave - totalSamples = waveSamplesTotal wave - liftInit (encoderSetChannels e channels) + sampleRate = waveSampleRate wave + totalSamples = waveSamplesTotal wave + liftInit (encoderSetChannels e channels) liftInit (encoderSetBitsPerSample e bitsPerSample) - liftInit (encoderSetSampleRate e sampleRate) - liftInit (encoderSetCompression e encoderCompression) - liftInit (encoderSetBlockSize e encoderBlockSize) - liftInit (encoderSetVerify e encoderVerify) - forM_ encoderDoMidSideStereo + liftInit (encoderSetSampleRate e sampleRate) + liftInit (encoderSetCompression e encoderCompression) + liftInit (encoderSetBlockSize e encoderBlockSize) + liftInit (encoderSetVerify e encoderVerify) + forM_ + encoderDoMidSideStereo (liftInit . encoderSetDoMidSideStereo e) - forM_ encoderLooseMidSideStereo + forM_ + encoderLooseMidSideStereo (liftInit . encoderSetLooseMidSideStereo e) - forM_ encoderApodization + forM_ + encoderApodization (liftInit . encoderSetApodization e . renderApodizationSpec) - forM_ encoderMaxLpcOrder + forM_ + encoderMaxLpcOrder (liftInit . encoderSetMaxLpcOrder e) - forM_ encoderQlpCoeffPrecision + forM_ + encoderQlpCoeffPrecision (liftInit . encoderSetQlpCoeffPrecision e) - forM_ encoderDoQlpCoeffPrecisionSearch + forM_ + encoderDoQlpCoeffPrecisionSearch (liftInit . encoderSetDoQlpCoeffPrecisionSearch e) - forM_ encoderDoExhaustiveModelSearch + forM_ + encoderDoExhaustiveModelSearch (liftInit . encoderSetDoExhaustiveModelSearch e) - forM_ encoderResidualPartitionOrders + forM_ + encoderResidualPartitionOrders (liftInit . encoderSetMinResidualPartitionOrder e . fst) - forM_ encoderResidualPartitionOrders + forM_ + encoderResidualPartitionOrders (liftInit . encoderSetMaxResidualPartitionOrder e . snd) -- Set the estimate (which is likely correct), to avoid rewrite of -- STREAMINFO metadata block after encoding. @@ -189,10 +200,12 @@ case initStatus of EncoderInitStatusOK -> return () status -> throwIO (EncoderInitFailed status) - liftBool e $ encoderProcessHelper e - (fromIntegral $ waveDataOffset wave) - (waveDataSize wave) - ipath + liftBool e $ + encoderProcessHelper + e + (fromIntegral $ waveDataOffset wave) + (waveDataSize wave) + ipath liftBool e (encoderFinish e) renameFile otemp opath @@ -200,22 +213,21 @@ -- Helpers -- | Execute an initializing action that returns 'False' on failure and take --- care of error reporting. In case of trouble, @'EncoderInitFailed' --- 'EncoderInitStatusAlreadyInitialized'@ is thrown. - +-- care of error reporting. +-- +-- Throws @'EncoderInitFailed' 'EncoderInitStatusAlreadyInitialized'@. liftInit :: IO Bool -> IO () liftInit m = liftIO m >>= bool t (return ()) where t = throwIO (EncoderInitFailed EncoderInitStatusAlreadyInitialized) -- | Execute an action that returns 'False' on failure into taking care of --- error reporting. In case of trouble @'EncoderFailed'@ with encoder status --- attached is thrown. - +-- error reporting. +-- +-- Throws @'EncoderFailed'@. liftBool :: Encoder -> IO Bool -> IO () liftBool encoder m = liftIO m >>= bool (throwState encoder) (return ()) -- | Get 'EncoderState' from given 'Encoder' and throw it immediately. - throwState :: Encoder -> IO a throwState = encoderGetState >=> throwIO . EncoderFailed diff --git a/Codec/Audio/FLAC/StreamEncoder/Apodization.hs b/Codec/Audio/FLAC/StreamEncoder/Apodization.hs --- a/Codec/Audio/FLAC/StreamEncoder/Apodization.hs +++ b/Codec/Audio/FLAC/StreamEncoder/Apodization.hs @@ -1,6 +1,6 @@ -- | -- Module : Codec.Audio.FLAC.StreamEncoder.Apodization --- Copyright : © 2016–2019 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -11,9 +11,9 @@ -- needed, and thus should not “contaminate” the -- "Codec.Audio.FLAC.StreamEncoder" module with potentially confilcting -- names. - module Codec.Audio.FLAC.StreamEncoder.Apodization - ( ApodizationFunction (..) ) + ( ApodizationFunction (..), + ) where import Codec.Audio.FLAC.StreamEncoder.Internal.Types diff --git a/Codec/Audio/FLAC/StreamEncoder/Internal.hs b/Codec/Audio/FLAC/StreamEncoder/Internal.hs --- a/Codec/Audio/FLAC/StreamEncoder/Internal.hs +++ b/Codec/Audio/FLAC/StreamEncoder/Internal.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE LambdaCase #-} + -- | -- Module : Codec.Audio.FLAC.StreamEncoder.Internal --- Copyright : © 2016–2019 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -10,58 +13,54 @@ -- Low-level Haskell wrapper around FLAC stream encoder API, see: -- -- - -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE LambdaCase #-} - module Codec.Audio.FLAC.StreamEncoder.Internal - ( withEncoder - , encoderSetChannels - , encoderSetBitsPerSample - , encoderSetSampleRate - , encoderSetCompression - , encoderSetBlockSize - , encoderSetDoMidSideStereo - , encoderSetLooseMidSideStereo - , encoderSetApodization - , encoderSetMaxLpcOrder - , encoderSetQlpCoeffPrecision - , encoderSetDoQlpCoeffPrecisionSearch - , encoderSetDoExhaustiveModelSearch - , encoderSetMinResidualPartitionOrder - , encoderSetMaxResidualPartitionOrder - , encoderSetTotalSamplesEstimate - , encoderSetVerify - , encoderGetState - , encoderInitFile - , encoderFinish ) + ( withEncoder, + encoderSetChannels, + encoderSetBitsPerSample, + encoderSetSampleRate, + encoderSetCompression, + encoderSetBlockSize, + encoderSetDoMidSideStereo, + encoderSetLooseMidSideStereo, + encoderSetApodization, + encoderSetMaxLpcOrder, + encoderSetQlpCoeffPrecision, + encoderSetDoQlpCoeffPrecisionSearch, + encoderSetDoExhaustiveModelSearch, + encoderSetMinResidualPartitionOrder, + encoderSetMaxResidualPartitionOrder, + encoderSetTotalSamplesEstimate, + encoderSetVerify, + encoderGetState, + encoderInitFile, + encoderFinish, + ) where import Codec.Audio.FLAC.StreamEncoder.Internal.Types import Codec.Audio.FLAC.Util import Control.Monad.Catch import Data.ByteString (ByteString) +import Data.ByteString qualified as B import Data.Void import Foreign import Foreign.C.String import Foreign.C.Types -import qualified Data.ByteString as B -- | Create and use an 'Encoder'. The encoder is guaranteed to be freed even -- in the case of exception. -- -- If memory for the encoder cannot be allocated, corresponding -- 'EncoderException' is raised. - withEncoder :: (Encoder -> IO a) -> IO a withEncoder f = bracket encoderNew (mapM_ encoderDelete) $ \case - Nothing -> throwM - (EncoderFailed EncoderStateMemoryAllocationError) + Nothing -> + throwM + (EncoderFailed EncoderStateMemoryAllocationError) Just x -> f x -- | Create a new stream encoder instance with the default settings. In the -- case of memory allocation problem 'Nothing' is returned. - encoderNew :: IO (Maybe Encoder) encoderNew = maybePtr <$> c_encoder_new @@ -69,7 +68,6 @@ c_encoder_new :: IO Encoder -- | Free an encoder instance. - encoderDelete :: Encoder -> IO () encoderDelete = c_encoder_delete @@ -78,7 +76,6 @@ -- | Set the number of channels to be encoded. Return 'False' if encoder is -- already initialized. - encoderSetChannels :: Encoder -> Word32 -> IO Bool encoderSetChannels encoder channels = c_encoder_set_channels encoder (fromIntegral channels) @@ -88,7 +85,6 @@ -- | Set the sample resolution of the input to be encoded. Return 'False' if -- encoder is already initialized. - encoderSetBitsPerSample :: Encoder -> Word32 -> IO Bool encoderSetBitsPerSample encoder bps = c_encoder_set_bits_per_sample encoder (fromIntegral bps) @@ -98,7 +94,6 @@ -- | Set the sample rate in Hz of the input to be encoded. Return 'False' if -- encoder is already initialized. - encoderSetSampleRate :: Encoder -> Word32 -> IO Bool encoderSetSampleRate encoder sampleRate = c_encoder_set_sample_rate encoder (fromIntegral sampleRate) @@ -109,7 +104,6 @@ -- | Set the compression level. The argument can range from 0 (fastest, -- least compression) to 8 (slowest, most compression). A value higher than -- 8 will be treated as 8. Return 'False' if encoder is already initialized. - encoderSetCompression :: Encoder -> Word32 -> IO Bool encoderSetCompression encoder level = c_encoder_set_compression_level encoder (fromIntegral level) @@ -118,7 +112,6 @@ c_encoder_set_compression_level :: Encoder -> CUInt -> IO Bool -- | Set the blocksize to use while encoding. - encoderSetBlockSize :: Encoder -> Word32 -> IO Bool encoderSetBlockSize encoder blockSize = c_encoder_set_blocksize encoder (fromIntegral blockSize) @@ -127,7 +120,6 @@ c_encoder_set_blocksize :: Encoder -> CUInt -> IO Bool -- | Set to 'True' to enable mid-side encoding on stereo input. - encoderSetDoMidSideStereo :: Encoder -> Bool -> IO Bool encoderSetDoMidSideStereo = c_encoder_set_do_mid_side_stereo @@ -137,7 +129,6 @@ -- | Set to 'True' to enable adaptive switching between mid-side and -- left-right encoding on stereo input. Set to 'False' to use exhaustive -- searching. - encoderSetLooseMidSideStereo :: Encoder -> Bool -> IO Bool encoderSetLooseMidSideStereo = c_encoder_set_loose_mid_side_stereo @@ -146,7 +137,6 @@ -- | Set the apodization function(s) the encoder will use when windowing -- audio data for LPC analysis. - encoderSetApodization :: Encoder -> ByteString -> IO Bool encoderSetApodization encoder specification = B.useAsCString specification (c_encoder_set_apodization encoder) @@ -155,7 +145,6 @@ c_encoder_set_apodization :: Encoder -> CString -> IO Bool -- | Set the maximum LPC order, or 0 to use only the fixed predictors. - encoderSetMaxLpcOrder :: Encoder -> Word32 -> IO Bool encoderSetMaxLpcOrder encoder value = c_encoder_set_max_lpc_order encoder (fromIntegral value) @@ -165,7 +154,6 @@ -- | Set the precision in bits, of the quantized linear predictor -- coefficients, or 0 to let the encoder select it based on the blocksize. - encoderSetQlpCoeffPrecision :: Encoder -> Word32 -> IO Bool encoderSetQlpCoeffPrecision encoder value = c_encoder_set_qlp_coeff_precision encoder (fromIntegral value) @@ -176,7 +164,6 @@ -- | Set to 'False' to use only the specified quantized linear predictor -- coefficient precision, or 'True' to search neighboring precision values -- and use the best one. - encoderSetDoQlpCoeffPrecisionSearch :: Encoder -> Bool -> IO Bool encoderSetDoQlpCoeffPrecisionSearch = c_encoder_set_qlp_coeff_prec_search @@ -186,7 +173,6 @@ -- | Set to 'False' to let the encoder estimate the best model order based -- on the residual signal energy, or 'True' to force the encoder to evaluate -- all order models and select the best. - encoderSetDoExhaustiveModelSearch :: Encoder -> Bool -> IO Bool encoderSetDoExhaustiveModelSearch = c_encoder_set_do_exhaustive_model_search @@ -194,7 +180,6 @@ c_encoder_set_do_exhaustive_model_search :: Encoder -> Bool -> IO Bool -- | Set the minimum partition order to search when coding the residual. - encoderSetMinResidualPartitionOrder :: Encoder -> Word32 -> IO Bool encoderSetMinResidualPartitionOrder encoder value = c_encoder_set_min_residual_partition_order encoder (fromIntegral value) @@ -203,7 +188,6 @@ c_encoder_set_min_residual_partition_order :: Encoder -> CUInt -> IO Bool -- | Set the maximum partition order to search when coding the residual. - encoderSetMaxResidualPartitionOrder :: Encoder -> Word32 -> IO Bool encoderSetMaxResidualPartitionOrder encoder value = c_encoder_set_max_residual_partition_order encoder (fromIntegral value) @@ -216,7 +200,6 @@ -- written to the STREAMINFO block before encoding, and can remove the need -- for the caller to rewrite the value later if the value is known before -- encoding. - encoderSetTotalSamplesEstimate :: Encoder -> Word64 -> IO Bool encoderSetTotalSamplesEstimate = c_encoder_set_total_samples_estimate @@ -228,7 +211,6 @@ -- the original signal against the decoded signal. If a mismatch occurs, the -- process call will return false. Note that this will slow the encoding -- process by the extra time required for decoding and comparison. - encoderSetVerify :: Encoder -> Bool -> IO Bool encoderSetVerify = c_encoder_set_verify @@ -236,7 +218,6 @@ c_encoder_set_verify :: Encoder -> Bool -> IO Bool -- | Get the current encoder state. - encoderGetState :: Encoder -> IO EncoderState encoderGetState = fmap toEnum' . c_encoder_get_state @@ -244,11 +225,12 @@ c_encoder_get_state :: Encoder -> IO CUInt -- | Initialize the encoder instance to encode native FLAC files. - -encoderInitFile - :: Encoder -- ^ Uninitialized encoder instance - -> FilePath -- ^ Name of file to encode to - -> IO EncoderInitStatus +encoderInitFile :: + -- | Uninitialized encoder instance + Encoder -> + -- | Name of file to encode to + FilePath -> + IO EncoderInitStatus encoderInitFile encoder path = withCString path $ \cstr -> toEnum' <$> c_encoder_init_file encoder cstr nullPtr nullPtr @@ -258,7 +240,6 @@ -- | Finish the encoding process and release resources (also resets encoder -- and its settings). Return 'False' in case of trouble. - encoderFinish :: Encoder -> IO Bool encoderFinish = c_encoder_finish diff --git a/Codec/Audio/FLAC/StreamEncoder/Internal/Helpers.hs b/Codec/Audio/FLAC/StreamEncoder/Internal/Helpers.hs --- a/Codec/Audio/FLAC/StreamEncoder/Internal/Helpers.hs +++ b/Codec/Audio/FLAC/StreamEncoder/Internal/Helpers.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} + -- | -- Module : Codec.Audio.FLAC.StreamEncoder.Internal.Helpers --- Copyright : © 2016–2019 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -8,73 +11,72 @@ -- Portability : portable -- -- Wrappers around helpers written to help work with the stream encoder. - -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE OverloadedStrings #-} - module Codec.Audio.FLAC.StreamEncoder.Internal.Helpers - ( encoderProcessHelper - , renderApodizationSpec ) + ( encoderProcessHelper, + renderApodizationSpec, + ) where import Codec.Audio.FLAC.StreamEncoder.Internal.Types import Data.ByteString (ByteString) +import Data.ByteString.Builder qualified as BU +import Data.ByteString.Lazy qualified as BL import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Monoid ((<>)) +import Data.List.NonEmpty qualified as NE import Data.Word (Word64) import Foreign.C.String import Numeric.Natural -import qualified Data.ByteString.Builder as BU -import qualified Data.ByteString.Lazy as BL -import qualified Data.List.NonEmpty as NE -- | Encode given input file, return 'False' in case of failure. - -encoderProcessHelper - :: Encoder -- ^ 'Encoder' to use - -> Word64 -- ^ Offset of data chunk - -> Word64 -- ^ Size of data chunk - -> FilePath -- ^ Location of input file (normalized) - -> IO Bool -- ^ 'False' in case of trouble +encoderProcessHelper :: + -- | 'Encoder' to use + Encoder -> + -- | Offset of data chunk + Word64 -> + -- | Size of data chunk + Word64 -> + -- | Location of input file (normalized) + FilePath -> + -- | 'False' in case of trouble + IO Bool encoderProcessHelper encoder dataOffset dataSize ipath = withCString ipath $ \ipathPtr -> c_encoder_process_helper - encoder -- stream encoder - dataOffset -- offset of data chunk - dataSize -- size of data chunk - ipathPtr -- path to input file + encoder -- stream encoder + dataOffset -- offset of data chunk + dataSize -- size of data chunk + ipathPtr -- path to input file foreign import ccall unsafe "FLAC__stream_encoder_process_helper" c_encoder_process_helper :: Encoder -> Word64 -> Word64 -> CString -> IO Bool -- | Render apodization functions specification as per description here: -- . - renderApodizationSpec :: NonEmpty ApodizationFunction -> ByteString renderApodizationSpec = - BL.toStrict . - BU.toLazyByteString . - mconcat . - intersperse ";" . - NE.toList . - fmap f + BL.toStrict + . BU.toLazyByteString + . mconcat + . intersperse ";" + . NE.toList + . fmap f where f :: ApodizationFunction -> BU.Builder - f Bartlett = "bartlett" - f BartlettHann = "bartlett_hann" - f Blackman = "blackman" + f Bartlett = "bartlett" + f BartlettHann = "bartlett_hann" + f Blackman = "blackman" f BlackmanHarris4Term92Db = "blackman_harris_4term_92db" - f Connes = "connes" - f Flattop = "flattop" - f (Gauss stddev) = "gauss(" <> BU.doubleDec stddev <> ")" - f Hamming = "hamming" - f Hann = "hann" - f KaiserBessel = "kaiser_bessel" - f Nuttall = "nuttall" - f Rectangle = "rectangle" - f Triangle = "triangle" - f (Tukey p) = "tukey(" <> BU.doubleDec p <> ")" + f Connes = "connes" + f Flattop = "flattop" + f (Gauss stddev) = "gauss(" <> BU.doubleDec stddev <> ")" + f Hamming = "hamming" + f Hann = "hann" + f KaiserBessel = "kaiser_bessel" + f Nuttall = "nuttall" + f Rectangle = "rectangle" + f Triangle = "triangle" + f (Tukey p) = "tukey(" <> BU.doubleDec p <> ")" f (PartialTukey n Nothing) = "partial_tukey(" <> natDec n <> ")" f (PartialTukey n (Just (ov, Nothing))) = @@ -87,6 +89,6 @@ "punchout_tukey(" <> natDec n <> "/" <> BU.doubleDec ov <> ")" f (PunchoutTukey n (Just (ov, Just p))) = "punchout_tukey(" <> natDec n <> "/" <> BU.doubleDec ov <> "/" <> BU.doubleDec p <> ")" - f Welch = "welch" + f Welch = "welch" natDec :: Natural -> BU.Builder natDec = BU.integerDec . fromIntegral diff --git a/Codec/Audio/FLAC/StreamEncoder/Internal/Types.hs b/Codec/Audio/FLAC/StreamEncoder/Internal/Types.hs --- a/Codec/Audio/FLAC/StreamEncoder/Internal/Types.hs +++ b/Codec/Audio/FLAC/StreamEncoder/Internal/Types.hs @@ -1,6 +1,6 @@ -- | -- Module : Codec.Audio.FLAC.StreamEncoder.Internal.Types --- Copyright : © 2016–2019 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -8,13 +8,13 @@ -- Portability : portable -- -- Mostly non-public stream encoder-specific helper types. - module Codec.Audio.FLAC.StreamEncoder.Internal.Types - ( Encoder (..) - , EncoderInitStatus (..) - , EncoderState (..) - , EncoderException (..) - , ApodizationFunction (..) ) + ( Encoder (..), + EncoderInitStatus (..), + EncoderState (..), + EncoderException (..), + ApodizationFunction (..), + ) where import Codec.Audio.Wave (SampleFormat) @@ -25,87 +25,82 @@ -- | An opaque newtype wrapper around @'Ptr' 'Void'@, serves to represent a -- pointer to an encoder instance. - newtype Encoder = Encoder (Ptr Void) -- | Status of encoder initialization process. - data EncoderInitStatus - = EncoderInitStatusOK - -- ^ Initialization was successful. - | EncoderInitStatusEncoderError - -- ^ General failure to set up encoder. - | EncoderInitStatusUnsupportedCointainer - -- ^ The library was not compiled with support for the given container + = -- | Initialization was successful. + EncoderInitStatusOK + | -- | General failure to set up encoder. + EncoderInitStatusEncoderError + | -- | The library was not compiled with support for the given container -- format. - | EncoderInitStatusInvalidCallbacks - -- ^ A required callback was not supplied. - | EncoderInitStatusInvalidNumberOfChannels - -- ^ The encoder has an invalid setting for the number of channels. - | EncoderInitStatusInvalidBitsPerSample - -- ^ The encoder has an invalid setting for the bits-per-sample. FLAC + EncoderInitStatusUnsupportedCointainer + | -- | A required callback was not supplied. + EncoderInitStatusInvalidCallbacks + | -- | The encoder has an invalid setting for the number of channels. + EncoderInitStatusInvalidNumberOfChannels + | -- | The encoder has an invalid setting for the bits-per-sample. FLAC -- supports 4-32 bps but the reference encoder currently supports only -- up to 24 bps. - | EncoderInitStatusInvalidSampleRate - -- ^ The encoder has an invalid setting for the sample rate. - | EncoderInitStatusInvalidBlockSize - -- ^ The encoder has an invalid setting for the block size. - | EncoderInitStatusInvalidMaxLpcOrder - -- ^ The encoder has an invalid setting for the maximum LPC order. - | EncoderInitStatusInvalidQlpCoeffPrecision - -- ^ The encoder has an invalid setting for the precision of the + EncoderInitStatusInvalidBitsPerSample + | -- | The encoder has an invalid setting for the sample rate. + EncoderInitStatusInvalidSampleRate + | -- | The encoder has an invalid setting for the block size. + EncoderInitStatusInvalidBlockSize + | -- | The encoder has an invalid setting for the maximum LPC order. + EncoderInitStatusInvalidMaxLpcOrder + | -- | The encoder has an invalid setting for the precision of the -- quantized linear predictor coefficients. - | EncoderInitStatusBlockSizeTooSmallForLpcOrder - -- ^ The specified block size is less than the maximum LPC order. - | EncoderInitStatusNotStreamable - -- ^ The encoder is bound to the Subset but other settings violate it. - | EncoderInitStatusInvalidMetadata - -- ^ The metadata input to the encoder is invalid (should never happen + EncoderInitStatusInvalidQlpCoeffPrecision + | -- | The specified block size is less than the maximum LPC order. + EncoderInitStatusBlockSizeTooSmallForLpcOrder + | -- | The encoder is bound to the Subset but other settings violate it. + EncoderInitStatusNotStreamable + | -- | The metadata input to the encoder is invalid (should never happen -- with this binding). - | EncoderInitStatusAlreadyInitialized - -- ^ Initialization was attempted on already initialized encoder. + EncoderInitStatusInvalidMetadata + | -- | Initialization was attempted on already initialized encoder. + EncoderInitStatusAlreadyInitialized deriving (Show, Read, Eq, Ord, Bounded, Enum) -- | Enumeration of encoder states. - data EncoderState - = EncoderStateOK - -- ^ The encoder is in the normal OK state and samples can be processed. - | EncoderStateUninitialized - -- ^ The encoder is in the uninitialized state. - | EncoderStateOggError - -- ^ An error occurred in the underlying Ogg layer. - | EncoderStateVerifyDecoderError - -- ^ An error occurred in the underlying verify stream decoder. - | EncoderStateVerifyMismatchInAudioData - -- ^ The verify decoder detected a mismatch between the original audio + = -- | The encoder is in the normal OK state and samples can be processed. + EncoderStateOK + | -- | The encoder is in the uninitialized state. + EncoderStateUninitialized + | -- | An error occurred in the underlying Ogg layer. + EncoderStateOggError + | -- | An error occurred in the underlying verify stream decoder. + EncoderStateVerifyDecoderError + | -- | The verify decoder detected a mismatch between the original audio -- signal and the decoded audio signal. - | EncoderStateClientError - -- ^ One of the callbacks returned a fatal error. - | EncoderStateIOError - -- ^ An I\/O error occurred while opening\/reading\/writing a file. - | EncoderStateFramingError - -- ^ An error occurred while writing the stream. - | EncoderStateMemoryAllocationError - -- ^ Memory allocation failed. + EncoderStateVerifyMismatchInAudioData + | -- | One of the callbacks returned a fatal error. + EncoderStateClientError + | -- | An I\/O error occurred while opening\/reading\/writing a file. + EncoderStateIOError + | -- | An error occurred while writing the stream. + EncoderStateFramingError + | -- | Memory allocation failed. + EncoderStateMemoryAllocationError deriving (Show, Read, Eq, Ord, Bounded, Enum) -- | Exception that is thrown when encoding fails for some reason. - data EncoderException - = EncoderInvalidSampleFormat SampleFormat - -- ^ Input WAVE file had this sample format, which is not supported + = -- | Input WAVE file had this sample format, which is not supported -- (usually happens with floating point samples right now). - | EncoderInitFailed EncoderInitStatus - -- ^ Encoder initialization failed. - | EncoderFailed EncoderState - -- ^ Encoder failed. + EncoderInvalidSampleFormat SampleFormat + | -- | Encoder initialization failed. + EncoderInitFailed EncoderInitStatus + | -- | Encoder failed. + EncoderFailed EncoderState deriving (Eq, Show, Read) instance Exception EncoderException -- | Supported apodization functions. - data ApodizationFunction = Bartlett | BartlettHann @@ -113,31 +108,31 @@ | BlackmanHarris4Term92Db | Connes | Flattop - | Gauss Double - -- ^ The parameter is standard deviation @STDDEV@, @0 < STDDEV <= 0.5@. + | -- | The parameter is standard deviation @STDDEV@, @0 < STDDEV <= 0.5@. + Gauss Double | Hamming | Hann | KaiserBessel | Nuttall | Rectangle | Triangle - | Tukey Double - -- ^ The parameter is the fraction of the window that is tapered @P@, + | -- | The parameter is the fraction of the window that is tapered @P@, -- @0 <= P <= 1@. @P == 0@ corresponds to 'Rectangle' and @P = 1@ -- corresponds to 'Hann'. - | PartialTukey Natural (Maybe (Double, Maybe Double)) - -- ^ The parameters are a series of small windows (all treated + Tukey Double + | -- | The parameters are a series of small windows (all treated -- separately). The three parameters are @n@, @ov@ and @P@. @n@ is the -- number of functions to add, @ov@ is the overlap of the windows. @P@ -- is the fraction of the window that is tapered, like with a regular -- tukey window. The function can be specified with only a number, a -- number and an overlap, or a number, an overlap and a @P@. @ov@ should -- be smaller than 1 and can be negative. - | PunchoutTukey Natural (Maybe (Double, Maybe Double)) - -- ^ The parameters are a series of windows that have a hole in them. In + PartialTukey Natural (Maybe (Double, Maybe Double)) + | -- | The parameters are a series of windows that have a hole in them. In -- this way, the predictor is constructed with only a part of the block, -- which helps in case a block consists of dissimilar parts. All said -- about the parameters in the comment for 'PartialTukey' applies here, -- with the exception that @ov@ is the overlap in the gaps in this case. + PunchoutTukey Natural (Maybe (Double, Maybe Double)) | Welch deriving (Eq, Show, Read, Ord) diff --git a/Codec/Audio/FLAC/Util.hs b/Codec/Audio/FLAC/Util.hs --- a/Codec/Audio/FLAC/Util.hs +++ b/Codec/Audio/FLAC/Util.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE FlexibleContexts #-} + -- | -- Module : Codec.Audio.FLAC.Util --- Copyright : © 2016–2019 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -8,66 +10,58 @@ -- Portability : portable -- -- Random non-public helpers. - -{-# LANGUAGE FlexibleContexts #-} - module Codec.Audio.FLAC.Util - ( maybePtr - , toEnum' - , fromEnum' - , peekCStringText - , withCStringText - , withTempFile' ) + ( maybePtr, + toEnum', + fromEnum', + peekCStringText, + withCStringText, + withTempFile', + ) where import Control.Exception +import Data.ByteString qualified as B import Data.Coerce import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Foreign import Foreign.C.String import System.Directory import System.FilePath import System.IO -import qualified Data.ByteString as B -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -- | Coerce to 'Ptr' and check if it's a null pointer, return 'Nothing' if -- it is, otherwise return the given pointer unchanged. Needless to say that --- this thing is unsafe. - -maybePtr :: Coercible a (Ptr p) => a -> Maybe a +-- this is unsafe. +maybePtr :: (Coercible a (Ptr p)) => a -> Maybe a maybePtr a | coerce a == nullPtr = Nothing - | otherwise = Just a + | otherwise = Just a -- | A version of 'toEnum' that converts from any 'Integral' type. - toEnum' :: (Integral a, Enum b) => a -> b toEnum' = toEnum . fromIntegral -- | A version of 'fromEnum' that is polymorphic in return type. - fromEnum' :: (Integral a, Enum b) => b -> a fromEnum' = fromIntegral . fromEnum -- | Peek 'CString' and decode it as UTF-8 encoded value. - peekCStringText :: CString -> IO Text peekCStringText = fmap T.decodeUtf8 . B.packCString --- | Convert a 'Text' value to null-terminated C string that will be freed +-- | Convert a 'Text' value to a null-terminated C string that will be freed -- automatically. Null bytes are removed from the 'Text' value first. - withCStringText :: Text -> (CString -> IO a) -> IO a withCStringText text = B.useAsCString bytes where bytes = T.encodeUtf8 (T.filter (/= '\0') text) -- | A custom wrapper for creating temporary files in the same directory as --- given file. 'Handle' is not opened, you only get 'FilePath' in the +-- the given file. 'Handle' is not opened, you only get 'FilePath' in the -- callback. - withTempFile' :: FilePath -> (FilePath -> IO a) -> IO a withTempFile' path m = bracketOnError acquire cleanup $ \(path', h) -> hClose h >> m path' @@ -76,11 +70,10 @@ -- NOTE We need ignoringIOErrors in the case exception strikes before we -- create the actual file. cleanup = ignoringIOErrors . removeFile . fst - dir = takeDirectory path - file = takeFileName path - --- | Perform specified action ignoring IO exceptions it may throw. + dir = takeDirectory path + file = takeFileName path +-- | Perform the specified action ignoring IO exceptions it may throw. ignoringIOErrors :: IO () -> IO () ignoringIOErrors ioe = ioe `catch` handler where diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -1,4 +1,4 @@ -Copyright © 2016–2018 Mark Karpov +Copyright © 2016–present Mark Karpov All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ [![Hackage](https://img.shields.io/hackage/v/flac.svg?style=flat)](https://hackage.haskell.org/package/flac) [![Stackage Nightly](http://stackage.org/package/flac/badge/nightly)](http://stackage.org/nightly/package/flac) [![Stackage LTS](http://stackage.org/package/flac/badge/lts)](http://stackage.org/lts/package/flac) -[![Build Status](https://travis-ci.org/mrkkrp/flac.svg?branch=master)](https://travis-ci.org/mrkkrp/flac) +![CI](https://github.com/mrkkrp/flac/workflows/CI/badge.svg?branch=master) * [Aims of the project](#aims-of-the-project) * [Motivation](#motivation) @@ -15,8 +15,8 @@ * [Contribution](#contribution) * [License](#license) -This is a complete high-level Haskell binding -to [libFLAC](https://xiph.org/flac/)—reference FLAC implementation. +This is a complete high-level Haskell binding to +[libFLAC](https://xiph.org/flac/)—reference FLAC implementation. > As the maintainer of the C FLAC code base, I must say I'm impressed. Quite > honestly, I think the C API is horrible. @@ -25,79 +25,60 @@ ## Aims of the project -Here are several ideas the project follows: - -* Concentrate only on native FLAC format without messing with other audio - formats or their flavors. This library is about FLAC only. - -* Be a complete interface for FLAC file manipulation in Haskell. “Complete” - means that everything supported by the reference implementation should be - supported by this package. This is in the hope to prevent fragmentation - and proliferation of different libraries to work with FLAC with each of - them covering only some 80% of functionality the library author needed and - neglecting other 20%. - -* Be as efficient as the underlying C implementation, avoid adding any sort - of overhead (memory/speed/or otherwise). - -* Provide *idiot-proof* API using type system to kindly guard against bad - things, but not so much to remain beginner-friendly and simple. +These are the goals of the project: -* Make invalid code and data unrepresentable. +* Be a complete interface for FLAC file manipulation in Haskell. +* Be as efficient as the underlying C implementation. +* Provide a safe API using type system to kindly guard against bad things, + but not too much so as to remain beginner-friendly and simple. ## Motivation -FLAC is awesome and Haskell is awesome, surely there should be a way to -achieve an even higher level of awesomeness by coding a safe Haskell API to -the fast libFLAC library. +FLAC is awesome and Haskell is awesome, surely there should be a safe +Haskell API to the fast libFLAC library! -Seriously though, we -have [`htaglib`](https://hackage.haskell.org/package/htaglib) to work with -audio metadata, but it does not support a lot of FLAC-specific things I'd -love to manipulate. We -have [`hsndfile`](https://hackage.haskell.org/package/hsndfile), but I don't +Seriously though, we have +[`htaglib`](https://hackage.haskell.org/package/htaglib) to work with audio +metadata, but it does not support FLAC-specific thing I would like to +manipulate. We have +[`hsndfile`](https://hackage.haskell.org/package/hsndfile), but I don't really want to read FLAC data into a buffer or Haskell `Vector`. How simple is it (if possible) to decode a FLAC file using that library? How simple is -it to figure out where to begin with such a task? With `flac` it's -`decodeFlac def "myfile.flac" "myfile.wav"`—done, average song in a fraction -of second. +it to figure out where to begin with such a task? With `flac` it is one line +of code. ## Provided functionality -Here we go: +`flac` can work with: * Metadata—full support for reading/writing/deleting of all audio parameters, application data, seek tables, vorbis comments of all sorts, CUE sheets, and even pictures. -* Stream decoder—simple interface for decoding to vanilla WAVE and RF64 - (support for files larger than 4 Gb). +* Stream decoder—simple interface for decoding to WAVE and RF64. -* Stream encoder—a lot of options to tweak, everything that libFLAC has, but - you can also use `def` and just encode vanilla WAVE or RF64 file into - native FLAC. Simple and efficient. +* Stream encoder—a lot of options to tweak, everything that libFLAC + supports. ## Limitations Right now there are three main limitations: -* No Ogg FLAC support, and I do not plan to add it, but I'll accept a PR - adding support for Ogg FLAC. +* No Ogg FLAC support, and I do not plan to add it; I'll accept a PR adding + support for Ogg FLAC. * It's not possible to use custom callbacks for printing decoding/encoding - progress in real-time and stuff like that. Not a big issue IMO, given that - we get nice and safe API instead. + progress in real-time. -* Only works on little-endian architectures so far, I'll accept a PR lifting +* Only works on little-endian architectures so far; I'll accept a PR lifting this limitation. ## Quick start -The best way to start using `flac` is to take a look -at [the Haddocks](https://hackage.haskell.org/package/flac). Encoding and -decoding are so simple that even a baby could handle it, and for metadata -there are examples and a lot of details in the docs. Feel free to ask me a -question if you get stuck with something though. +The best way to start using `flac` is to take a look at [the +Haddocks](https://hackage.haskell.org/package/flac). Encoding and decoding +should be simple to understand, for metadata there are examples in the docs. +Feel free to ask me a question if you get stuck with something. ## Related packages @@ -108,13 +89,13 @@ ## Contribution -Please kindly direct all issues, bugs, and questions to -[the GitHub issue tracker for this project](https://github.com/mrkkrp/flac/issues). +Please direct all issues, bugs, and questions to [the GitHub issue tracker +for this project](https://github.com/mrkkrp/flac/issues). -Pull requests are also welcome and will be reviewed quickly. +Pull requests are also welcome. ## License -Copyright © 2016–2019 Mark Karpov +Copyright © 2016–present Mark Karpov Distributed under BSD 3 clause license. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main (main) where - -import Distribution.Simple - -main :: IO () -main = defaultMain diff --git a/flac.cabal b/flac.cabal --- a/flac.cabal +++ b/flac.cabal @@ -1,101 +1,110 @@ -name: flac -version: 0.2.0 -cabal-version: 1.18 -tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.3 -license: BSD3 -license-file: LICENSE.md -author: Mark Karpov -maintainer: Mark Karpov -homepage: https://github.com/mrkkrp/flac -bug-reports: https://github.com/mrkkrp/flac/issues -category: Codec, Audio -synopsis: Complete high-level binding to libFLAC -build-type: Simple -description: Complete high-level binding to libFLAC. -extra-doc-files: CHANGELOG.md - , README.md -extra-source-files: cbits/*.h -data-files: audio-samples/sample.flac - , audio-samples/*.rf64 - , audio-samples/*.wav +cabal-version: 2.4 +name: flac +version: 0.2.1 +license: BSD-3-Clause +license-file: LICENSE.md +maintainer: Mark Karpov +author: Mark Karpov +tested-with: ghc ==9.4.7 ghc ==9.6.3 ghc ==9.8.1 +homepage: https://github.com/mrkkrp/flac +bug-reports: https://github.com/mrkkrp/flac/issues +synopsis: Complete high-level binding to libFLAC +description: Complete high-level binding to libFLAC. +category: Codec, Audio +build-type: Simple +data-files: + audio-samples/sample.flac + audio-samples/*.rf64 + audio-samples/*.wav +extra-source-files: cbits/*.h +extra-doc-files: + CHANGELOG.md + README.md + source-repository head - type: git - location: https://github.com/mrkkrp/flac.git + type: git + location: https://github.com/mrkkrp/flac.git flag dev - description: Turn on development settings. - manual: True - default: False + description: Turn on development settings. + default: False + manual: True library - build-depends: base >= 4.8 && < 5.0 - , bytestring >= 0.2 && < 0.11 - , containers >= 0.5 && < 0.7 - , directory >= 1.2.2 && < 1.4 - , exceptions >= 0.6 && < 0.11 - , filepath >= 1.2 && < 1.5 - , mtl >= 2.0 && < 3.0 - , text >= 0.2 && < 1.3 - , transformers >= 0.4 && < 0.6 - , vector >= 0.10 && < 0.13 - , wave >= 0.1.2 && < 0.2 - if !impl(ghc >= 8.0) - build-depends: semigroups == 0.18.* - extra-libraries: FLAC - exposed-modules: Codec.Audio.FLAC.Metadata - , Codec.Audio.FLAC.Metadata.CueSheet - , Codec.Audio.FLAC.StreamDecoder - , Codec.Audio.FLAC.StreamEncoder - , Codec.Audio.FLAC.StreamEncoder.Apodization - other-modules: Codec.Audio.FLAC.Metadata.Internal.Level2Interface - , Codec.Audio.FLAC.Metadata.Internal.Level2Interface.Helpers - , Codec.Audio.FLAC.Metadata.Internal.Object - , Codec.Audio.FLAC.Metadata.Internal.Types - , Codec.Audio.FLAC.StreamDecoder.Internal - , Codec.Audio.FLAC.StreamDecoder.Internal.Helpers - , Codec.Audio.FLAC.StreamDecoder.Internal.Types - , Codec.Audio.FLAC.StreamEncoder.Internal - , Codec.Audio.FLAC.StreamEncoder.Internal.Helpers - , Codec.Audio.FLAC.StreamEncoder.Internal.Types - , Codec.Audio.FLAC.Util - c-sources: cbits/metadata_level2_helpers.c - , cbits/stream_decoder_helpers.c - , cbits/stream_encoder_helpers.c - include-dirs: cbits - if flag(dev) - ghc-options: -Wall -Werror -fsimpl-tick-factor=150 - else - ghc-options: -O2 -Wall -fsimpl-tick-factor=150 - if flag(dev) && impl(ghc >= 8.0) - ghc-options: -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wnoncanonical-monad-instances - -Wnoncanonical-monadfail-instances - default-language: Haskell2010 + exposed-modules: + Codec.Audio.FLAC.Metadata + Codec.Audio.FLAC.Metadata.CueSheet + Codec.Audio.FLAC.StreamDecoder + Codec.Audio.FLAC.StreamEncoder + Codec.Audio.FLAC.StreamEncoder.Apodization + c-sources: + cbits/metadata_level2_helpers.c + cbits/stream_decoder_helpers.c + cbits/stream_encoder_helpers.c + + other-modules: + Codec.Audio.FLAC.Metadata.Internal.Level2Interface + Codec.Audio.FLAC.Metadata.Internal.Level2Interface.Helpers + Codec.Audio.FLAC.Metadata.Internal.Object + Codec.Audio.FLAC.Metadata.Internal.Types + Codec.Audio.FLAC.StreamDecoder.Internal + Codec.Audio.FLAC.StreamDecoder.Internal.Helpers + Codec.Audio.FLAC.StreamDecoder.Internal.Types + Codec.Audio.FLAC.StreamEncoder.Internal + Codec.Audio.FLAC.StreamEncoder.Internal.Helpers + Codec.Audio.FLAC.StreamEncoder.Internal.Types + Codec.Audio.FLAC.Util + + default-language: GHC2021 + extra-libraries: FLAC + include-dirs: cbits + build-depends: + base >=4.15 && <5, + bytestring >=0.2 && <0.12, + containers >=0.5 && <0.7, + directory >=1.2.2 && <1.4, + exceptions >=0.6 && <0.11, + filepath >=1.2 && <1.5, + mtl >=2 && <3, + text >=0.2 && <2.2, + vector >=0.10 && <0.14, + wave >=0.1.2 && <0.3 + + if flag(dev) + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages + + if impl(ghc >=9.8) + ghc-options: -Wno-x-partial + test-suite tests - main-is: Spec.hs - other-modules: Codec.Audio.FLAC.MetadataSpec - , Codec.Audio.FLAC.StreamEncoderSpec - hs-source-dirs: tests - type: exitcode-stdio-1.0 - build-depends: base >= 4.8 && < 5.0 - , bytestring >= 0.2 && < 0.11 - , directory >= 1.2.2 && < 1.4 - , filepath >= 1.2 && < 1.5 - , flac - , hspec >= 2.0 && < 3.0 - , temporary >= 1.1 && < 1.4 - , transformers >= 0.4 && < 0.6 - , vector >= 0.10 && < 0.13 - , wave >= 0.1.2 && < 0.2 - build-tools: hspec-discover >= 2.0 && < 3.0 - if !impl(ghc >= 8.0) - build-depends: semigroups == 0.18.* - if flag(dev) - ghc-options: -Wall -Werror - else - ghc-options: -O2 -Wall - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: hspec-discover:hspec-discover >=2 && <3 + hs-source-dirs: tests + other-modules: + Codec.Audio.FLAC.MetadataSpec + Codec.Audio.FLAC.StreamEncoderSpec + + default-language: GHC2021 + build-depends: + base >=4.15 && <5, + bytestring >=0.2 && <0.12, + directory >=1.2.2 && <1.4, + filepath >=1.2 && <1.5, + flac, + hspec >=2 && <3, + temporary >=1.1 && <1.4, + vector >=0.10 && <0.14, + wave >=0.1.2 && <0.3 + + if flag(dev) + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages + + else + ghc-options: -Wall diff --git a/tests/Codec/Audio/FLAC/MetadataSpec.hs b/tests/Codec/Audio/FLAC/MetadataSpec.hs --- a/tests/Codec/Audio/FLAC/MetadataSpec.hs +++ b/tests/Codec/Audio/FLAC/MetadataSpec.hs @@ -1,26 +1,24 @@ {-# LANGUAGE OverloadedStrings #-} -module Codec.Audio.FLAC.MetadataSpec - ( spec ) -where +module Codec.Audio.FLAC.MetadataSpec (spec) where import Codec.Audio.FLAC.Metadata hiding (runFlacMeta) +import Codec.Audio.FLAC.Metadata qualified as Flac import Codec.Audio.FLAC.Metadata.CueSheet import Codec.Audio.Wave import Control.Monad import Control.Monad.IO.Class (MonadIO (..)) import Data.ByteString (ByteString) +import Data.ByteString qualified as B import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE import Data.Vector (Vector) +import Data.Vector qualified as V import System.Directory import System.IO import System.IO.Temp (withSystemTempFile) import Test.Hspec hiding (shouldBe, shouldReturn) -import qualified Codec.Audio.FLAC.Metadata as Flac -import qualified Data.ByteString as B -import qualified Data.List.NonEmpty as NE -import qualified Data.Vector as V -import qualified Test.Hspec as Hspec +import Test.Hspec qualified as Hspec -- TODO How to share the same sandbox between several subsequent tests? This -- would allow for more precise labelling. @@ -96,29 +94,32 @@ it "is set/read/deleted correctly" $ \path -> do -- Can set application data. runFlacMeta def path $ do - Application "foo" =-> Just "foo" + Application "foo" =-> Just "foo" Application "bobo" =-> Just "bobo" - getMetaChain `shouldReturn` StreamInfoBlock :| - [ApplicationBlock,ApplicationBlock,VorbisCommentBlock,PaddingBlock] + getMetaChain + `shouldReturn` StreamInfoBlock + :| [ApplicationBlock, ApplicationBlock, VorbisCommentBlock, PaddingBlock] isMetaChainModified `shouldReturn` True -- Can read it back. runFlacMeta def path . checkNoMod $ do - retrieve (Application "foo") `shouldReturn` Just "foo" + retrieve (Application "foo") `shouldReturn` Just "foo" retrieve (Application "bobo") `shouldReturn` Just "bobo" -- Can wipe one without affecting the other. runFlacMeta def path $ do Application "foo" =-> Nothing - retrieve (Application "foo") `shouldReturn` Nothing + retrieve (Application "foo") `shouldReturn` Nothing retrieve (Application "bobo") `shouldReturn` Just "bobo" - getMetaChain `shouldReturn` StreamInfoBlock :| - [ApplicationBlock,VorbisCommentBlock,PaddingBlock] + getMetaChain + `shouldReturn` StreamInfoBlock + :| [ApplicationBlock, VorbisCommentBlock, PaddingBlock] isMetaChainModified `shouldReturn` True -- Can overwrite application data. runFlacMeta def path $ do Application "bobo" =-> Just "moon" retrieve (Application "bobo") `shouldReturn` Just "moon" - getMetaChain `shouldReturn` StreamInfoBlock :| - [ApplicationBlock,VorbisCommentBlock,PaddingBlock] + getMetaChain + `shouldReturn` StreamInfoBlock + :| [ApplicationBlock, VorbisCommentBlock, PaddingBlock] isMetaChainModified `shouldReturn` True -- Can wipe the other one bringing it to the default state. runFlacMeta def path $ do @@ -126,20 +127,22 @@ getMetaChain `shouldReturn` refChain isMetaChainModified `shouldReturn` True runFlacMeta def path . checkNoMod $ do - retrieve (Application "foo") `shouldReturn` Nothing + retrieve (Application "foo") `shouldReturn` Nothing retrieve (Application "bobo") `shouldReturn` Nothing describe "SeekTable" $ do it "raises exception when invalid seek table given" $ \path -> do - let m = runFlacMeta def path $ - SeekTable =-> Just invalidSeekTable + let m = + runFlacMeta def path $ + SeekTable =-> Just invalidSeekTable m `shouldThrow` (== MetaInvalidSeekTable) it "is set/read/deleted correctly" $ \path -> do -- Can set seek table if it's correct. runFlacMeta def path $ do SeekTable =-> Just testSeekTable - getMetaChain `shouldReturn` StreamInfoBlock :| - [SeekTableBlock,VorbisCommentBlock,PaddingBlock] + getMetaChain + `shouldReturn` StreamInfoBlock + :| [SeekTableBlock, VorbisCommentBlock, PaddingBlock] isMetaChainModified `shouldReturn` True -- Can read it back. runFlacMeta def path . checkNoMod $ @@ -153,21 +156,23 @@ SeekTable =-> Nothing context "when auto-vacuum disabled" $ it "can write empty seek table" $ \path -> do - runFlacMeta def { metaAutoVacuum = False } path $ do + runFlacMeta def {metaAutoVacuum = False} path $ do SeekTable =-> Just V.empty retrieve SeekTable `shouldReturn` Just V.empty - getMetaChain `shouldReturn` StreamInfoBlock :| - [SeekTableBlock,VorbisCommentBlock,PaddingBlock] + getMetaChain + `shouldReturn` StreamInfoBlock + :| [SeekTableBlock, VorbisCommentBlock, PaddingBlock] isMetaChainModified `shouldReturn` True runFlacMeta def path . checkNoMod $ retrieve SeekTable `shouldReturn` Just V.empty context "when auto-vacuum enabled" $ it "empty seek table is removed automatically" $ \path -> do - runFlacMeta def { metaAutoVacuum = True } path $ do + runFlacMeta def {metaAutoVacuum = True} path $ do SeekTable =-> Just V.empty retrieve SeekTable `shouldReturn` Just V.empty - getMetaChain `shouldReturn` StreamInfoBlock :| - [SeekTableBlock,VorbisCommentBlock,PaddingBlock] + getMetaChain + `shouldReturn` StreamInfoBlock + :| [SeekTableBlock, VorbisCommentBlock, PaddingBlock] isMetaChainModified `shouldReturn` True runFlacMeta def path . checkNoMod $ do retrieve SeekTable `shouldReturn` Nothing @@ -178,55 +183,61 @@ -- Can set vorbis vendor. runFlacMeta def path $ do VorbisVendor =-> Just "foo" - getMetaChain `shouldReturn` StreamInfoBlock :| - [VorbisCommentBlock,PaddingBlock] + getMetaChain + `shouldReturn` StreamInfoBlock + :| [VorbisCommentBlock, PaddingBlock] isMetaChainModified `shouldReturn` True -- Can read it back. runFlacMeta def path . checkNoMod $ retrieve VorbisVendor `shouldReturn` Just "foo" context "when auto-vacuum disabled" $ it "deletion just sets the field to empty string" $ \path -> do - runFlacMeta def { metaAutoVacuum = False } path $ do + runFlacMeta def {metaAutoVacuum = False} path $ do VorbisVendor =-> Nothing retrieve VorbisVendor `shouldReturn` Just "" - getMetaChain `shouldReturn` StreamInfoBlock :| - [VorbisCommentBlock,PaddingBlock] + getMetaChain + `shouldReturn` StreamInfoBlock + :| [VorbisCommentBlock, PaddingBlock] isMetaChainModified `shouldReturn` True runFlacMeta def path . checkNoMod $ retrieve VorbisVendor `shouldReturn` Just "" context "when auto-vacuum enabled" $ do context "when no other vorbis fields set" $ it "empty vendor causes removal of vorbis vendor block" $ \path -> do - runFlacMeta def { metaAutoVacuum = True } path $ do + runFlacMeta def {metaAutoVacuum = True} path $ do VorbisVendor =-> Nothing retrieve VorbisVendor `shouldReturn` Just "" - getMetaChain `shouldReturn` StreamInfoBlock :| - [VorbisCommentBlock,PaddingBlock] + getMetaChain + `shouldReturn` StreamInfoBlock + :| [VorbisCommentBlock, PaddingBlock] isMetaChainModified `shouldReturn` True runFlacMeta def path . checkNoMod $ do retrieve VorbisVendor `shouldReturn` Nothing getMetaChain `shouldReturn` StreamInfoBlock :| [PaddingBlock] context "when other vorbis fields exist" $ it "deletion just sets the field to empty string" $ \path -> do - runFlacMeta def { metaAutoVacuum = True } path $ do + runFlacMeta def {metaAutoVacuum = True} path $ do VorbisComment Title =-> Just "bobla" VorbisVendor =-> Nothing retrieve VorbisVendor `shouldReturn` Just "" - getMetaChain `shouldReturn` StreamInfoBlock :| - [VorbisCommentBlock,PaddingBlock] + getMetaChain + `shouldReturn` StreamInfoBlock + :| [VorbisCommentBlock, PaddingBlock] isMetaChainModified `shouldReturn` True runFlacMeta def path . checkNoMod $ do retrieve VorbisVendor `shouldReturn` Just "" - getMetaChain `shouldReturn` StreamInfoBlock :| - [VorbisCommentBlock,PaddingBlock] + getMetaChain + `shouldReturn` StreamInfoBlock + :| [VorbisCommentBlock, PaddingBlock] - describe "VorbisComment" . forM_ [minBound..maxBound] $ \vfield -> + describe "VorbisComment" . forM_ [minBound .. maxBound] $ \vfield -> it (show vfield ++ " is set/read/deleted correctly") $ \path -> do -- Can set vorbis comment. runFlacMeta def path $ do VorbisComment vfield =-> Just "foo" - getMetaChain `shouldReturn` StreamInfoBlock :| - [VorbisCommentBlock,PaddingBlock] + getMetaChain + `shouldReturn` StreamInfoBlock + :| [VorbisCommentBlock, PaddingBlock] isMetaChainModified `shouldReturn` True -- Can read it back. runFlacMeta def path . checkNoMod $ @@ -243,8 +254,9 @@ describe "CueSheet" $ do context "when the CUE sheet is for a CD" $ it "raises exception when invalid CDDA CUE sheet is given" $ \path -> do - let m = runFlacMeta def path $ - CueSheet =-> Just invalidCueSheet { cueIsCd = True } + let m = + runFlacMeta def path $ + CueSheet =-> Just invalidCueSheet {cueIsCd = True} leadInError = "CD-DA cue sheet must have a lead-in length of at least 2 seconds" m `shouldThrow` (== MetaInvalidCueSheet leadInError) context "when the CUE sheet is not for a CD" $ @@ -252,13 +264,14 @@ -- NOTE All other possible issues have been taken care of by the -- type system and carefully arranged data type definitions. runFlacMeta def path $ - CueSheet =-> Just invalidCueSheet { cueIsCd = False } + CueSheet =-> Just invalidCueSheet {cueIsCd = False} it "is set/read/deleted correctly" $ \path -> do -- Can set CUE sheet if it's correct. runFlacMeta def path $ do CueSheet =-> Just testCueSheet - getMetaChain `shouldReturn` StreamInfoBlock :| - [CueSheetBlock,VorbisCommentBlock,PaddingBlock] + getMetaChain + `shouldReturn` StreamInfoBlock + :| [CueSheetBlock, VorbisCommentBlock, PaddingBlock] isMetaChainModified `shouldReturn` True -- Can read it back. runFlacMeta def path . checkNoMod $ @@ -271,18 +284,20 @@ runFlacMeta def path . checkNoMod $ CueSheet =-> Nothing - describe "Picture" . forM_ [minBound..maxBound] $ \ptype -> do + describe "Picture" . forM_ [minBound .. maxBound] $ \ptype -> do it (show ptype ++ " raises exception on invalid picture") $ \path -> do - let m = runFlacMeta def path $ - Picture ptype =-> Just invalidPicture + let m = + runFlacMeta def path $ + Picture ptype =-> Just invalidPicture mimeTypeError = "MIME type string must contain only printable ASCII characters (0x20-0x7e)" m `shouldThrow` (== MetaInvalidPicture mimeTypeError) it (show ptype ++ " is set/read/deleted correctly") $ \path -> do -- Can set a picture. runFlacMeta def path $ do Picture ptype =-> Just testPicture - getMetaChain `shouldReturn` StreamInfoBlock :| - [PictureBlock,VorbisCommentBlock,PaddingBlock] + getMetaChain + `shouldReturn` StreamInfoBlock + :| [PictureBlock, VorbisCommentBlock, PaddingBlock] isMetaChainModified `shouldReturn` True -- Can read it back. runFlacMeta def path . checkNoMod $ @@ -298,7 +313,7 @@ describe "wipeVorbisComment" $ it "wipes all “vorbis comment” metadata blocks" $ \path -> do runFlacMeta def path $ do - VorbisComment Title =-> Just "Title" + VorbisComment Title =-> Just "Title" VorbisComment Artist =-> Just "Artist" runFlacMeta def path $ do wipeVorbisComment @@ -310,7 +325,7 @@ describe "wipeApplications" $ it "wipes all “application” metadata blocks" $ \path -> do runFlacMeta def path $ do - Application "foo" =-> Just "foo" + Application "foo" =-> Just "foo" Application "bobo" =-> Just "bobo" runFlacMeta def path $ do wipeApplications @@ -345,7 +360,7 @@ it "wipes all “picture” metadata blocks" $ \path -> do runFlacMeta def path $ do Picture PictureFrontCover =-> Just testPicture - Picture PictureBackCover =-> Just testPicture + Picture PictureBackCover =-> Just testPicture runFlacMeta def path $ do wipePictures getMetaChain `shouldReturn` refChain @@ -357,32 +372,27 @@ -- Helpers -- | A shortcut for 'defaultMetaSettings'. - def :: MetaSettings def = defaultMetaSettings infix 1 `shouldBe`, `shouldReturn` -- | Lifted 'Hspec.shouldBe'. - shouldBe :: (MonadIO m, Show a, Eq a) => a -> a -> m () shouldBe x y = liftIO (x `Hspec.shouldBe` y) -- | Lifted 'Hspec.shouldReturn'. - shouldReturn :: (MonadIO m, Show a, Eq a) => m a -> a -> m () shouldReturn m y = m >>= (`shouldBe` y) -- | Type constrained version of 'Flac.runFlacMeta' to remove type -- ambiguity. - runFlacMeta :: MetaSettings -> FilePath -> FlacMeta a -> IO a runFlacMeta = Flac.runFlacMeta -- | Make a temporary copy of @audio-samples/sample.flac@ file and provide -- the path to the file. Automatically remove the file when the test -- finishes. - withSandbox :: ActionWith FilePath -> IO () withSandbox action = withSystemTempFile "sample.flac" $ \path h -> do hClose h @@ -390,131 +400,137 @@ action path -- | Check that the inner action does not modify the chain. - checkNoMod :: FlacMeta a -> FlacMeta a checkNoMod m = do chainBefore <- getMetaChain result <- m - chainAfter <- getMetaChain + chainAfter <- getMetaChain chainAfter `shouldBe` chainBefore isMetaChainModified `shouldReturn` False return result -- | MD5 sum of uncompressed audio data of the unmodified sample we use in -- these tests. - refMD5Sum :: ByteString -refMD5Sum = B.pack [89,191,106,236,125,27,65,161,78,138,172,153,91,60,42,109] +refMD5Sum = B.pack [89, 191, 106, 236, 125, 27, 65, 161, 78, 138, 172, 153, 91, 60, 42, 109] -- | The sequence of metadata blocks as they appear in the unmodified sample -- we use in these tests. - refChain :: NonEmpty MetadataType refChain = StreamInfoBlock :| [VorbisCommentBlock, PaddingBlock] -- | A correct seek table. - testSeekTable :: Vector SeekPoint -testSeekTable = V.fromList - [ SeekPoint 1 10 100 - , SeekPoint 2 20 108 - , SeekPoint 3 30 101 ] +testSeekTable = + V.fromList + [ SeekPoint 1 10 100, + SeekPoint 2 20 108, + SeekPoint 3 30 101 + ] -- | An invalid seek table. - invalidSeekTable :: Vector SeekPoint -invalidSeekTable = V.fromList - [ SeekPoint 0 0 100 - , SeekPoint 0 0 108 - , SeekPoint 0 0 101 ] +invalidSeekTable = + V.fromList + [ SeekPoint 0 0 100, + SeekPoint 0 0 108, + SeekPoint 0 0 101 + ] -- | A correct CUE sheet. - testCueSheet :: CueSheetData -testCueSheet = CueSheetData - { cueCatalog = "1112223334445" - , cueLeadIn = 88200 -- at least two seconds - , cueIsCd = True - , cueTracks = - [ CueTrack - { cueTrackOffset = 588 * 2 - , cueTrackIsrc = "abcde1234567" - , cueTrackAudio = True - , cueTrackPreEmphasis = True - , cueTrackPregapIndex = Nothing - , cueTrackIndices = NE.fromList [0,588,588 * 2] } - , CueTrack - { cueTrackOffset = 588 * 3 - , cueTrackIsrc = "abced1234576" - , cueTrackAudio = False - , cueTrackPreEmphasis = False - , cueTrackPregapIndex = Just 588 - , cueTrackIndices = NE.fromList [0,588,588 * 7] } - ] - , cueLeadOutTrack = - CueTrack - { cueTrackOffset = 588 * 10 - , cueTrackIsrc = "" - , cueTrackAudio = True - , cueTrackPreEmphasis = False - , cueTrackPregapIndex = Just (588 * 9) - , cueTrackIndices = NE.fromList [0] } - } +testCueSheet = + CueSheetData + { cueCatalog = "1112223334445", + cueLeadIn = 88200, -- at least two seconds + cueIsCd = True, + cueTracks = + [ CueTrack + { cueTrackOffset = 588 * 2, + cueTrackIsrc = "abcde1234567", + cueTrackAudio = True, + cueTrackPreEmphasis = True, + cueTrackPregapIndex = Nothing, + cueTrackIndices = NE.fromList [0, 588, 588 * 2] + }, + CueTrack + { cueTrackOffset = 588 * 3, + cueTrackIsrc = "abced1234576", + cueTrackAudio = False, + cueTrackPreEmphasis = False, + cueTrackPregapIndex = Just 588, + cueTrackIndices = NE.fromList [0, 588, 588 * 7] + } + ], + cueLeadOutTrack = + CueTrack + { cueTrackOffset = 588 * 10, + cueTrackIsrc = "", + cueTrackAudio = True, + cueTrackPreEmphasis = False, + cueTrackPregapIndex = Just (588 * 9), + cueTrackIndices = NE.fromList [0] + } + } -- | An invalid CUE sheet. - invalidCueSheet :: CueSheetData -invalidCueSheet = CueSheetData - { cueCatalog = "1112223334445" - , cueLeadIn = 1401 -- less than two seconds — illegal - , cueIsCd = True - , cueTracks = - [ CueTrack - { cueTrackOffset = 1212 - , cueTrackIsrc = "abcde1234567" - , cueTrackAudio = True - , cueTrackPreEmphasis = True - , cueTrackPregapIndex = Nothing - , cueTrackIndices = NE.fromList [0,13,1096] } - , CueTrack - { cueTrackOffset = 1313 - , cueTrackIsrc = "abced1234576" - , cueTrackAudio = False - , cueTrackPreEmphasis = False - , cueTrackPregapIndex = Just 588 - , cueTrackIndices = NE.fromList [0,19,1069] } - ] - , cueLeadOutTrack = - CueTrack - { cueTrackOffset = 8888 - , cueTrackIsrc = "" - , cueTrackAudio = True - , cueTrackPreEmphasis = False - , cueTrackPregapIndex = Just 588 - , cueTrackIndices = NE.fromList [0] - } - } +invalidCueSheet = + CueSheetData + { cueCatalog = "1112223334445", + cueLeadIn = 1401, -- less than two seconds — illegal + cueIsCd = True, + cueTracks = + [ CueTrack + { cueTrackOffset = 1212, + cueTrackIsrc = "abcde1234567", + cueTrackAudio = True, + cueTrackPreEmphasis = True, + cueTrackPregapIndex = Nothing, + cueTrackIndices = NE.fromList [0, 13, 1096] + }, + CueTrack + { cueTrackOffset = 1313, + cueTrackIsrc = "abced1234576", + cueTrackAudio = False, + cueTrackPreEmphasis = False, + cueTrackPregapIndex = Just 588, + cueTrackIndices = NE.fromList [0, 19, 1069] + } + ], + cueLeadOutTrack = + CueTrack + { cueTrackOffset = 8888, + cueTrackIsrc = "", + cueTrackAudio = True, + cueTrackPreEmphasis = False, + cueTrackPregapIndex = Just 588, + cueTrackIndices = NE.fromList [0] + } + } -- | A correct picture. - testPicture :: PictureData -testPicture = PictureData - { pictureMimeType = "application/jpeg" - , pictureDescription = "Good description." - , pictureWidth = 100 - , pictureHeight = 100 - , pictureDepth = 24 - , pictureColors = 0 - , pictureData = "Some picture data goes here, honest." } +testPicture = + PictureData + { pictureMimeType = "application/jpeg", + pictureDescription = "Good description.", + pictureWidth = 100, + pictureHeight = 100, + pictureDepth = 24, + pictureColors = 0, + pictureData = "Some picture data goes here, honest." + } -- | An invalid picture. - invalidPicture :: PictureData -invalidPicture = PictureData - { pictureMimeType = "application\1/jpeg" - , pictureDescription = "Bad\1 description." - , pictureWidth = 100 - , pictureHeight = 100 - , pictureDepth = 24 - , pictureColors = 0 - , pictureData = "Some picture data goes here, honest." } +invalidPicture = + PictureData + { pictureMimeType = "application\1/jpeg", + pictureDescription = "Bad\1 description.", + pictureWidth = 100, + pictureHeight = 100, + pictureDepth = 24, + pictureColors = 0, + pictureData = "Some picture data goes here, honest." + } diff --git a/tests/Codec/Audio/FLAC/StreamEncoderSpec.hs b/tests/Codec/Audio/FLAC/StreamEncoderSpec.hs --- a/tests/Codec/Audio/FLAC/StreamEncoderSpec.hs +++ b/tests/Codec/Audio/FLAC/StreamEncoderSpec.hs @@ -1,26 +1,19 @@ {-# LANGUAGE RecordWildCards #-} -module Codec.Audio.FLAC.StreamEncoderSpec - ( spec ) -where +module Codec.Audio.FLAC.StreamEncoderSpec (spec) where import Codec.Audio.FLAC.StreamDecoder import Codec.Audio.FLAC.StreamEncoder import Codec.Audio.Wave import Control.Monad import Data.ByteString (ByteString) +import Data.ByteString qualified as B import System.Directory import System.FilePath import System.IO import System.IO.Temp (withSystemTempDirectory) import Test.Hspec -import qualified Data.ByteString as B --- NOTE OK, we test here a lot of things at the same time, which may --- disappoint adepts of various testing techniques and principles, but it's --- easier to test many things simultaneously in this case, and when --- something is not right, it's usually obvious what's wrong. - spec :: Spec spec = describe "encodeFlac and decodeFlac" $ @@ -31,11 +24,20 @@ old <- Blind <$> fetchWaveBody path -- We first let the built-in verification mechanics catch possible -- errors. - encodeFlac defaultEncoderSettings - { encoderVerify = True } path path - -- Then we let decoder check that the streams match with MD5 hash. - decodeFlac defaultDecoderSettings - { decoderMd5Checking = True } path path + encodeFlac + defaultEncoderSettings + { encoderVerify = True + } + path + path + -- Then we let decoder check that the streams match with the MD5 + -- hash. + decodeFlac + defaultDecoderSettings + { decoderMd5Checking = True + } + path + path -- But we also want to be sure that audio streams match -- byte-by-byte, we can't trust just FLAC's own checking. new <- Blind <$> fetchWaveBody path @@ -46,14 +48,13 @@ newtype Blind a = Blind a -instance Eq a => Eq (Blind a) where +instance (Eq a) => Eq (Blind a) where (Blind x) == (Blind y) = x == y instance Show (Blind a) where show _ = "" -- | Run given test with various WAVE files. - withVariousWaves :: SpecWith FilePath -> SpecWith () withVariousWaves m = forM_ waveFiles $ \(path, desc) -> @@ -62,7 +63,6 @@ -- | Make a temporary copy of given file and provide the path to the file in -- a sandbox directory. Automatically remove the files when the test -- finishes. - withSandbox :: FilePath -> ActionWith FilePath -> IO () withSandbox path action = withSystemTempDirectory "flac-test" $ \dir -> do @@ -72,7 +72,6 @@ -- | Extract body of given WAVE or RF64 file as a strict 'ByteString'. -- Needless to say that the body should be relatively short. - fetchWaveBody :: FilePath -> IO ByteString fetchWaveBody path = do Wave {..} <- readWaveFile path @@ -82,34 +81,49 @@ waveFiles :: [(FilePath, String)] waveFiles = - [ ( "audio-samples/1ch-44100hz-16bit.rf64" - , "1 channel 44100 Hz 16 bit (RF64)" ) - , ( "audio-samples/1ch-44100hz-16bit.wav" - , "1 channel 44100 Hz 16 bit (WAVE)" ) - , ( "audio-samples/1ch-44100hz-16bit-x.wav" - , "1 channel 44100 Hz 16 bit (WAVEX)" ) - , ( "audio-samples/2ch-11025hz-24bit.rf64" - , "2 channels 11025 Hz 24 bit (RF64)" ) - , ( "audio-samples/2ch-11025hz-24bit.wav" - , "2 channels 11025 Hz 24 bit (WAVE)" ) - , ( "audio-samples/2ch-11025hz-24bit-x.wav" - , "2 channels 11025 Hz 24 bit (WAVEX)" ) - , ( "audio-samples/2ch-8000hz-8bit.rf64" - , "2 channels 8000 Hz 8 bit (RF64)" ) - , ( "audio-samples/2ch-8000hz-8bit.wav" - , "2 channels 8000 Hz 8 bit (WAVE)" ) - , ( "audio-samples/2ch-8000hz-8bit-x.wav" - , "2 channels 8000 Hz 8 bit (WAVEX)" ) - , ( "audio-samples/1ch-44100hz-8bit-full-range.wav" - , "1 channel 44100 Hz 8 bit full range (WAVE)" ) - , ( "audio-samples/1ch-44100hz-8bit-silence.wav" - , "1 channel 44100 Hz 8 bit silence (WAVE)" ) - , ( "audio-samples/1ch-44100hz-16bit-full-range.wav" - , "1 channel 44100 Hz 16 bit full range (WAVE)" ) - , ( "audio-samples/1ch-44100hz-16bit-silence.wav" - , "1 channel 44100 Hz 16 bit silence (WAVE)" ) - , ( "audio-samples/1ch-44100hz-24bit-full-range.wav" - , "1 channel 44100 Hz 24 bit full range (WAVE)" ) - , ( "audio-samples/1ch-44100hz-24bit-silence.wav" - , "1 channel 44100 Hz 24 bit silence (WAVE)" ) + [ ( "audio-samples/1ch-44100hz-16bit.rf64", + "1 channel 44100 Hz 16 bit (RF64)" + ), + ( "audio-samples/1ch-44100hz-16bit.wav", + "1 channel 44100 Hz 16 bit (WAVE)" + ), + ( "audio-samples/1ch-44100hz-16bit-x.wav", + "1 channel 44100 Hz 16 bit (WAVEX)" + ), + ( "audio-samples/2ch-11025hz-24bit.rf64", + "2 channels 11025 Hz 24 bit (RF64)" + ), + ( "audio-samples/2ch-11025hz-24bit.wav", + "2 channels 11025 Hz 24 bit (WAVE)" + ), + ( "audio-samples/2ch-11025hz-24bit-x.wav", + "2 channels 11025 Hz 24 bit (WAVEX)" + ), + ( "audio-samples/2ch-8000hz-8bit.rf64", + "2 channels 8000 Hz 8 bit (RF64)" + ), + ( "audio-samples/2ch-8000hz-8bit.wav", + "2 channels 8000 Hz 8 bit (WAVE)" + ), + ( "audio-samples/2ch-8000hz-8bit-x.wav", + "2 channels 8000 Hz 8 bit (WAVEX)" + ), + ( "audio-samples/1ch-44100hz-8bit-full-range.wav", + "1 channel 44100 Hz 8 bit full range (WAVE)" + ), + ( "audio-samples/1ch-44100hz-8bit-silence.wav", + "1 channel 44100 Hz 8 bit silence (WAVE)" + ), + ( "audio-samples/1ch-44100hz-16bit-full-range.wav", + "1 channel 44100 Hz 16 bit full range (WAVE)" + ), + ( "audio-samples/1ch-44100hz-16bit-silence.wav", + "1 channel 44100 Hz 16 bit silence (WAVE)" + ), + ( "audio-samples/1ch-44100hz-24bit-full-range.wav", + "1 channel 44100 Hz 24 bit full range (WAVE)" + ), + ( "audio-samples/1ch-44100hz-24bit-silence.wav", + "1 channel 44100 Hz 24 bit silence (WAVE)" + ) ]