Browse Source

Fix up compatibility with old versions of base without relying on CPP (#14)

Oops import

Remove compat prelude and just import shit

Formatting script & changes to Compat

Add base-compat-batteries

Remove the Prosidy.Compat shim

Co-authored-by: Alex Feldman-Crough <alex@fldcr.com>
Reviewed-on: #14
master
James Alexander Feldman-Crough 2 years ago
parent
commit
38b32e7845
  1. 33
      prosidy.cabal
  2. 57
      scripts/format
  3. 8
      src/Prosidy/Compat.hs
  4. 3
      src/Prosidy/Optics/Internal.hs
  5. 4
      src/Prosidy/Parse.hs
  6. 2
      src/Prosidy/Types/Series.hs
  7. 2
      test/Paths_prosidy.hs
  8. 17
      test/Prosidy/Test.hs
  9. 68
      test/Prosidy/Test/Parse.hs
  10. 76
      test/Prosidy/Test/Source.hs
  11. 64
      test/Prosidy/Test/Types.hs

33
prosidy.cabal

@ -1,6 +1,6 @@
cabal-version: 2.4
name: prosidy
version: 1.6.0.1
version: 1.6.0.2
synopsis: A simple language for writing documents.
license: MPL-2.0
license-file: LICENSE
@ -58,24 +58,23 @@ library
other-modules:
Prosidy.Optics.Internal
, Prosidy.Compat
build-depends:
base >= 4.11 && < 5
, aeson >= 1.4 && < 1.5
, bytestring >= 0.10 && < 0.11
, binary >= 0.8 && < 0.9
, containers >= 0.6 && < 0.7
, contravariant >= 1.5 && < 1.6
, deepseq >= 1.4 && < 1.5
, hashable >= 1.2 && < 1.4
, megaparsec >= 7.0 && < 8.1
, profunctors >= 5.3 && < 5.6
, tagged >= 0.8 && < 0.9
, text >= 1.2 && < 1.3
, transformers >= 0.5 && < 0.6
, vector >= 0.12 && < 0.13
, unordered-containers >= 0.2 && < 0.3
base >= 4.11 && < 5
, base-compat-batteries >= 0.11 && < 0.12
, aeson >= 1.4 && < 1.5
, bytestring >= 0.10 && < 0.11
, binary >= 0.8 && < 0.9
, containers >= 0.6 && < 0.7
, deepseq >= 1.4 && < 1.5
, hashable >= 1.2 && < 1.4
, megaparsec >= 7.0 && < 8.1
, profunctors >= 5.3 && < 5.6
, tagged >= 0.8 && < 0.9
, text >= 1.2 && < 1.3
, transformers >= 0.5 && < 0.6
, vector >= 0.12 && < 0.13
, unordered-containers >= 0.2 && < 0.3
-------------------------------------------------------------------------------
test-suite prosidy-test

57
scripts/format

@ -0,0 +1,57 @@
#!/bin/bash
set -euo pipefail
cd "$(git rev-parse --show-toplevel)"
log ()
{
local color='0'
case "$1" in
--red | -r) color=31; shift;;
--green | -g) color=32; shift;;
--yellow | -y) color=33; shift;;
--cyan | -c) color=36; shift;;
--) shift;;
esac
printf -- '\e[%dm----> %b\e[m\n' "$color" "$*" >&2
}
fail ()
{
if [[ "$1" != -* ]]
then
log --red "$@"
else
log "$@"
fi
exit 1
}
log -c 'Checking for \e[1muntracked\e[22m files and \e[1munstaged\e[22m modifications…'
num_untracked="$(git ls-files --exclude-standard --modified --others | tee /dev/tty | wc -l)"
if (( num_untracked == 0 ))
then
log -g 'No unstanged changes!'
else
log -y "Found \e[1m$num_untracked changes\e[22m not staged to the index."
fail 'Please stage or commit all changes before running this script.'
fi
log -c 'Formatting Haskell source files…'
grep \
--extended-regexp \
--files-without-match \
--include '*.hs' \
--recursive \
'\{-#\s+ANN\s+module\s+"nofmt"\s+#-}' \
src/ test/ \
| xargs -t brittany --config-file brittany.yaml --write-mode inplace
num_changed="$(git ls-files --exclude-standard --modified | tee /dev/tty | wc -l)"
if (( num_changed == 0 ))
then
log -g 'No formatting changes were made!'
else
log -y "Reformatted $num_changed Haskell source files."
exit 2
fi

