liblawless 0.19.5 → 0.20.1

raw patch · 8 files changed

+287/−144 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Source/IO.hs +148/−55
• Source/Text/IO.hs +28/−2
• Source/Text/Machine.hs +0/−38
• Source/Time.hs +61/−8
• Tests/Line.hs +35/−0
• Tests/TestTemporary.hs +8/−15
• Tests/TestTextMachine.hs +4/−22
• liblawless.cabal +3/−4

@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell, RecordWildCards #-} {-| Module:             IO Description:        General IO functions specialized for 'Printable' instances.@@ -10,113 +10,206 @@ -}  module IO (+    getLine,+    hGetLine,     putStr,     putStrLn,-    managed,-    Managed,-    MonadManaged(..),-    runManaged,-    TempFile,+    hPutStr,+    hPutStrLn,++    ParseError,+    peReason,+    peStack,++    MonadThrow,+    MonadCatch,+    MonadMask,++    Handle,++    TemporaryFile,     tfPath,     tfHandle,-    tempFile,++    binaryTemporaryFile,+    textTemporaryFile,++    withOffset,+    withPosition,+     MonadIO,     liftIO,-    PIO.hSeek,-    PIO.SeekMode(..),-    PIO.IOMode(..),-    file,-    tfile,-    textMode,-    binaryMode,-    hIsEOF,-    hClose,++    IOMode(..),+    binaryFile,+    textFile,++    isEOF,+    close,+     doesFileExist,     removeFile,-    PIO.Handle,-    SIO.stdin,-    SIO.stdout,-    SIO.stderr++    stdin,+    stdout,+    stderr     ) where  import Lawless import Control.Monad.IO.Class import qualified System.Path.Directory as D import qualified System.Path.IO as PIO-import qualified Data.Text.IO as T+import qualified Text.IO as TIO import Text import Textual import Path import qualified System.Path.PartClass as PC-import Control.Monad.Managed.Safe import Exception import qualified System.IO as SIO+import System.IO (Handle, stdin, stdout, stderr, SeekMode(..), IOMode(..))+import Data.Typeable +default (Text)+ -- * Printable I/O to stdio -liftPrintble ∷ (MonadIO m, Printable p) ⇒ (Text → IO ()) → p → m ()-liftPrintble f p = liftIO $ f (buildText ∘ print $ p)+data ParseError = ParseError {+    _peReason ∷ Text,+    _peStack ∷ [Text]+    } deriving (Eq, Ord, Typeable)+makeLenses ''ParseError +instance Printable ParseError where+    print (ParseError {..}) = fsep ": " [+        print "Parse error",+        print _peReason,+        parens $ fsep (print ", ") $ over traversed print _peStack+        ]++instance Show ParseError where+    show = buildString ∘ print++instance Exception ParseError++sTxt ∷ (MonadThrow m, Textual t) ⇒ Text → m t+sTxt t = case parseText t of+    Malformed s r → throwM $ ParseError (r ^. packed) $ over traversed (view packed) s+    Parsed v → return v++getLine ∷ (MonadIO m, MonadThrow m, Textual t) ⇒ m t+getLine = TIO.getLine ≫= sTxt++hGetLine ∷ (MonadIO m, MonadThrow m, Textual t) ⇒ Handle → m t+hGetLine h = TIO.hGetLine h ≫= sTxt++pTxt ∷ (Printable p)⇒ p → Text+pTxt = buildText ∘ print+ putStr ∷ (MonadIO m, Printable p) ⇒ p → m ()-putStr = liftPrintble T.putStr+putStr = TIO.putStr ∘ pTxt  putStrLn ∷ (MonadIO m, Printable p) ⇒ p → m ()-putStrLn = liftPrintble T.putStrLn+putStrLn = TIO.putStrLn ∘ pTxt +hPutStr ∷ (MonadIO m, Printable p) ⇒ Handle → p → m ()+hPutStr h = TIO.hPutStr h ∘ pTxt++hPutStrLn ∷ (MonadIO m, Printable p) ⇒ Handle → p → m ()+hPutStrLn h = TIO.hPutStrLn h ∘ pTxt++-- * Seek managers++newtype FileOffset = FileOffset Integer+    deriving (Eq, Ord, Show, Enum, Real, Num, Integral)+newtype FilePosition = FilePosition Integer+    deriving (Eq, Ord, Show, Enum, Real, Num, Integral)++seek ∷ (MonadIO m) ⇒ Handle → FileOffset → m ()+seek h o = liftIO $ SIO.hSeek h RelativeSeek (fromIntegral o)++seek_ ∷ (MonadIO m) ⇒ Handle → FilePosition → m ()+seek_ h p = liftIO $ SIO.hSeek h AbsoluteSeek (fromIntegral p)++tell ∷ (MonadIO m) ⇒ Handle → m FilePosition+tell h = liftIO $ fromIntegral <$> SIO.hTell h++withOffset ∷ (MonadIO m, MonadMask m) ⇒ Handle → FileOffset → (Handle → m a) → m a+withOffset h o f= do+    p ← tell h+    bracket_ (seek h o) (seek_ h p) (f h)++withPosition ∷ (MonadIO m, MonadMask m) ⇒ Handle → FilePosition → (Handle → m a) → m a+withPosition h p f = do+    o ← tell h+    bracket_ (seek_ h p) (seek_ h o) (f h)+ -- * Managed temporary files-data TempFile = TempFile {++data TemporaryFile = TemporaryFile {     _tfPath ∷ AbsFile,-    _tfHandle ∷ PIO.Handle+    _tfHandle ∷ Handle     }-makeLenses ''TempFile+makeLenses ''TemporaryFile -tempFile ∷ AbsDir → RelFile → Managed TempFile-tempFile pth tmpl =+temporaryFile ∷ (MonadIO m, MonadMask m) ⇒+    (Handle → m ()) → AbsDir → RelFile → (TemporaryFile → m a) → m a+temporaryFile m pth tmpl =     let-        open = do+        openT = do             (p, h) ← liftIO $ PIO.openTempFile pth tmpl-            liftIO $ binaryMode h-            return $ TempFile p h+            m h+            return $ TemporaryFile p h -        close tf = do+        closeT tf = do             liftIO $ PIO.hClose $ tf ^. tfHandle             liftIO $ D.removeFile $ tf ^. tfPath     in-        managed $ bracket open close+        bracket openT closeT --- * Managed files+binaryTemporaryFile ∷ (MonadIO m, MonadMask m, MonadThrow m) ⇒+    AbsDir → RelFile → (TemporaryFile → m a) → m a+binaryTemporaryFile = temporaryFile binaryMode --- | Binary files, no buffering.-file ∷ PC.AbsRel ar ⇒ File ar → PIO.IOMode → Managed PIO.Handle-file pth m = managed $ \fh → do-    liftIO $ PIO.withBinaryFile pth m $ \h → do-        binaryMode h-        fh h+textTemporaryFile ∷ (MonadIO m, MonadMask m, MonadThrow m) ⇒+    AbsDir → RelFile → (TemporaryFile → m a) → m a+textTemporaryFile = temporaryFile textMode --- | Text files, line-buffered.-tfile ∷ PC.AbsRel ar ⇒ File ar → PIO.IOMode → Managed PIO.Handle-tfile pth m =managed $ \fh → do-    liftIO $ PIO.withBinaryFile pth m $ \h → do-        textMode h-        fh h+-- * Managed files+open ∷ (MonadIO m, PC.AbsRel ar) ⇒ File ar → IOMode → (Handle → m ()) → m Handle+open p m t = do+    h ← liftIO $ PIO.openBinaryFile p m+    t h+    return h -textMode ∷ MonadIO m ⇒ PIO.Handle → m ()+textMode ∷ MonadIO m ⇒ Handle → m () textMode h = liftIO $     PIO.hSetBuffering h PIO.LineBuffering >>     PIO.hSetBinaryMode h False -binaryMode ∷ MonadIO m ⇒ PIO.Handle → m ()+binaryMode ∷ MonadIO m ⇒ Handle → m () binaryMode h = liftIO $     PIO.hSetBuffering h PIO.NoBuffering >>     PIO.hSetBinaryMode h True +-- | Binary files, no buffering.+binaryFile ∷ (MonadIO m, MonadMask m, PC.AbsRel ar) ⇒+    File ar → IOMode → (Handle → m a) → m a+binaryFile pth m =+    bracket (open pth m binaryMode) (close)++-- | Text files, line-buffered.+textFile ∷ (MonadIO m, MonadMask m, PC.AbsRel ar) ⇒+    File ar → IOMode → (Handle → m a) → m a+textFile pth m = do+    bracket (open pth m textMode) (close)+ -- * Lifted IO -hIsEOF ∷ MonadIO m ⇒ SIO.Handle → m Bool-hIsEOF = liftIO ∘ SIO.hIsEOF+isEOF ∷ MonadIO m ⇒ Handle → m Bool+isEOF = liftIO ∘ SIO.hIsEOF -hClose ∷ MonadIO m ⇒ SIO.Handle → m ()-hClose = liftIO ∘ SIO.hClose+close ∷ MonadIO m ⇒ Handle → m ()+close = liftIO ∘ SIO.hClose  doesFileExist ∷ (MonadIO m, PC.AbsRel ar) ⇒ File ar → m Bool doesFileExist = liftIO ∘ D.doesFileExist

