diff --git a/Source/Aeson.hs b/Source/Aeson.hs --- a/Source/Aeson.hs +++ b/Source/Aeson.hs @@ -1,7 +1,7 @@ module Aeson ( module Data.Aeson, module Data.Aeson.Types, - module Data.JsonSchema.Draft4, + module JSONSchema.Draft4, module Generics, lawlessJSONOptions, lawlessToJSONEncoding, @@ -14,7 +14,7 @@ import Data.Aeson import Data.Aeson.Types import GHC.Generics (Rep) -import Data.JsonSchema.Draft4 +import JSONSchema.Draft4 dropLensPrefix ∷ [Char] → [Char] dropLensPrefix = diff --git a/Source/Environment.hs b/Source/Environment.hs new file mode 100644 --- /dev/null +++ b/Source/Environment.hs @@ -0,0 +1,75 @@ +{-| +Module: Environment +Description: Execution environment, but as Text and lifted to MonadIO. +Copyright: © 2017 All rights reserved. +License: GPL-3 +Maintainer: Evan Cofsky +Stability: experimental +Portability: POSIX +-} + +module Environment where + +import Lawless +import IO +import Text +import Textual + +import qualified System.Environment as SE + +-- | A key in the 'Environment'. +newtype EnvName = EnvName {unEnvName ∷ Text} deriving (Eq, Ord, Show, Printable) +instance IsText EnvName where + packed = iso (EnvName ∘ view packed) (view unpacked ∘ unEnvName) + builder = iso (view builder ∘ unEnvName) (EnvName ∘ review builder) + +-- | A value in the 'Environment' +newtype EnvValue = EnvValue {unEnvValue ∷ Text} deriving (Eq, Ord, Show, Printable) +instance IsText EnvValue where + packed = iso (EnvValue ∘ view packed) (view unpacked ∘ unEnvValue) + builder = iso (view builder ∘ unEnvValue) (EnvValue ∘ review builder) + +lookupEnv ∷ MonadIO m ⇒ EnvName → m (Maybe EnvValue) +lookupEnv k = + liftIO $ maybe Nothing (Just ∘ EnvValue ∘ view packed) + <$> SE.lookupEnv (k ^. unpacked) + +setEnv ∷ MonadIO m ⇒ EnvName → EnvValue → m () +setEnv k v = liftIO $ SE.setEnv (k ^. unpacked) (v ^. unpacked) + +-- | 'Lens' for the system environment. +-- +-- +-- lens ∷ Functor f => (s -> a) -> (s -> b -> t) -> (a -> f b) -> s -> f t +-- +-- +-- Lens s t a b = Functor f ⇒ (a → f b) → s → f t +-- +-- 'lookupEnv' +-- s → a: EnvName → m (Maybe EnvValue) +-- +-- 'setEnv' +-- s → b → t: EnvName → EnvValue → m () +-- +-- s: EnvName +-- t: m () +-- a: m (Maybe EnvValue) +-- b: EnvValue +environment ∷ MonadIO m ⇒ Lens EnvName (m ()) (m (Maybe EnvValue)) EnvValue +environment = lens lookupEnv setEnv + +newtype Arg = Arg {unArg ∷ Text} deriving (Eq, Show, Ord, Printable) +instance IsText Arg where + packed = iso (Arg ∘ view packed) (view unpacked ∘ unArg) + builder = iso (view builder ∘ unArg) (Arg ∘ review builder) + +args ∷ (MonadIO m) ⇒ m [Arg] +args = liftIO $ over traversed (view packed) <$> SE.getArgs + +newtype ProgName = ProgName {unProgName ∷ Text} deriving (Eq, Show, Ord, Printable) +instance IsText ProgName where + packed = iso (ProgName ∘ view packed) (view unpacked ∘ unProgName) + builder = iso (view builder ∘ unProgName) (ProgName ∘ review builder) + +progName ∷ (MonadIO m) ⇒ m ProgName +progName = liftIO $ view packed <$> SE.getProgName diff --git a/Source/IO.hs b/Source/IO.hs --- a/Source/IO.hs +++ b/Source/IO.hs @@ -36,6 +36,7 @@ withOffset, withPosition, + withCurrentPosition, MonadIO, liftIO, @@ -68,11 +69,13 @@ import qualified System.IO as SIO import System.IO (Handle, stdin, stdout, stderr, SeekMode(..), IOMode(..)) import Data.Typeable +import Data.Text.Lazy.Builder (Builder) default (Text) -- * Printable I/O to stdio +-- | Exception representing a failure to parse a 'Textual'. data ParseError = ParseError { _peReason ∷ Text, _peStack ∷ [Text] @@ -91,57 +94,86 @@ instance Exception ParseError +-- | Try parsing a 'Textual', and throw 'ParseError' if it can't be parsed. 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 +-- | Read and parse a 'Textual" from 'stdin'. getLine ∷ (MonadIO m, MonadThrow m, Textual t) ⇒ m t getLine = TIO.getLine ≫= sTxt +-- | Read and parse a 'Textual' from a 'Handle'. 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, Printer p) ⇒ p → m () -putStr ∷ (MonadIO m, Printable p) ⇒ p → m () -putStr = TIO.putStr ∘ pTxt +-- | Write a 'Printer' to 'stdout'. +putStr ∷ (MonadIO m) ⇒ Builder → m () +putStr = TIO.putStr ∘ buildText -putStrLn ∷ (MonadIO m, Printable p) ⇒ p → m () -putStrLn = TIO.putStrLn ∘ pTxt +-- putStrLn ∷ (MonadIO m, Printer p) ⇒ p → m () -hPutStr ∷ (MonadIO m, Printable p) ⇒ Handle → p → m () -hPutStr h = TIO.hPutStr h ∘ pTxt +-- | Write a 'Printer' plus a newline to 'stdout'. +putStrLn ∷ MonadIO m ⇒ Builder → m () +putStrLn = TIO.putStrLn ∘ buildText -hPutStrLn ∷ (MonadIO m, Printable p) ⇒ Handle → p → m () -hPutStrLn h = TIO.hPutStrLn h ∘ pTxt +-- | Write a 'Printer' to a 'Handle'. +hPutStr ∷ (MonadIO m) ⇒ Handle → Builder → m () +hPutStr h = TIO.hPutStr h ∘ buildText +-- | Write a 'Printer' plus a newline to 'stderr'. +hPutStrLn ∷ (MonadIO m) ⇒ Handle → Builder → m () +hPutStrLn h = TIO.hPutStrLn h ∘ buildText + -- * Seek managers +-- | A relative position in a file 'Handle'. newtype FileOffset = FileOffset Integer - deriving (Eq, Ord, Show, Enum, Real, Num, Integral) + deriving (Eq, Ord, Show, Enum, Real, Num, Integral, Printable) + +-- | An absolute position in a file 'Handle'. newtype FilePosition = FilePosition Integer - deriving (Eq, Ord, Show, Enum, Real, Num, Integral) + deriving (Eq, Ord, Show, Enum, Real, Num, Integral, Printable) -seek ∷ (MonadIO m) ⇒ Handle → FileOffset → m () -seek h o = liftIO $ SIO.hSeek h RelativeSeek (fromIntegral o) +-- | Seek relative to the current position in 'Handle'. +rseek ∷ (MonadIO m) ⇒ Handle → FileOffset → m () +rseek 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) +-- | Seek to an absolute position in 'Handle'. +aseek ∷ (MonadIO m) ⇒ Handle → FilePosition → m () +aseek h p = liftIO $ SIO.hSeek h AbsoluteSeek (fromIntegral p) +-- | Get the current 'FilePosition'. 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 +-- | Function to flush a 'Handle' and seek to a position. +hreturn ∷ (MonadIO m) ⇒ FilePosition → Handle → m () +hreturn p h = (liftIO $ SIO.hFlush h) ≫ aseek h p + +-- | Save the current file position, seek relative to it, perform a +-- function, and then return to the original position. +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) + bracket_ (rseek h o) (hreturn p h) (f h) -withPosition ∷ (MonadIO m, MonadMask m) ⇒ Handle → FilePosition → (Handle → m a) → m a +-- | Save the current file position, seek to a new position, perform a +-- function, then return to the original position. +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) + bracket_ (aseek h p) (hreturn o h) (f h) + +withCurrentPosition ∷ (MonadIO m, MonadMask m) ⇒ + Handle → (Handle → m a) → m a +withCurrentPosition h f = withOffset h 0 f -- * Managed temporary files diff --git a/Source/Text/IO.hs b/Source/Text/IO.hs --- a/Source/Text/IO.hs +++ b/Source/Text/IO.hs @@ -62,9 +62,9 @@ -- | 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) +readLines h = repeatedly $ ifM (liftIO $ hIsEOF h) stop (hGetLine h ≫= yield) -- | 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 +writeLines h = autoM (\l → hPutStrLn h l ≫ return l) diff --git a/Tests/Line.hs b/Tests/Line.hs --- a/Tests/Line.hs +++ b/Tests/Line.hs @@ -14,22 +14,21 @@ import Textual import Arbitrary() import Test.QuickCheck -import Text +import Text hiding (text) import Text.IO import IO hiding (putStrLn) import Machine import Path -newtype Line = Line Text deriving (Eq, Ord, Show) +newtype Line = Line Text deriving (Eq, Ord, Show, Printable) 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 + withCurrentPosition h $ \i → + runT_ $ supply lns (mapping $ \(Line t) → t) ⇝ writeLines i + runT $ readLines h ⇝ mapping Line diff --git a/Tests/TestTextMachine.hs b/Tests/TestTextMachine.hs --- a/Tests/TestTextMachine.hs +++ b/Tests/TestTextMachine.hs @@ -14,7 +14,7 @@ module TestTextMachine where import Lawless -import Text +import Text hiding (text) import Arbitrary() import Test.Framework @@ -27,9 +27,9 @@ default (Text) prop_CheckTextMachine ∷ [Line] → Property -prop_CheckTextMachine lines = monadicIO $ do - m ← run $ readWriteLines lines - assert (lines == m) +prop_CheckTextMachine lns = monadicIO $ do + m ← run $ readWriteLines lns + assert (lns == m) properties ∷ Test properties = $(testGroupGenerator) diff --git a/liblawless.cabal b/liblawless.cabal --- a/liblawless.cabal +++ b/liblawless.cabal @@ -1,11 +1,11 @@ name: liblawless -version: 0.20.2 +version: 0.21.0 synopsis: Prelude based on protolude for GHC 8 and beyond. license: GPL-3 license-file: LICENSE author: Evan Cofsky maintainer: evan@theunixman.com -copyright: © 2016 Evan Cofsky +copyright: © 2017 Evan Cofsky category: Prelude build-type: Simple extra-source-files: @@ -28,7 +28,7 @@ source-repository this type: git location: git@gitlab.com:misandrist/liblawless.git - tag: v0.20.2 + tag: v0.21.0 library ghc-options: -Wall -Wno-redundant-constraints -Wno-type-defaults -O2 @@ -37,6 +37,7 @@ Arbitrary Boomerang ByteString + Environment Exception Generics IO @@ -92,7 +93,7 @@ data-textual >= 0.3.0 && < 0.4, dns >= 2.0.8 && < 2.1, exceptions >= 0.8.3 && < 0.9, - hjsonschema >= 1.2.0 && < 1.3, + hjsonschema >= 1.6.2 && < 1.7, lens >= 4.14 && < 4.16, machines >= 0.6.1 && < 0.7, managed >= 1.0.5 && < 1.1, @@ -107,11 +108,11 @@ semigroups >= 0.18.2 && < 0.19, stm >= 2.4.4 && < 2.5, stm-containers >= 0.2.15 && < 0.3, - QuickCheck >= 2.8.2 && < 2.9, + QuickCheck >= 2.8 && < 2.10, temporary >= 1.2.0 && < 1.3, text >= 1.2.2 && < 1.3, text-icu >= 0.7.0 && < 0.8, - text-icu-normalized >= 0.3.0 && < 0.4, + text-icu-normalized >= 0.4.0 && < 0.5, text-printer >= 0.4 && < 0.5, time >= 1.6.0 && < 1.7, transformers >= 0.5.2 && < 0.6, @@ -128,6 +129,7 @@ -feager-blackholing -rtsopts -dynamic + -with-rtsopts=-N default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: Tests @@ -139,14 +141,14 @@ TestTime Paths_liblawless build-depends: - QuickCheck >= 2.8.2 && < 2.9, + QuickCheck >= 2.8 && < 2.10, aeson < 1.0, base >= 4.9 && < 4.10, binary >= 0.7.5.0, bytestring, exceptions >= 0.8.3, filepath >= 1.4.0.0, - liblawless == 0.20.2, + liblawless, temporary >= 1.2.0.4, test-framework, test-framework-quickcheck2,