8
src/Prosidy/Compat.hs

@ -1,8 +0,0 @@
{-# LANGUAGE CPP #-}
module Prosidy.Compat
( MonadFail(..)
) where
#if __GLASGOW_HASKELL__ < 808
import Control.Monad.Fail (MonadFail(..))
#endif

3
src/Prosidy/Optics/Internal.hs

@ -26,7 +26,8 @@ import Data.Monoid ( First(..)
)
import Data.Functor.Identity ( Identity(..) )
import Data.Tagged ( Tagged(..) )
import Data.Functor.Contravariant ( Contravariant(..) )
import Data.Functor.Contravariant.Compat
( Contravariant(..) )
type Optic p f s t a b = p a (f b) -> p s (f t)
type Iso s t a b = forall p f . (Profunctor p, Functor f) => Optic p f s t a b

4
src/Prosidy/Parse.hs

@ -10,7 +10,7 @@ Maintainer : alex@fldcr.com
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Prosidy.Parse
( -- * Parsing Prosidy types from 'Data.Text.Text'
parseDocument
@ -24,7 +24,7 @@ module Prosidy.Parse
)
where
import Prosidy.Compat
import Control.Monad.Fail.Compat ( MonadFail(..) )
import Prelude hiding ( fail )
import Prosidy.Types

2
src/Prosidy/Types/Series.hs

@ -45,6 +45,8 @@ import Control.Monad ( guard )
import qualified Data.Sequence as Seq
{-# ANN module "nofmt" #-}
-- | A newtype wrapper around a sequential collection.
--
-- Currently, 'Series' is implemented as a 'Seq', but this is not guarenteed to

2
test/Paths_prosidy.hs

@ -1,4 +1,4 @@
module Paths_prosidy where
getDataDir :: IO FilePath
getDataDir = pure "data"
getDataDir = pure "data"

17
test/Prosidy/Test.hs

@ -1,21 +1,16 @@
import Test.Tasty
import Test.Tasty.Runners.AntXML (antXMLRunner)
import Test.Tasty
import Test.Tasty.Runners.AntXML ( antXMLRunner )
import qualified Prosidy.Test.Source
import qualified Prosidy.Test.Types
import qualified Prosidy.Test.Parse
main :: IO ()
main = tests >>= defaultMainWithIngredients ingredients
where
ingredients = defaultIngredients ++
[ antXMLRunner
]
where ingredients = defaultIngredients ++ [antXMLRunner]
tests :: IO TestTree
tests = do
parseTests <- Prosidy.Test.Parse.tests
pure $ testGroup "test"
[ Prosidy.Test.Source.tests
, Prosidy.Test.Types.tests
, parseTests
]
pure $ testGroup
"test"
[Prosidy.Test.Source.tests, Prosidy.Test.Types.tests, parseTests]

68
test/Prosidy/Test/Parse.hs

@ -4,21 +4,23 @@ module Prosidy.Test.Parse (tests) where
import qualified Prosidy
import Test.Tasty
import Test.Tasty.Golden.Advanced (goldenTest)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BS.Lazy
import qualified System.Directory as Dir
import System.FilePath ((</>))
import Control.Exception (handle, displayException)
import Test.Tasty
import Test.Tasty.Golden.Advanced ( goldenTest )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BS.Lazy
import qualified System.Directory as Dir
import System.FilePath ( (</>) )
import Control.Exception ( handle
, displayException
)
import qualified Paths_prosidy as Paths
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Diff as Aeson.Diff
import qualified Data.Aeson.Encode.Pretty as Aeson.Pretty
import qualified Paths_prosidy as Paths
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Diff as Aeson.Diff
import qualified Data.Aeson.Encode.Pretty as Aeson.Pretty
import qualified Data.Text.Lazy as Text.Lazy
import Data.Text.Lazy.Encoding (decodeUtf8With)
import qualified Data.Text.Lazy as Text.Lazy
import Data.Text.Lazy.Encoding ( decodeUtf8With )
tests :: IO TestTree
tests = do
@ -27,38 +29,38 @@ tests = do
pure . testGroup "parse" $ makeTest goldenDir <$> goldenTests
makeTest :: FilePath -> String -> TestTree
makeTest goldenDir name =
goldenTest name
(catchErrors getJSON)
(catchErrors parsePro)
compareDocs
writeGolden
makeTest goldenDir name = goldenTest name
(catchErrors getJSON)
(catchErrors parsePro)
compareDocs
writeGolden
where
getJSON :: IO Aeson.Value
getJSON = do
bytes <- BS.readFile $ goldenDir </> name </> "output.json"
case Aeson.eitherDecode' . BS.Lazy.fromStrict $ bytes of
Left e -> fail $ "Failed to parse JSON: " <> e
Left e -> fail $ "Failed to parse JSON: " <> e
Right ok -> pure ok
parsePro :: IO Aeson.Value
parsePro = Aeson.toJSON <$>
Prosidy.readDocument (goldenDir </> name </> "input.pro")
parsePro = Aeson.toJSON
<$> Prosidy.readDocument (goldenDir </> name </> "input.pro")
compareDocs :: Aeson.Value -> Aeson.Value -> IO (Maybe String)
compareDocs gold test | gold == test = pure Nothing
compareDocs gold test =
let
diff = Aeson.Diff.diff (Aeson.toJSON gold) (Aeson.toJSON test)
pretty = Aeson.Pretty.encodePretty diff
in
pure . Just . Text.Lazy.unpack $
"Golden test failed. The diff is included below:\n" <>
decodeUtf8With (\_ _ -> Just '\65533') pretty
compareDocs gold test =
let diff = Aeson.Diff.diff (Aeson.toJSON gold) (Aeson.toJSON test)
pretty = Aeson.Pretty.encodePretty diff
in pure
. Just
. Text.Lazy.unpack
$ "Golden test failed. The diff is included below:\n"
<> decodeUtf8With (\_ _ -> Just '\65533') pretty
writeGolden :: Aeson.Value -> IO ()
writeGolden doc = BS.Lazy.writeFile (goldenDir </> name </> "output.json") $
Aeson.Pretty.encodePretty doc
writeGolden doc =
BS.Lazy.writeFile (goldenDir </> name </> "output.json")
$ Aeson.Pretty.encodePretty doc
catchErrors :: IO a -> IO a
catchErrors = handle $ \(e :: Prosidy.Failure) -> fail $ displayException e
catchErrors = handle $ \(e :: Prosidy.Failure) -> fail $ displayException e

76
test/Prosidy/Test/Source.hs

@ -1,19 +1,22 @@
{-# LANGUAGE OverloadedStrings #-}
module Prosidy.Test.Source (tests) where
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import Data.Foldable (toList, for_)
import Data.IORef
import System.IO.Unsafe
import Control.Exception (evaluate)
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import Data.Foldable ( toList
, for_
)
import Data.IORef
import System.IO.Unsafe
import Control.Exception ( evaluate )
import qualified Prosidy.Source as PS
import qualified Data.Text as T
import qualified Prosidy.Source as PS
import qualified Data.Text as T
tests :: TestTree
tests = testGroup "source"
tests = testGroup
"source"
[ testEmptyLineMap
, testSimpleLineMap
, testLineDelimiters
@ -24,9 +27,9 @@ tests = testGroup "source"
testEmptyLineMap :: TestTree
testEmptyLineMap = testCase "empty" $ do
let source = PS.makeSource "<test>" ""
assertBool "An empty source generates an empty line map." $
null (PS.lineOffsets $ PS.sourceLineMap source)
let source = PS.makeSource "<test>" ""
assertBool "An empty source generates an empty line map."
$ null (PS.lineOffsets $ PS.sourceLineMap source)
testSimpleLineMap :: TestTree
testSimpleLineMap = testCase "simple" $ do
@ -34,14 +37,14 @@ testSimpleLineMap = testCase "simple" $ do
[ "This source file contains a few lines."
, "Some, line the next, are empty."
, ""
, "Multiple consecutive empty lines are fine as well."
, "Multiple consecutive empty lines are fine as well."
, ""
, ""
, "終わり"
]
source = PS.makeSource "<test>" $ T.unlines sourceLines
toList (PS.lineOffsets $ PS.sourceLineMap source) @?=
fmap PS.Offset [39, 71, 72, 123, 124, 125, 129]
toList (PS.lineOffsets $ PS.sourceLineMap source)
@?= fmap PS.Offset [39, 71, 72, 123, 124, 125, 129]
for_ (zip [PS.Line 0 ..] sourceLines) $ \(lineNumber, line) ->
PS.getSourceLine lineNumber source @?= Just (line <> "\n")
@ -50,13 +53,13 @@ testLineDelimiters = testCase "endings" $ do
let source = PS.makeSource "<test>" "abc\ndef\rghi\r\njkl"
lines = PS.sourceLineMap source
PS.getSourceLine (PS.Line 0) source @?= Just "abc\n"
PS.lineToOffset (PS.Line 0) lines @?= Just (PS.Offset 0)
PS.lineToOffset (PS.Line 0) lines @?= Just (PS.Offset 0)
PS.getSourceLine (PS.Line 1) source @?= Just "def\r"
PS.lineToOffset (PS.Line 1) lines @?= Just (PS.Offset 4)
PS.lineToOffset (PS.Line 1) lines @?= Just (PS.Offset 4)
PS.getSourceLine (PS.Line 2) source @?= Just "ghi\r\n"
PS.lineToOffset (PS.Line 2) lines @?= Just (PS.Offset 8)
PS.lineToOffset (PS.Line 2) lines @?= Just (PS.Offset 8)
PS.getSourceLine (PS.Line 3) source @?= Just "jkl"
PS.lineToOffset (PS.Line 3) lines @?= Just (PS.Offset 13)
PS.lineToOffset (PS.Line 3) lines @?= Just (PS.Offset 13)
PS.getSourceLine (PS.Line 4) source @?= Nothing
testLocation :: TestTree
@ -82,39 +85,38 @@ testLocationLazy = testCase "lazy" $ do
let source = PS.makeSource "<test>" "abc\ndef"
Just loc = PS.getLocation (PS.Offset 5) source
(line, checkLine) <- checkEvaluated (PS.locationLine loc)
(col, checkCol) <- checkEvaluated (PS.locationColumn loc)
(col , checkCol ) <- checkEvaluated (PS.locationColumn loc)
assertBool "line is unevaluated" . not =<< checkLine
assertBool "col is unevaluated" . not =<< checkCol
assertBool "col is unevaluated" . not =<< checkCol
_ <- evaluate line
assertBool "line is evaluated" =<< checkLine
assertBool "col is unevaluated" . not =<< checkCol
assertBool "line is evaluated" =<< checkLine
assertBool "col is unevaluated" . not =<< checkCol
_ <- evaluate col
assertBool "line is evaluated" =<< checkLine
assertBool "col is evaluated" =<< checkCol
assertBool "col is evaluated" =<< checkCol
propLineOffset :: TestTree
propLineOffset = testProperty "line-and-offset" $
forAll gen $ \(source, initialOffset) ->
propLineOffset =
testProperty "line-and-offset" $ forAll gen $ \(source, initialOffset) ->
let lineMap = PS.sourceLineMap source
line = PS.offsetToLine initialOffset lineMap
Just offset = PS.lineToOffset line lineMap
line' = PS.offsetToLine offset lineMap
in (initialOffset >= offset) .&&. (line === line')
in (initialOffset >= offset) .&&. (line === line')
where
gen = do
text <- T.pack <$> genChar
initialOffset <- elements [PS.Offset 0 .. toEnum (if T.null text then 0 else T.length text - 1)]
initialOffset <-
elements
[PS.Offset 0 .. toEnum
(if T.null text then 0 else T.length text - 1)]
pure (PS.makeSource "<text>" text, initialOffset)
genChar = listOf $ frequency
[ (10, elements ['a' .. 'z'] )
, (4, pure ' ')
, (1, pure '\n')
]
genChar =
listOf $ frequency
[(10, elements ['a' .. 'z']), (4, pure ' '), (1, pure '\n')]
{-# NOINLINE checkEvaluated #-}
checkEvaluated :: a -> IO (a, IO Bool)
checkEvaluated val = do
ref <- newIORef False
pure ( unsafePerformIO (writeIORef ref True) `seq` val
, readIORef ref
)
pure (unsafePerformIO (writeIORef ref True) `seq` val, readIORef ref)

64
test/Prosidy/Test/Types.hs

@ -1,30 +1,29 @@
{-# LANGUAGE OverloadedStrings #-}
module Prosidy.Test.Types (tests) where
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
import qualified Prosidy.Types.Key as Key
import qualified Prosidy.Types.Series as Series
import qualified Data.Text as Text
import qualified Data.Sequence as Seq
import qualified Prosidy.Types.Key as Key
import qualified Prosidy.Types.Series as Series
import qualified Data.Text as Text
import qualified Data.Sequence as Seq
tests :: TestTree
tests = testGroup "types"
[ testKey
, testSeriesNE
]
tests = testGroup "types" [testKey, testSeriesNE]
testKey :: TestTree
testKey = testGroup "key"
testKey = testGroup
"key"
[ testProperty "valid" $ forAll validGen $ \raw ->
fmap Key.rawKey (Key.makeKey raw) === Right raw
, testProperty "invalid-head" $ forAll invalidHeadGen $ \raw ->
case Key.makeKey raw of
Right _ -> label "key creation should fail" False
Left Key.EmptyKeyError -> label "key should be nonempty" $ property False
Left (Key.InvalidCharacterError (Key.InvalidCharacter raw' nth ch)) ->
conjoin
Left Key.EmptyKeyError ->
label "key should be nonempty" $ property False
Left (Key.InvalidCharacterError (Key.InvalidCharacter raw' nth ch))
-> conjoin
[ label "error string matches input" $ raw === raw'
, label "invalid at index 0" $ nth === 0
, label "char is invalid" $ not (Key.isValidKeyHead ch)
@ -32,22 +31,23 @@ testKey = testGroup "key"
, testProperty "invalid-tail" $ forAll invalidTailGen $ \raw ->
case Key.makeKey raw of
Right _ -> label "key creation should fail" False
Left Key.EmptyKeyError -> label "key should be nonempty" $ property False
Left (Key.InvalidCharacterError (Key.InvalidCharacter raw' nth ch)) ->
conjoin
Left Key.EmptyKeyError ->
label "key should be nonempty" $ property False
Left (Key.InvalidCharacterError (Key.InvalidCharacter raw' nth ch))
-> conjoin
[ label "error string matches input" $ raw === raw'
, label "invalid at index > 0" $ nth =/= 0
, label "char is invalid" $ not (Key.isValidKeyTail ch)
]
, testProperty "empty" $
case Key.makeKey "" of
Right _ -> label "key creation should fail" False
Left Key.EmptyKeyError -> property ()
Left (Key.InvalidCharacterError _) -> label "input should be empty" False
, testProperty "empty" $ case Key.makeKey "" of
Right _ -> label "key creation should fail" False
Left Key.EmptyKeyError -> property ()
Left (Key.InvalidCharacterError _) ->
label "input should be empty" False
]
where
arbHead = arbitraryUnicodeChar `suchThat` Key.isValidKeyHead
arbTail = listOf $ arbitraryUnicodeChar `suchThat` Key.isValidKeyTail
arbHead = arbitraryUnicodeChar `suchThat` Key.isValidKeyHead
arbTail = listOf $ arbitraryUnicodeChar `suchThat` Key.isValidKeyTail
validGen = do
keyHead <- arbHead
@ -67,12 +67,12 @@ testKey = testGroup "key"
pure . Text.pack $ keyHead : keyTail0 ++ keyTail1 : keyTail2
testSeriesNE :: TestTree
testSeriesNE = testGroup "SeriesNE"
[ testProperty "nonempty" $
forAll genSeq1 $ \xs ->
fmap Series.toSeqNE (Series.fromSeqNE xs) === Just xs
, testProperty "empty" $
Series.fromSeqNE (mempty :: Seq.Seq Word) === Nothing
testSeriesNE = testGroup
"SeriesNE"
[ testProperty "nonempty" $ forAll genSeq1 $ \xs ->
fmap Series.toSeqNE (Series.fromSeqNE xs) === Just xs
, testProperty "empty"
$ Series.fromSeqNE (mempty :: Seq.Seq Word)
=== Nothing
]
where
genSeq1 = fmap Seq.fromList . listOf1 $ (arbitrary :: Gen Word)
where genSeq1 = fmap Seq.fromList . listOf1 $ (arbitrary :: Gen Word)
Loading…
Cancel
Save