@@ -12,9 +12,14 @@     readFile,     writeFile,     appendFile,+    getLine,+    putStr,+    putStrLn,     hGetLine,     hPutStr,-    hPutStrLn+    hPutStrLn,+    readLines,+    writeLines     ) where  import Lawless@@ -23,7 +28,8 @@ import Data.Text (Text) import System.Path import Control.Monad.IO.Class-import System.Path.IO (Handle)+import System.Path.IO (Handle, hIsEOF)+import Machine  readFile ∷ (MonadIO m) ⇒ AbsRelFile → m Text readFile = liftIO ∘ TIO.readFile ∘ toString@@ -34,11 +40,31 @@ appendFile ∷ (MonadIO m) ⇒ AbsRelFile → Text → m () appendFile f t = liftIO $ TIO.appendFile (toString f) t +putStr ∷ (MonadIO m) ⇒ Text → m ()+putStr = liftIO ∘ TIO.putStr++putStrLn ∷ (MonadIO m) ⇒ Text → m ()+putStrLn = liftIO ∘ TIO.putStrLn+ hPutStr ∷ (MonadIO m) ⇒ Handle → Text → m () hPutStr h = liftIO ∘ TIO.hPutStr h  hPutStrLn ∷ (MonadIO m) ⇒ Handle → Text → m () hPutStrLn h = liftIO ∘ TIO.hPutStrLn h +getLine ∷ (MonadIO m) ⇒ m Text+getLine = liftIO TIO.getLine+ hGetLine ∷ (MonadIO m) ⇒ Handle → m Text hGetLine = liftIO ∘ TIO.hGetLine++-- * Machines++-- | Read lines of 'Text' from a 'Handle' until $EOF$ is reached.+readLines  ∷ ∀ (m ∷ * → *). (MonadIO m) ⇒ Handle → SourceT m Text+readLines h = repeatedly $ ifM (liftIO $ hIsEOF h) stop (hGetLine h)++-- | Write lines of 'Text' to a 'Handle' until there are no+-- more. Forwards them on.+writeLines ∷ ∀ (m ∷ * → *). (MonadIO m) ⇒ Handle → ProcessT m Text Text+writeLines h = repeatedly $ await ≫= \l → hPutStrLn h l ≫ return l

