diff --git a/Source/IO.hs b/Source/IO.hs --- a/Source/IO.hs +++ b/Source/IO.hs @@ -24,7 +24,16 @@ liftIO, PIO.hSeek, PIO.SeekMode(..), - file + PIO.IOMode(..), + file, + tfile, + textMode, + binaryMode, + hIsEOF, + hClose, + doesFileExist, + removeFile, + PIO.Handle ) where import Lawless @@ -35,9 +44,13 @@ 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 +-- * Printable I/O to stdio + liftPrintble ∷ (MonadIO m, Printable p) ⇒ (Text → IO ()) → p → m () liftPrintble f p = liftIO $ f (buildText ∘ print $ p) @@ -47,6 +60,7 @@ putStrLn ∷ (MonadIO m, Printable p) ⇒ p → m () putStrLn = liftPrintble T.putStrLn +-- * Managed temporary files data TempFile = TempFile { _tfPath ∷ AbsFile, _tfHandle ∷ PIO.Handle @@ -58,8 +72,7 @@ let open = do (p, h) ← liftIO $ PIO.openTempFile pth tmpl - liftIO $ PIO.hSetBuffering h PIO.NoBuffering - liftIO $ PIO.hSetBinaryMode h True + liftIO $ binaryMode h return $ TempFile p h close tf = do @@ -68,6 +81,42 @@ in managed $ bracket open close -file ∷ AbsRelFile → PIO.IOMode → Managed PIO.Handle +-- * Managed files + +-- | 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 fh + liftIO $ PIO.withBinaryFile pth m $ \h → do + binaryMode h + fh h + +-- | 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 + +textMode ∷ MonadIO m ⇒ PIO.Handle → m () +textMode h = liftIO $ + PIO.hSetBuffering h PIO.LineBuffering >> + PIO.hSetBinaryMode h False + +binaryMode ∷ MonadIO m ⇒ PIO.Handle → m () +binaryMode h = liftIO $ + PIO.hSetBuffering h PIO.NoBuffering >> + PIO.hSetBinaryMode h True + +-- * Lifted IO + +hIsEOF ∷ MonadIO m ⇒ SIO.Handle → m Bool +hIsEOF = liftIO ∘ SIO.hIsEOF + +hClose ∷ MonadIO m ⇒ SIO.Handle → m () +hClose = liftIO ∘ SIO.hClose + +doesFileExist ∷ (MonadIO m, PC.AbsRel ar) ⇒ File ar → m Bool +doesFileExist = liftIO ∘ D.doesFileExist + +removeFile ∷ (MonadIO m, PC.AbsRel ar) ⇒ File ar → m () +removeFile = liftIO ∘ D.removeFile diff --git a/Source/Path.hs b/Source/Path.hs --- a/Source/Path.hs +++ b/Source/Path.hs @@ -89,6 +89,7 @@ RelDir, AbsRelFile, AbsRelDir, + File, absFile, relFile, absDir, @@ -109,6 +110,7 @@ RelDir, AbsRelFile, AbsRelDir, + File, (), (<.>), (<++>) diff --git a/Source/Text/IO.hs b/Source/Text/IO.hs --- a/Source/Text/IO.hs +++ b/Source/Text/IO.hs @@ -14,10 +14,7 @@ appendFile, hGetLine, hPutStr, - hPutStrLn, - getLine, - putStr, - putStrLn + hPutStrLn ) where import Lawless @@ -45,12 +42,3 @@ hGetLine ∷ (MonadIO m) ⇒ Handle → m Text hGetLine = liftIO ∘ TIO.hGetLine - -getLine ∷ (MonadIO m) ⇒ m Text -getLine = liftIO TIO.getLine - -putStr ∷ (MonadIO m) ⇒ Text → m () -putStr = liftIO ∘ TIO.putStr - -putStrLn ∷ (MonadIO m) ⇒ Text → m () -putStrLn = liftIO ∘ TIO.putStrLn diff --git a/Source/Text/Machine.hs b/Source/Text/Machine.hs new file mode 100644 --- /dev/null +++ b/Source/Text/Machine.hs @@ -0,0 +1,38 @@ +{-# 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 diff --git a/Tests/Main.hs b/Tests/Main.hs --- a/Tests/Main.hs +++ b/Tests/Main.hs @@ -7,10 +7,12 @@ import qualified TestAeson as TJ import qualified TestTemporary as TM import qualified TestAesonEncoding as TE +import qualified TestTextMachine as TX main :: IO () main = defaultMain [ TT.properties, TJ.properties, TM.properties, - TE.properties] + TE.properties, + TX.properties] diff --git a/Tests/TestTextMachine.hs b/Tests/TestTextMachine.hs new file mode 100644 --- /dev/null +++ b/Tests/TestTextMachine.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +{-| +Module: TestTextMachine +Description: Test reading lines from text files. +Copyright: © 2016 All rights reserved. +License: GPL-3 +Maintainer: Evan Cofsky +Stability: experimental +Portability: POSIX +-} + +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 +import Test.Framework.TH +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 + +instance Arbitrary Line where + arbitrary = Line <$> suchThat arbitrary (allOf each (≢ '\n')) + +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) + +properties ∷ Test +properties = $(testGroupGenerator) diff --git a/liblawless.cabal b/liblawless.cabal --- a/liblawless.cabal +++ b/liblawless.cabal @@ -1,5 +1,5 @@ name: liblawless -version: 0.18.3 +version: 0.19.0 synopsis: Prelude based on protolude for GHC 8 and beyond. license: GPL-3 license-file: LICENSE @@ -48,6 +48,7 @@ Set Text Text.IO + Text.Machine Textual Time Tree