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
1 year ago · 38b32e7845
11 changed files with 192 additions and 142 deletions
--- a/prosidy.cabal
+++ b/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
--- a/scripts/format
+++ b/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
--- a/src/Prosidy/Compat.hs
+++ b/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
--- a/src/Prosidy/Optics/Internal.hs
+++ b/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
--- a/src/Prosidy/Parse.hs
+++ b/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
--- a/src/Prosidy/Types/Series.hs
+++ b/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
--- a/test/Paths_prosidy.hs
+++ b/test/Paths_prosidy.hs
@ -1,4 +1,4 @@
 module Paths_prosidy where

 getDataDir :: IO FilePath
-getDataDir = pure "data"
+getDataDir = pure "data"
--- a/test/Prosidy/Test.hs
+++ b/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]
--- a/test/Prosidy/Test/Parse.hs
+++ b/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
--- a/test/Prosidy/Test/Source.hs
+++ b/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)
--- a/test/Prosidy/Test/Types.hs
+++ b/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)