@@ -1,38 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-|-Module:             Text.Machines-Description:        Machines for transducing Text streams.-Copyright:          © 2016 All rights reserved.-License:            GPL-3-Maintainer:         Evan Cofsky <>-Stability:          experimental-Portability:        POSIX--}--module Text.Machine (-    readLines,-    writeLines-    ) where--import Lawless-import IO-import Text-import Text.IO-import Machine---- | Read lines from a 'Handle' until $EOF$ is reached.-readLines ∷ MonadIO m ⇒ Handle → SourceT m Text-readLines h =-    let-        p = ifM (liftIO $ hIsEOF h) stop ((liftIO $ hGetLine h) >>= yield >> p)-    in-        construct p---- | Write lines to a 'Handle' until there are no more. Forwards them--- on.-writeLines ∷ MonadIO m ⇒ Handle → ProcessT m Text Text-writeLines h =-    let-        w = await >>= liftIO ∘ hPutStrLn h >> w-    in-        construct w

@@ -3,35 +3,71 @@ module Time   (     Time,+    Seconds,     ParseTime(..),     FormatTime(..),     _Time,     day,     time,-    now+    now,+    seconds   ) where -import Lawless-import Data.Time.Clock+import Data.Binary+import Data.Char+import Data.Data import Data.Time.Calendar+import Data.Time.Clock import Data.Time.Format import Generics-import Data.Binary-+import IO (MonadIO, liftIO)+import Lawless+import Text import qualified Textual as T+import qualified Parser as P+import Aeson +default (Text)+ newtype Time = Time UTCTime deriving (Show, Eq, Ord, ParseTime, FormatTime, Generic) makePrisms ''Time +deriving instance ToJSON Time+deriving instance FromJSON Time++timeFormat ∷ [Char]+timeFormat = (iso8601DateFormat (Just "%H:%M:%S.%q%z"))++-- | 'Lens' for the 'Day' component of a 'Time'. day :: Lens' Time Day day = lens (utctDay ∘ view _Time) (\(Time (UTCTime{..})) d → Time $ UTCTime d utctDayTime) +-- | 'Lens' for the 'DiffTime' component of a 'Time'. time ∷ Lens' Time DiffTime time = lens (utctDayTime ∘ view _Time) (\(Time (UTCTime{..})) t → Time $ UTCTime utctDay t) -now ∷ IO Time-now = Time <$> getCurrentTime+-- | Get the current system time.+now ∷ MonadIO m ⇒ m Time+now = liftIO $ Time <$> getCurrentTime +newtype Seconds = Seconds DiffTime+    deriving (Eq, Ord, Show, Enum, Fractional, Data, Num, Real, RealFrac)++-- | Convert between 'Double' and 'Seconds'.+seconds ∷ Iso' Double DiffTime+seconds = iso (fromRational ∘ toRational) (fromRational ∘ toRational)++instance FromJSON Seconds where+    parseJSON (Number n) = return $ Seconds (fromRational ∘ toRational $ n)+    parseJSON v = typeMismatch "Seconds" v++instance ToJSON Seconds where+    toJSON = Number ∘ fromRational ∘ toRational++instance Binary Seconds where+    put = put ∘ toRational+    get = Seconds ∘ fromRational <$> get+ instance Binary Time where   put t =     put (toModifiedJulianDay (t ^. day)) >>@@ -43,4 +79,21 @@     return ∘ Time $ UTCTime d t  instance T.Printable Time where-  print = T.print ∘ formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S%QZ"))+  print = T.print ∘formatTime defaultTimeLocale timeFormat++parseTimeFormats ∷ [[Char]]+parseTimeFormats = over traversed (iso8601DateFormat ∘ Just) [+    "%H:%M:%S%Q%z",+    "%H:%M:%S%QZ"+    ]++instance T.Textual Time where+    textual =+        let+            r = P.some+                (P.satisfy+                    (\c → isAlphaNum c ∨ anyOf traversed (c≡) (":+-." ∷ [Char]))+                )+            p f = (parseTimeM False defaultTimeLocale f)+        in+            P.choice $ over traversed (\f → P.try $ p f =≪ r) parseTimeFormats

@@ -0,0 +1,35 @@+{-|+Module:             Line+Description:        Arbitrary Text Line.+Copyright:          © 2017 All rights reserved.+License:            GPL-3+Maintainer:         Evan Cofsky <evan@theunixman.com>+Stability:          experimental+Portability:        POSIX+-}++module Line (Line(..), readWriteLines) where++import Lawless hiding (mapping)+import Textual+import Arbitrary()+import Test.QuickCheck+import Text+import Text.IO+import IO hiding (putStrLn)+import Machine+import Path++newtype Line = Line Text deriving (Eq, Ord, Show)+instance Arbitrary Line where+    arbitrary = Line <$> suchThat arbitrary (allOf each (≥ ' '))+instance Printable Line where+    print (Line t) = print t++readWriteLines ∷+    (Traversable f, MonadMask m, MonadIO m) ⇒+    f Line → m [Line]+readWriteLines lns = textTemporaryFile (absDir "/tmp") (relFile "testTemp") $ \tf → do+    let h = tf ^. tfHandle+    runT_ $ supply lns (mapping $ \(Line t) → t) ⇝ writeLines h ⇝ autoM (\l → putStrLn l ≫ return l)+    runT $ readLines h ⇝ autoM (\l → putStrLn l ≫ return l) ⇝ mapping Line

@@ -17,8 +17,7 @@ import Path import Text import Text.IO-import IO-import Control.Concurrent.STM+import IO hiding (hGetLine, hPutStrLn)  import Arbitrary() import Test.Framework@@ -26,24 +25,18 @@ import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck import Test.QuickCheck.Monadic-default (Text)+import Line -newtype Line = Line Text deriving (Eq, Ord, Show)-instance Arbitrary Line where-    arbitrary = Line <$> suchThat arbitrary (not ∘ anyOf each (≡ '\n'))+default (Text)  prop_CheckBuffering ∷ Line → Property-prop_CheckBuffering (Line line) = monadicIO $ do+prop_CheckBuffering (Line l) = monadicIO $ do     m ← run $ do-        v ← atomically $ newEmptyTMVar-        runManaged $ do-            tf ← tempFile (absDir ("/tmp" ∷ Text)) (relFile ("testTemp" ∷ Text))+        binaryTemporaryFile (absDir "/tmp") (relFile "testTemp") $ \tf → do             let h = tf ^. tfHandle-            liftIO $ hPutStrLn h line-            liftIO $ hSeek h AbsoluteSeek 0-            liftIO $ hGetLine h >>= atomically ∘ putTMVar v-        liftIO $ atomically $ takeTMVar v-    assert (line ≡ m)+            withOffset h 0 $ \_ → hPutStrLn h l+            hGetLine h+    assert (l ≡ m)  properties ∷ Test properties = $(testGroupGenerator)

@@ -14,12 +14,7 @@ module TestTextMachine where  import Lawless-import Path import Text-import Text.Machine-import IO-import Control.Concurrent.STM-import Machine hiding (run)  import Arbitrary() import Test.Framework@@ -27,27 +22,14 @@ import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck import Test.QuickCheck.Monadic-default (Text)--newtype Line = Line Text deriving (Eq, Ord, Show)-makePrisms ''Line+import Line -instance Arbitrary Line where-    arbitrary = Line <$> suchThat arbitrary (allOf each (≢ '\n'))+default (Text)  prop_CheckTextMachine ∷ [Line] → Property prop_CheckTextMachine lines = monadicIO $ do-    let tls = over traversed (view _Line) lines-    m ← run $ do-        v ← atomically $ newEmptyTMVar-        runManaged $ do-            tf ← tempFile (absDir ("/tmp" ∷ Text)) (relFile ("testTemp" ∷ Text))-            let h = tf ^. tfHandle-            runT_ $ supply tls $ writeLines h-            liftIO $ hSeek h AbsoluteSeek 0-            liftIO $ (runT $ readLines h) >>= atomically ∘ putTMVar v-        liftIO $ atomically $ takeTMVar v-    assert (tls == m)+    m ← run $ readWriteLines lines+    assert (lines == m)  properties ∷ Test properties = $(testGroupGenerator)

@@ -1,5 +1,5 @@ name:                liblawless-version:             0.19.5+version:             0.20.1 synopsis:            Prelude based on protolude for GHC 8 and beyond. license:             GPL-3 license-file:        LICENSE@@ -28,10 +28,10 @@ source-repository this   type:     git   location:   git@gitlab.com:misandrist/liblawless.git-  tag: v0.19.5+  tag: v0.20.1  library-  ghc-options: -Wall -Wno-redundant-constraints -O2+  ghc-options: -Wall -Wno-redundant-constraints -Wno-type-defaults -O2   exposed-modules:                   Aeson                   Arbitrary@@ -49,7 +49,6 @@                   Set                   Text                   Text.IO-                  Text.Machine                   Textual                   Time                   Tree