diff --git a/Cabal-layout/Cabal-layout.cabal b/Cabal-layout/Cabal-layout.cabal new file mode 100644 index 00000000000..d641faafab2 --- /dev/null +++ b/Cabal-layout/Cabal-layout.cabal @@ -0,0 +1,137 @@ +cabal-version: 2.2 +name: Cabal-layout +version: 3.11.0.0 +copyright: 2003-2023, Cabal Development Team (see AUTHORS file) +license: BSD-3-Clause +license-file: LICENSE +author: Cabal Development Team +maintainer: cabal-devel@haskell.org +homepage: http://www.haskell.org/cabal/ +bug-reports: https://github.com/haskell/cabal/issues +synopsis: Cabal format manipulation +description: + Cabal format manipulation. + +category: Distribution +build-type: Simple + +extra-source-files: + README.md ChangeLog.md + + +source-repository head + type: git + location: https://github.com/haskell/cabal/ + subdir: Cabal-layout + + +library + default-language: Haskell2010 + + hs-source-dirs: src + + build-depends: + base >= 4.9 && < 5 + , bytestring + , parsec + , text + + ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances + + if impl(ghc >= 8.0) && impl(ghc < 8.8) + ghc-options: -Wnoncanonical-monadfail-instances + + exposed-modules: + Codec.Manifest.Cabal.Layout + + exposed-modules: + Codec.Manifest.Cabal.Internal.Layout + Codec.Manifest.Cabal.Internal.Parse + Codec.Manifest.Cabal.Internal.Render + + + +test-suite sanity + type: exitcode-stdio-1.0 + + main-is: Main.hs + + default-language: Haskell2010 + + hs-source-dirs: src + , test/sanity + + build-depends: + base >= 4.9 && < 5 + , bytestring + , parsec + , tasty + , tasty-hunit + , text + + ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances + + if impl(ghc >= 8.0) && impl(ghc < 8.8) + ghc-options: -Wnoncanonical-monadfail-instances + + + +test-suite hackage + type: exitcode-stdio-1.0 + + main-is: Main.hs + + default-language: Haskell2010 + + hs-source-dirs: src + , test/hackage + , test/strictness + + build-depends: + base >= 4.9 && < 5 + , bytestring + , directory + , filepath + , nothunks + , parsec + , text + + ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances + + if impl(ghc >= 8.0) && impl(ghc < 8.8) + ghc-options: -Wnoncanonical-monadfail-instances + + + +test-suite patches + type: exitcode-stdio-1.0 + + main-is: Main.hs + + default-language: Haskell2010 + + hs-source-dirs: src + , test/patches + + build-depends: + base >= 4.9 && < 5 + , bytestring + , parsec + , process + + ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances + + if impl(ghc >= 8.0) && impl(ghc < 8.8) + ghc-options: -Wnoncanonical-monadfail-instances diff --git a/Cabal-layout/src/Codec/Manifest/Cabal/Internal/Layout.hs b/Cabal-layout/src/Codec/Manifest/Cabal/Internal/Layout.hs new file mode 100644 index 00000000000..4e0069ec742 --- /dev/null +++ b/Cabal-layout/src/Codec/Manifest/Cabal/Internal/Layout.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE DerivingStrategies + , GeneralizedNewtypeDeriving + , QuantifiedConstraints + , StandaloneDeriving + , UndecidableInstances #-} + +module Codec.Manifest.Cabal.Internal.Layout where + +import Data.Text (Text) + + + +-- | Context-dependent whitespace. +newtype Offset = Offset Int + deriving newtype Show + +-- | Context-independent whitespace. +newtype Whitespace = Whitespace Int + deriving newtype Show + +-- | Anything that follows two consecutive hyphens. Lasts until the end of the line. +data Comment = Comment + Whitespace -- ^ Before double hyphens + Whitespace -- ^ Between double hyphens and text + Text + Whitespace -- ^ Between end of comment and end of line + deriving Show + + + +-- | Any Unicode characters, excluding '\x00'..'\x1F' +-- ('\r' and '\t' are allowed), '\DEL', '{', '}', ':'. +newtype Heading = Heading Text + deriving newtype Show + +-- | Any Unicode characters, excluding '\x00'..'\x1F', '\DEL', '{', '}', ':' and spaces. +newtype Name = Name Text + deriving newtype Show + + + + +-- | Field contents at the declaration line. +data Inline = Inline + Whitespace -- ^ Between colon and start of text + Text + Whitespace -- ^ Between end of text and end of line + + | EmptyI Whitespace + + deriving Show + +-- | Field contents at the lines following the declaration. +data Line = Line + Offset + Text + Whitespace -- ^ Between end of text and end of line + + | CommentL Comment + + | EmptyL Whitespace + + deriving Show + + + +-- | Non-meaningful information. +data Filler = CommentF Comment + | EmptyF Whitespace + deriving Show + + + +-- | Section contents with the curly bracket alternative. +data Section = CurlS + [Filler] -- ^ Between heading and left curly + [Node] + + | NormalS + Filler -- ^ Inline comment + [Node] + deriving Show + + + +-- | Field contents. +data Contents = Contents Inline [Line] + deriving Show + +-- | Field contents with the curly bracket alternative. +data Field = CurlF + [Filler] -- ^ Between colon and left curly + Contents + + | NormalF Contents + deriving Show + + + +data Node = Section + Offset + Heading + Section + + | Field + Offset + Name + Whitespace -- ^ Between field name and colon + Field + + | CommentN Comment + + | EmptyN Whitespace + + deriving Show + + + +newtype Layout = Layout [Node] + deriving newtype Show diff --git a/Cabal-layout/src/Codec/Manifest/Cabal/Internal/Parse.hs b/Cabal-layout/src/Codec/Manifest/Cabal/Internal/Parse.hs new file mode 100644 index 00000000000..cd3e44de12b --- /dev/null +++ b/Cabal-layout/src/Codec/Manifest/Cabal/Internal/Parse.hs @@ -0,0 +1,774 @@ +{-# LANGUAGE BangPatterns + , OverloadedStrings + , RankNTypes #-} + +module Codec.Manifest.Cabal.Internal.Parse + ( layoutP + ) where + +import Codec.Manifest.Cabal.Internal.Layout + +import Control.Monad +import qualified Data.ByteString.Lazy as BSL +import Data.ByteString.Builder +import Data.Char (isSpace) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding +import qualified Data.Text.Internal.StrictBuilder as StrictBuilder +import Text.Parsec hiding (Line) +import Text.Parsec.Text.Lazy + + + +isControlC0 :: Char -> Bool +isControlC0 c = (c <= '\x1F' && c /= '\t' && c /= '\r') || c == '\DEL' + + + +data Curliness = Normal | Curled + +commentP :: Parser (Whitespace -> Comment) +commentP = do + space1_ <- many $ satisfy (\c -> c /= '\n' && isSpace c) + let !space1 = length space1_ + + (len, space2) <- lookAhead $ forecast 0 0 + txt_ <- count len anyChar + let !txt = Text.pack txt_ + + _ <- count space2 anyChar + + pure $ \space0 -> Comment space0 (Whitespace space1) txt (Whitespace space2) + where + forecast :: Int -> Int -> Parser (Int, Int) + forecast !n !m = do + mayc <- optionMaybe anyChar + case mayc of + Just c + | c == '\n' -> pure (n, m) + | isSpace c -> forecast n (m + 1) + | isControlC0 c -> fail "C0 control codes and '\\DEL' are not allowed" + | otherwise -> forecast (n + m + 1) 0 + + Nothing -> pure (n, m) + +uncomment :: Filler -> Inline +uncomment filler = + case filler of + CommentF (Comment space0 (Whitespace space1) comment space2) -> + let !txt = StrictBuilder.toText . StrictBuilder.unsafeFromByteString + . BSL.toStrict . toLazyByteString + $ string8 "--" + <> foldMap id (replicate space1 $ char8 ' ') + <> byteString (encodeUtf8 comment) + + in Inline space0 txt space2 + + EmptyF space_ -> EmptyI space_ + + + +rightCurlyP :: SourcePos -> Parser () +rightCurlyP curlyPos = do + let sourcePosS pos = showString "line " . shows (sourceLine pos) + . showString ", column " . shows (sourceColumn pos) + + mayc <- optionMaybe $ lookAhead anyChar + case mayc of + Just c + | c == '}' -> void anyChar + + | otherwise -> + fail $ + showString "Curly section started on " . sourcePosS curlyPos + $ showString + " was not consumed correctly. This is not supposed to\ + \ happen, please report it as a Cabal bug." [] + + Nothing -> + fail $ + showString "Reached end of file without finding a closing bracket\ + \ for curly section started on " $ sourcePosS curlyPos [] + + + +data Lined = Newline + | Trailing + deriving Show + +data Stop = LineEnd Lined + | MidLine Whitespace + deriving Show + +data Next = NextLine Whitespace + | NextComment Comment Lined + | NextEmpty Whitespace Lined + | NextFin + deriving Show + +nextP :: Curliness -> (Next -> Parser a) -> Parser a +nextP curliness f = go 0 + where + go !n = do + mayc <- optionMaybe $ lookAhead anyChar + case mayc of + Just c + | c == '\n' -> do + _ <- anyChar + f $ NextEmpty (Whitespace n) Newline + + | isSpace c -> do + _ <- anyChar + go (n + 1) + + | c == '-' -> do + mayd <- lookAhead $ do + _ <- anyChar + optionMaybe anyChar + + case mayd of + Just '-' -> do + _ <- anyChar + _ <- anyChar + comment_ <- commentP + let !comment = comment_ (Whitespace n) + + maye <- optionMaybe $ lookAhead anyChar + lined <- case maye of + Just '\n' -> do _ <- anyChar + pure Newline + + _ -> pure Trailing + + f $ NextComment comment lined + + _ -> f $ NextLine (Whitespace n) + + | c == '}' -> + f $ case curliness of + Curled + | n <= 0 -> NextFin + | otherwise -> NextEmpty (Whitespace n) Trailing + + _ -> NextLine (Whitespace n) + + | otherwise -> f $ NextLine (Whitespace n) + + Nothing -> + f $ if n > 0 + then NextEmpty (Whitespace n) Trailing + else NextFin + + + +data Anchor = Bottom + | Anchor Int + +data Belonging = Belongs Offset + | Above + +relative :: Anchor -> Whitespace -> Belonging +relative anchor (Whitespace space_) = + case anchor of + Bottom -> Belongs (Offset space_) + Anchor pivot -> let off = space_ - pivot + in if off > 0 + then Belongs (Offset off) + else Above + + + +-- | Comments and newlines whose position within the layout has not yet been figured out. +data Overflow = NoOverflow + | Overflow + (forall a. (Whitespace -> a) -> (Comment -> a) -> [a] -> [a]) + +instance Show Overflow where + showsPrec d flow = + case flow of + NoOverflow -> showString "NoOverflow" + Overflow _ -> showParen (d > 10) $ showString "Overflow _" + +flowComment :: Comment -> Overflow -> Overflow +flowComment comment flow = + case flow of + NoOverflow -> Overflow $ \_ comm -> (:) (comm comment) + Overflow f -> Overflow $ \new comm -> f new comm . (:) (comm comment) + +flowEmpty :: Whitespace -> Overflow -> Overflow +flowEmpty space_ flow = + case flow of + NoOverflow -> Overflow $ \new _ -> (:) (new space_) + Overflow f -> Overflow $ \new comm -> f new comm . (:) (new space_) + +runOverflow :: (Whitespace -> a) -> (Comment -> a) -> Overflow -> [a] -> [a] +runOverflow new comm flow = + case flow of + NoOverflow -> id + Overflow f -> f new comm + +nodeOverflow :: Overflow -> [Node] -> [Node] +nodeOverflow = runOverflow EmptyN CommentN + +lineOverflow :: Overflow -> [Line] -> [Line] +lineOverflow = runOverflow EmptyL CommentL + +fillerOverflow :: Overflow -> [Filler] -> [Filler] +fillerOverflow = runOverflow EmptyF CommentF + + + +data Result = Proper Node Overflow Stop + | Fin (Maybe Whitespace) + deriving Show + +data NodeLine = JustSection + Int -- ^ Length of the section name + Int -- ^ Whitespace between the name and line end + + | CurlySection + Int -- ^ Length of the section name + Int -- ^ Whitespace between the name and left curly brace + + | CommentSection + Int -- ^ Length of the section name + Int -- ^ Whitespace between the name and the comment start + + | JustField + Int -- ^ Length of the field name + Int -- ^ Whitespace between the name and the colon + + deriving Show + +layoutP :: Parser Layout +layoutP = do + (acc, flow, stop) <- nodesP Normal Bottom (LineEnd Trailing) + + atEnd <- option False $ True <$ eof + unless atEnd $ + fail "Input was not consumed in its entirety. This is not supposed to\ + \ happen, please report it as a Cabal bug." + + let base = case stop of + LineEnd Newline -> [EmptyN (Whitespace 0)] + LineEnd Trailing -> [] + MidLine _ -> [] + + pure . Layout . acc $ nodeOverflow flow base + + +nodesP :: Curliness -> Anchor -> Stop -> Parser ([Node] -> [Node], Overflow, Stop) +nodesP curliness anchor = go id NoOverflow + where + go acc flow stop = do + result <- case stop of + LineEnd _ -> nodeP curliness anchor + MidLine lines_ -> spaceNodeP curliness anchor lines_ + + case result of + Proper node flow' stop' -> + let acc' xs = acc $ nodeOverflow flow (node : xs) + in case node of + Section _ _ _ -> go acc' flow' stop' + Field _ _ _ _ -> go acc' flow' stop' + + CommentN comment -> go acc (flowComment comment flow) stop' + EmptyN space_ -> go acc (flowEmpty space_ flow) stop' + + Fin mayOff -> + pure + ( acc + , flow + , case mayOff of + Just space' -> MidLine space' + Nothing -> stop + ) + + + +nodeP :: Curliness -> Anchor -> Parser Result +nodeP curliness anchor = + nextP curliness $ \next -> do + case next of + NextLine space_ -> + spaceNodeP curliness anchor space_ + + NextComment comment lines_ -> + pure $ Proper (CommentN comment) NoOverflow (LineEnd lines_) + + NextEmpty space_ lines_ -> + pure $ Proper (EmptyN space_) NoOverflow (LineEnd lines_) + + NextFin -> pure $ Fin Nothing + + + +spaceNodeP :: Curliness -> Anchor -> Whitespace -> Parser Result +spaceNodeP curliness anchor (Whitespace space_) = do + case relative anchor (Whitespace space_) of + Above -> pure $ Fin (Just (Whitespace space_)) + Belongs off -> do + mayc <- optionMaybe $ lookAhead anyChar + case mayc of + Just ':' -> fail "Colon" + Just '{' -> fail "Curly bracket" + _ -> pure () + + future <- lookAhead $ firstWordP 0 + case future of + JustSection len space' -> do + heading_ <- count len anyChar + let !heading = Text.pack heading_ + + _ <- count space' anyChar + mc <- optionMaybe $ lookAhead anyChar + lined <- case mc of + Just '\n' -> do void anyChar + pure Newline + _ -> pure Trailing + + (section, flow', stop) <- + ambiguousSectionP curliness (Anchor space_) (EmptyF (Whitespace space')) lined + + pure $ + Proper + (Section off (Heading heading) section) + flow' + stop + + CurlySection len space' -> do + heading_ <- count len anyChar + let !heading = Text.pack heading_ + + _ <- count space' anyChar + + curlyPos <- getPosition + _ <- anyChar -- '{' + + (acc, flow', stop) <- nodesP Curled Bottom (LineEnd Trailing) + + rightCurlyP curlyPos + + let base = case stop of + LineEnd Newline -> [EmptyN (Whitespace 0)] + LineEnd Trailing -> [] + MidLine _ -> [] + + pure $ + Proper + (Section off (Heading heading) $ CurlS [EmptyF (Whitespace space')] (acc $ nodeOverflow flow' base)) + NoOverflow + (LineEnd Trailing) + + CommentSection len space' -> do + heading_ <- count len anyChar + let !heading = Text.pack heading_ + + _ <- count space' anyChar + _ <- anyChar -- '-' + _ <- anyChar -- '-' + comment <- commentP + + mc <- optionMaybe $ lookAhead anyChar + lined <- case mc of + Just '\n' -> do void anyChar + pure Newline + _ -> pure Trailing + + (section, flow', stop) <- + ambiguousSectionP curliness (Anchor space_) (CommentF $ comment (Whitespace space')) lined + + pure $ + Proper + (Section off (Heading heading) section) + flow' + stop + + JustField len space' -> do + let !_ = off + + name_ <- count len anyChar + let !name = Text.pack name_ + + _ <- count space' anyChar + _ <- anyChar -- ':' + + (field, flow', stop) <- fieldP curliness (Anchor space_) + + pure $ + Proper + (Field off (Name name) (Whitespace space') field) + flow' + stop + + where + firstWordP :: Int -> Parser NodeLine + firstWordP !n = do + mayc <- optionMaybe $ lookAhead anyChar + case mayc of + Just c + | c == '\n' -> pure $ JustSection n 0 + + | isSpace c -> do + _ <- anyChar + firstSpaceP n 1 + + | c == '-' -> do + mayd <- lookAhead $ do + _ <- anyChar + optionMaybe anyChar + + case mayd of + Just '-' -> pure $ CommentSection n 0 + Just _ -> do + _ <- anyChar + firstWordP (n + 1) + + Nothing -> pure $ JustSection n 0 + + | c == ':' -> pure $ JustField n 0 + | c == '{' -> pure $ CurlySection n 0 + | c == '}' -> + case curliness of + Curled -> pure $ JustSection n 0 + Normal -> fail "Closing curly bracket found, but no opening one" + + | isControlC0 c -> + fail "C0 control codes and '\\DEL' are not allowed" + + | otherwise -> do + _ <- anyChar + firstWordP (n + 1) + + Nothing -> pure $ JustSection n 0 + + firstSpaceP :: Int -> Int -> Parser NodeLine + firstSpaceP n !m = do + mayc <- optionMaybe $ lookAhead anyChar + case mayc of + Just c + | c == '\n' -> pure $ JustSection n m + + | isSpace c -> do + _ <- anyChar + firstSpaceP n (m + 1) + + | c == '-' -> do + mayd <- lookAhead $ do + _ <- anyChar + optionMaybe anyChar + + case mayd of + Just '-' -> pure $ CommentSection n m + Just _ -> do + _ <- anyChar + moreWordsP (n + m + 1) 0 + + Nothing -> pure $ JustSection n m + + | c == ':' -> pure $ JustField n m + | c == '{' -> pure $ CurlySection n m + | c == '}' -> + case curliness of + Curled -> pure $ JustSection n m + Normal -> fail "Closing curly bracket found, but no opening one" + + | isControlC0 c -> + fail "C0 control codes and '\\DEL' are not allowed" + + | otherwise -> do + _ <- anyChar + moreWordsP (n + m + 1) 0 + + Nothing -> pure $ JustSection n m + + moreWordsP :: Int -> Int -> Parser NodeLine + moreWordsP !n !m = do + mayc <- optionMaybe $ lookAhead anyChar + case mayc of + Just c + | c == '\n' -> pure $ JustSection n m + + | isSpace c -> do + _ <- anyChar + moreWordsP n (m + 1) + + | c == '-' -> do + mayd <- lookAhead $ do + _ <- anyChar + optionMaybe anyChar + + case mayd of + Just '-' -> pure $ CommentSection n m + Just _ -> do + _ <- anyChar + moreWordsP (n + m + 1) 0 + + Nothing -> pure $ JustSection n m + + | c == '{' -> pure $ CurlySection n m + | c == '}' -> + case curliness of + Curled -> pure $ JustSection n m + Normal -> fail "Closing curly bracket found, but no opening one" + + | c == ':' -> + fail "Spaces in field names are not allowed" + + | isControlC0 c -> + fail "C0 control codes and '\\DEL' are not allowed" + + | otherwise -> do + _ <- anyChar + moreWordsP (n + m + 1) 0 + + Nothing -> pure $ JustSection n 0 + + + +ambiguousSectionP + :: Curliness + -> Anchor + -> Filler + -> Lined + -> Parser (Section, Overflow, Stop) +ambiguousSectionP curliness anchor inline = go NoOverflow + where + go flow lined = + nextP curliness $ \next -> + case next of + NextLine space_ -> do + c <- lookAhead anyChar + case c of + '{' -> do + curlyPos <- getPosition + _ <- anyChar + + (acc, flow', stop) <- nodesP Curled Bottom (LineEnd Trailing) + rightCurlyP curlyPos + + let lines_ = inline : fillerOverflow flow [EmptyF space_] + + base = case stop of + LineEnd Newline -> [EmptyN (Whitespace 0)] + LineEnd Trailing -> [] + MidLine _ -> [] + + pure + ( CurlS lines_ (acc $ nodeOverflow flow' base) + , NoOverflow + , LineEnd Trailing + ) + + _ -> + case relative anchor space_ of + Belongs _ -> do + (acc, flow', stop) <- nodesP curliness anchor (MidLine space_) + + let nodes = nodeOverflow flow $ acc [] + + pure (NormalS inline nodes, flow', stop) + + Above -> pure (NormalS inline [], flow, MidLine space_) + + NextComment comment lined' -> go (flowComment comment flow) lined' + + NextEmpty space1 lined' -> go (flowEmpty space1 flow) lined' + + NextFin -> + pure + ( NormalS inline [] + , flow + , LineEnd lined + ) + + + +lineP :: Curliness -> Parser (Text, Whitespace, Lined) +lineP curliness = do + (len, space2, lined) <- lookAhead $ forecast 0 0 + txt_ <- count len anyChar + let !txt = Text.pack txt_ + + _ <- count space2 anyChar + + case lined of + Newline -> do _ <- anyChar + pure () + Trailing -> pure () + + pure (txt, Whitespace space2, lined) + where + forecast :: Int -> Int -> Parser (Int, Int, Lined) + forecast !n !m = do + mayc <- optionMaybe anyChar + case mayc of + Just c + | c == '\n' -> do pure (n, m, Newline) + | c == '}' + , Curled <- curliness -> pure (n, m, Trailing) + + | isSpace c -> forecast n (m + 1) + | isControlC0 c -> fail "C0 control codes and '\\DEL' are not allowed" + | otherwise -> forecast (n + m + 1) 0 + + Nothing -> pure (n, m, Trailing) + + + +fieldP :: Curliness -> Anchor -> Parser (Field, Overflow, Stop) +fieldP curliness0 anchor0 = + nextP curliness0 $ \next -> + case next of + NextLine space_ -> do + c <- lookAhead anyChar + case c of + '{' -> do + curlyPos <- getPosition + _ <- anyChar + contents <- curledInlineP + rightCurlyP curlyPos + pure + ( CurlF [EmptyF space_] contents + , NoOverflow + , LineEnd Trailing + ) + + _ -> do + (txt, space', lined) <- lineP curliness0 + normalP curliness0 anchor0 (Inline space_ txt space') id NoOverflow lined + + NextComment comment lined -> + ambiguousP curliness0 anchor0 (CommentF comment) NoOverflow lined + + NextEmpty space1 lined -> + ambiguousP curliness0 anchor0 (EmptyF space1) NoOverflow lined + + NextFin -> + pure + ( NormalF (Contents (EmptyI (Whitespace 0)) []) + , NoOverflow + , LineEnd Trailing + ) + + where + ambiguousP curliness anchor inline flow lined0 = + nextP curliness $ \next -> + case next of + NextLine space_ -> do + c <- lookAhead anyChar + case c of + '{' -> do + curlyPos <- getPosition + _ <- anyChar + contents <- curledInlineP + let lines_ = inline : fillerOverflow flow [EmptyF space_] + + rightCurlyP curlyPos + pure + ( CurlF lines_ contents + , NoOverflow + , LineEnd Trailing + ) + + _ -> + let !inline' = uncomment inline + in case relative anchor space_ of + Belongs off -> do + (txt, space', lined1) <- lineP curliness + + normalP curliness anchor inline' + (lineOverflow flow . (:) (Line off txt space')) + NoOverflow + lined1 + + Above -> + pure + ( NormalF (Contents inline' []) + , flow + , MidLine space_ + ) + + NextComment comment lined1 -> + ambiguousP curliness anchor inline (flowComment comment flow) lined1 + + NextEmpty space1 lined1 -> + ambiguousP curliness anchor inline (flowEmpty space1 flow) lined1 + + NextFin -> + let !inline' = uncomment inline + in pure + ( NormalF (Contents inline' []) + , flow + , LineEnd lined0 + ) + + + curledInlineP = + nextP Curled $ \next -> + case next of + NextLine (Whitespace space_) -> do + (txt, space', lined) <- lineP Curled + let !inline = Inline (Whitespace space_) txt space' + curledP inline id lined + + NextComment comment lined -> + let !inline = uncomment (CommentF comment) + in curledP inline id lined + + NextEmpty space_ lined -> + curledP (EmptyI space_) id lined + + NextFin -> pure $ Contents (EmptyI (Whitespace 0)) [] + + curledP inline acc lined = + nextP Curled $ \next -> + case next of + NextLine (Whitespace space_) -> do + (txt, space', lined') <- lineP Curled + curledP inline (acc . (:) (Line (Offset space_) txt space')) lined' + + NextComment comment lined' -> + curledP inline (acc . (:) (CommentL comment)) lined' + + NextEmpty space_ lined' -> + curledP inline (acc . (:) (EmptyL space_)) lined' + + NextFin -> + let base = case lined of + Newline -> [EmptyL (Whitespace 0)] + Trailing -> [] + + in pure $ Contents inline (acc base) + + + normalP curliness anchor inline acc flow lined = + nextP curliness $ \next -> + case next of + NextLine space_ -> + case relative anchor space_ of + Belongs off -> do + (txt, space', lined') <- lineP curliness + + normalP curliness anchor inline + (acc . lineOverflow flow . (:) (Line off txt space')) + NoOverflow + lined' + + Above -> do + let !nodes = acc [] + pure + ( NormalF (Contents inline nodes) + , flow + , MidLine space_ + ) + + NextComment comment lined' -> + normalP curliness anchor inline acc (flowComment comment flow) lined' + + NextEmpty space_ lined' -> + normalP curliness anchor inline acc (flowEmpty space_ flow) lined' + + NextFin -> + pure (NormalF (Contents inline (acc [])), flow, LineEnd lined) diff --git a/Cabal-layout/src/Codec/Manifest/Cabal/Internal/Render.hs b/Cabal-layout/src/Codec/Manifest/Cabal/Internal/Render.hs new file mode 100644 index 00000000000..701a81c7810 --- /dev/null +++ b/Cabal-layout/src/Codec/Manifest/Cabal/Internal/Render.hs @@ -0,0 +1,176 @@ +module Codec.Manifest.Cabal.Internal.Render + ( layoutB + ) where + +import Codec.Manifest.Cabal.Internal.Layout + +import Data.ByteString.Builder +import qualified Data.ByteString.Builder.Prim as Prim +import Data.Text.Encoding + + + +data Anchor = Bottom + | Anchor Int + deriving Show + +mintercalate :: Monoid m => m -> [m] -> m +mintercalate x ys = + let go a bs = + case bs of + b:cs -> a <> x <> go b cs + [] -> a + + in case ys of + a:bs -> go a bs + [] -> mempty + + + +offset :: Offset -> Anchor -> Anchor +offset (Offset n) anchor = + case anchor of + Bottom | n > 0 -> Anchor n + | otherwise -> Bottom + Anchor m -> Anchor (m + n) + +anchorB :: Anchor -> Builder +anchorB anchor = + case anchor of + Bottom -> mempty + Anchor n -> spaceB (Whitespace $ max n 1) + + + +spaceB :: Whitespace -> Builder +spaceB (Whitespace n) = + Prim.primMapListBounded (Prim.liftFixedToBounded Prim.char8) (replicate n ' ') + +commentB :: Comment -> Builder +commentB (Comment space0 space1 comment space2) = + spaceB space0 <> string8 "--" <> spaceB space1 <> byteString (encodeUtf8 comment) + <> spaceB space2 + + + +fillerB :: Filler -> Builder +fillerB filler = + case filler of + CommentF comment -> commentB comment + EmptyF space -> spaceB space + +lineB :: Anchor -> Line -> Builder +lineB anchor l = + case l of + Line off txt space -> anchorB (offset off anchor) <> byteString (encodeUtf8 txt) + <> spaceB space + CommentL comment -> commentB comment + EmptyL space -> spaceB space + + + +contentsB :: Anchor -> Contents -> Builder +contentsB anchor (Contents inline lines_) = + let fit inl = + case inl of + Inline (Whitespace space0) txt space1 -> Line (Offset space0) txt space1 + EmptyI space -> EmptyL space + + in mintercalate (char8 '\n') $ + lineB Bottom (fit inline) : (fmap (lineB anchor) lines_) + + + +data Trail = Contextual + | Trailing + +sectionB :: Anchor -> Trail -> Section -> (Builder, Trail) +sectionB anchor trail section = + case section of + CurlS fillers nodes -> + ( mintercalate (char8 '\n') (fmap fillerB fillers) + <> char8 '{' + <> fst (nodesB Bottom Contextual nodes) + <> char8 '}' + , Trailing + ) + + NormalS filler nodes -> + case nodes of + [] -> (fillerB filler, trail) + _ -> let ~(rendered, trail') = nodesB anchor trail nodes + in ( fillerB filler + <> char8 '\n' + <> rendered + , trail' + ) + + + +fieldB :: Anchor -> Field -> (Builder, Trail) +fieldB anchor field = + case field of + CurlF fillers contents -> + ( mintercalate (char8 '\n') (fmap fillerB fillers) + <> char8 '{' + <> contentsB Bottom contents + <> char8 '}' + , Trailing + ) + + NormalF contents -> + (contentsB anchor contents, Contextual) + + + +layoutB :: Layout -> Builder +layoutB (Layout nodes) = fst $ nodesB Bottom Contextual nodes + +nodesB :: Anchor -> Trail -> [Node] -> (Builder, Trail) +nodesB anchor trail xs = + case xs of + y:zs -> go y zs + [] -> (mempty, Contextual) + where + go a bs = + let ~(rendered, trail') = nodeB anchor trail a + in case bs of + b:cs -> let (more, trail'') = go b cs + in ( rendered <> case trail' of + Contextual -> char8 '\n' <> more + Trailing -> more + , trail'' + ) + + [] -> (rendered, trail') + +nodeB :: Anchor -> Trail -> Node -> (Builder, Trail) +nodeB anchor trail node = + case node of + Section off (Heading heading) section -> + let anchor' = offset off anchor + + ~(rendered, trail') = sectionB anchor' trail section + + in ( anchorB anchor' + <> byteString (encodeUtf8 heading) + <> rendered + , trail' + ) + + Field off (Name name) space field -> + let anchor' = offset off anchor + + ~(rendered, trail') = fieldB anchor' field + + in ( anchorB anchor' + <> byteString (encodeUtf8 name) + <> spaceB space + <> char8 ':' + <> rendered + , trail' + ) + + CommentN comment -> (commentB comment, Contextual) + + EmptyN space -> (spaceB space, Contextual) diff --git a/Cabal-layout/src/Codec/Manifest/Cabal/Internal/Version.hs b/Cabal-layout/src/Codec/Manifest/Cabal/Internal/Version.hs new file mode 100644 index 00000000000..02f3024b87c --- /dev/null +++ b/Cabal-layout/src/Codec/Manifest/Cabal/Internal/Version.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE BangPatterns + , FlexibleContexts + , FlexibleInstances #-} + +module Codec.Manifest.Cabal.Internal.Version + ( Version (..) + , versionP + , versionB + ) where + +import Data.ByteString.Builder +import qualified Data.ByteString.Builder.Prim as Prim +import Data.Char +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Int +import Text.Parsec +import Text.Parsec.Text.Lazy + + + +newtype Version = Version (NonEmpty Int32) + +instance Show Version where + showsPrec _ (Version (v :| vs)) = go v vs + where + go x (y:zs) = shows x . showChar '.' . go y zs + go x [] = shows x + + + +int10e9P :: Parser Int32 +int10e9P = do + mayc <- optionMaybe $ lookAhead anyChar + case mayc of + Just c + | c <= '9' && c >= '0' -> + if c == '0' + then do + _ <- anyChar + mayd <- optionMaybe $ lookAhead anyChar + case mayd of + Just d + | d <= '9' && d >= '0' -> + fail "Leading zero in a version word" + + _ -> pure 0 + + else do + _ <- anyChar + go 1 $ fromIntegral (ord c - 48) + + _ -> fail "Expected a version word" + where + go :: Stream s m Char => Int -> Int32 -> ParsecT s u m Int32 + go i !n = do + mayc <- optionMaybe $ lookAhead anyChar + case mayc of + Just c + | c <= '9' && c >= '0' -> + if i >= 9 + then fail "Version word is longer than nine digits" + else do + _ <- anyChar + go (i + 1) $ 10 * n + fromIntegral (ord c - 48) + + _ -> pure n + + + +versionP :: Parser Version +versionP = do + v0 <- int10e9P + vs <- go 2 id + pure . Version $ v0 :| vs + where + go :: Int -> ([Int32] -> [Int32]) -> Parser [Int32] + go !n acc = do + mayc <- optionMaybe $ lookAhead anyChar + case mayc of + Just '.' -> do + _ <- anyChar + v <- int10e9P + go (n + 1) (acc . (:) v) + + _ -> pure $ acc [] + + + +versionB :: Version -> Builder +versionB (Version (v :| vs)) = go v vs + where + go x (y:zs) = + Prim.primBounded + (Prim.int32Dec Prim.>*< Prim.liftFixedToBounded Prim.char8) (x, '.') + + <> go y zs + + go x [] = Prim.primBounded Prim.int32Dec x diff --git a/Cabal-layout/src/Codec/Manifest/Cabal/Layout.hs b/Cabal-layout/src/Codec/Manifest/Cabal/Layout.hs new file mode 100644 index 00000000000..9bb04ed5cd8 --- /dev/null +++ b/Cabal-layout/src/Codec/Manifest/Cabal/Layout.hs @@ -0,0 +1,38 @@ +module Codec.Manifest.Cabal.Layout + ( Codec.Manifest.Cabal.Layout.parse + + , render + + , -- * Types + Offset (..) + , Whitespace (..) + , Comment (..) + , Heading (..) + , Inline (..) + , Line (..) + , Filler (..) + , Section (..) + , Contents (..) + , Field (..) + , Node (..) + , Layout (..) + ) where + +import Codec.Manifest.Cabal.Internal.Layout +import Codec.Manifest.Cabal.Internal.Parse +import Codec.Manifest.Cabal.Internal.Render + +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.ByteString.Builder +import qualified Data.Text.Lazy as Lazy (Text) +import Text.Parsec hiding (Line) + + + +parse :: Lazy.Text -> Either ParseError Layout +parse = Text.Parsec.parse layoutP "" + + + +render :: Layout -> BSLC.ByteString +render = toLazyByteString . layoutB diff --git a/Cabal-layout/src/Hackage/Cabal/Patches.hs b/Cabal-layout/src/Hackage/Cabal/Patches.hs new file mode 100644 index 00000000000..cf48d20bf24 --- /dev/null +++ b/Cabal-layout/src/Hackage/Cabal/Patches.hs @@ -0,0 +1,1027 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Hackage.Cabal.Patches + ( Package (..) + , Version (..) + , Revision (..) + , Patch (..) + + , patches + ) where + +import Codec.Manifest.Cabal.Internal.Version + +import Data.Bits +import Data.Char +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.ByteString.Unsafe +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Word +import GHC.Fingerprint +import Foreign.Ptr + + + +showsHexFingerprint :: Fingerprint -> ShowS +showsHexFingerprint (Fingerprint l r) = + showString "Fingerprint 0x" . (hex16 16 l <>) . showString " 0x" . (hex16 16 r <>) + where + offset :: Int -> Int + offset i + | i < 10 = 48 + | otherwise = 55 + + hex16 :: Int -> Word64 -> String + hex16 c n + | c <= 0 = [] + | otherwise = + let n' = n `unsafeShiftL` 4 + i = fromIntegral (n `unsafeShiftR` 60) + + in chr (i + offset i) : hex16 (c - 1) n' + +checkMD5 :: BSC.ByteString -> IO Fingerprint +checkMD5 bs = unsafeUseAsCStringLen bs $ \(ptr, len) -> + fingerprintData (castPtr ptr) len + +_fingerprint :: FilePath -> (BSLC.ByteString -> BSLC.ByteString) -> IO () +_fingerprint path patch = do + file <- BSC.readFile path + fingerprint <- checkMD5 file + + putStrLn $ showsHexFingerprint fingerprint "" + + let file' = BSLC.toStrict . patch $ BSLC.fromStrict file + fingerprint' <- checkMD5 file' + + putStrLn $ showsHexFingerprint fingerprint' "" + + + +newtype Package = Package BSC.ByteString + deriving Show + +newtype Revision = Revision Int + deriving Show + +data Patch = Patch + Fingerprint -- ^ Original file MD5 hash + Fingerprint -- ^ Modified file MD5 hash + (BSLC.ByteString -> BSLC.ByteString) + +instance Show Patch where + showsPrec d (Patch l r _) = + showParen (d > 10) $ showString "Patch " + . showsPrec 11 l . showChar ' ' + . showsPrec 11 r . showString " _" + + + +patches :: [(Package, [(Version, [(Revision, Patch)])])] +patches = + [ + + -- single dot in "other-modules" misinterpreted as an empty line + + (,) (Package "unicode-transforms") + [ (,) (Version (0 :| [3,3])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0xDD76C65DFDDAAA73 0x8F336B568E127831) + (Fingerprint 0x98C5ED065CA1964A 0xBFBAFA37F2CFBFAB) + punicode_transformsv0_3_3 + ] + ] + + -- fields with spaces in names + + , (,) (Package "DSTM") + [ (,) (Version (0 :| [1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x91C0BABCAC04DD3A 0xE3EE2BB1FA0BD64B) + (Fingerprint 0xBC35F486FEF9CF2B 0xF867D73E12DF13BE) + pDSTMv0_1 + ] + + , (,) (Version (0 :| [1,1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0xF04481FC8441AB51 0x855F1AA0F8550458) + (Fingerprint 0xEF67AC6FB76CA2FA 0xF4AA20697ED66889) + pDSTMv0_1_1 + ] + + , (,) (Version (0 :| [1,2])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x6006291A8F214ECE 0x7D9AB5DCB637A5C3) + (Fingerprint 0xEC220DCC8A00F27C 0xA5BEA530FD6C1910) + pDSTMv0_1_2 + ] + ] + + , (,) (Package "control-monad-exception-mtl") + [ (,) (Version (0 :| [10,3])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0xFD9CF2DDD63BCFD4 0x381D89165A98FCA3) + (Fingerprint 0x9DA6D0E329F2E1CF 0x071A20916FFEF82A) + pcontrol_monad_exception_mtlv0_10_3 + ] + ] + + -- '\DEL' character + + , (,) (Package "vacuum-opengl") + [ (,) (Version (0 :| [0])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x5287232FFBD7B691 0xEAFF62B1B5455C2E) + (Fingerprint 0xC2C56E4F7E19A973 0xC29FE1BAF78DD450) + pvacuum_openglv0_0 + ] + + , (,) (Version (0 :| [0,1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x95C127F3D330654F 0x122C7E1BE7946D5C) + (Fingerprint 0x15BAA3782DE374A0 0xBD5E90117A02DDF9) + pvacuum_openglv0_0_1 + ] + + ] + + -- {- comments -} + + , (,) (Package "ixset") + [ (,) (Version (1 :| [0,4])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0xA4F3E2029EA6CBE9 0x39999AFD1B2F28AF) + (Fingerprint 0x4F89E823849C0607 0xF27FDA365EC0835D) + pixsetv1_0_4r0 + ] + ] + + -- : after section + + , (,) (Package "ds-kanren") + [ (,) (Version (0 :| [2,0,0])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x26E9D54B4B97A36B 0x864E315EB592755E) + (Fingerprint 0x384E84502EB3046D 0x536C04CE0186455A) + pds_kanrenv0_2_0_0e1 + ] + + , (,) (Version (0 :| [2,0,1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x7EB532C6DADD44A1 0x1DEA7B7C0D9CB674) + (Fingerprint 0x1CDA064466985F34 0xE9CA7BC31EA7B5E4) + pds_kanrenv0_2_0_1e1 + ] + + ] + + , (,) (Package "metric") + [ (,) (Version (0 :| [1,4])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x555941F32E58FE2A 0x2A8F78C4D42CD502) + (Fingerprint 0x8F667EB7378DF5D7 0xB24B1E98D1DC5BDD) + pmetricv0_1_4e1 + ] + + , (,) (Version (0 :| [2,0])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x4063E6F1F50FFE2E 0x6D11E73784D96987) + (Fingerprint 0x0E35BCB54B49DD7A 0x506464B88BC0AC35) + pmetricv0_2_0e1 + ] + ] + + , (,) (Package "phasechange") + [ (,) (Version (0 :| [1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x925CBAC26035876E 0x0368389BFD517347) + (Fingerprint 0x47BF0259F1C240E8 0x6492D76BB19EC369) + pphasechangev0_1 + ] + ] + + , (,) (Package "smartword") + [ (,) (Version (0 :| [0,0,5])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x6C4BC2A2BB5DAC5F 0x95FB69A1B1BC3C86) + (Fingerprint 0x171D867EE25DD359 0xE0FDF038404B17BD) + psmartwordv0_0_0_5 + ] + ] + + , (,) (Package "shelltestrunner") + [ (,) (Version (1 :| [3])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x3D1B70D2AA75C16D 0xD59D97C209D5681A) + (Fingerprint 0x8DD0C7E21870D4C7 0x4073889A7AE8794D) + pshelltestrunnerv1_3 + ] + ] + + -- &&! + + , (,) (Package "hblas") + [ (,) (Version (0 :| [2,0,0])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x76EF2EDEBB7C9E61 0xFE2DD056ED3AFC19) + (Fingerprint 0x9668562A268F8E05 0xDE695A48CB9F33DF) + phblasv0_2_0_0 + ] + + , (,) (Version (0 :| [3,0,0])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x49097DB512A0C9F3 0x9686F520DD3723F8) + (Fingerprint 0x29F3B0E8185D4255 0xB9E811142A0B803C) + phblasv0_3_0_0 + ] + + , (,) (Version (0 :| [3,0,1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x00C0A3319837991D 0x4CB220094064DDB1) + (Fingerprint 0x1847EFF2EC949169 0x77727A7B02EB420D) + phblasv0_3_0_1 + ] + + , (,) (Version (0 :| [3,1,0])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x5E9BBD387B54CA5C 0xD40963973A5205E9) + (Fingerprint 0xDAAEA83295B653C0 0xD7B23C92C6595D9F) + phblasv0_3_1_0 + ] + + , (,) (Version (0 :| [3,1,1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x73533ACF82684D48 0x02CB399C5C4E09B7) + (Fingerprint 0x8EB5E8B5B2D1BB18 0x3ABAE5F0FB807316) + phblasv0_3_1_1 + ] + + , (,) (Version (0 :| [3,2,1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x614C08B4E3171EC3 0xA0DEA58890933104) + (Fingerprint 0x5577FFF442D39D1D 0x591782F1C222DC27) + phblasv0_3_2_1r0 + + , (,) (Revision 1) $ + Patch + (Fingerprint 0x1CD274CDDACAB6D9 0xE694E8A64C1E6B2B) + (Fingerprint 0x939611048906E89A 0x495AFA5A8E871738) + phblasv0_3_2_1r1 + + , (,) (Revision 2) $ + Patch + (Fingerprint 0xA473BAFAF8ED08AB 0xA5EDF500BB60EA2E) + (Fingerprint 0xBE2A5E8E07D28EE9 0xB9BBD6526BFE8B96) + phblasv0_3_2_1r2 + ] + + , (,) (Version (0 :| [4,0,0])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0xBDFDCC06038F74E4 0x004600BCCD095F02) + (Fingerprint 0x9B48A51E81B0BB48 0x7411388255F2A566) + phblasv0_4_0_0 + ] + ] + + -- flag used, but not defined + + , (,) (Package "brainheck") + [ (,) (Version (0 :| [1,0,2])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x5FE7D5B2A340EF48 0xD5BD98F4F4E2778D) + (Fingerprint 0xE5B26DA09ABA5F20 0xE1A8771590BE95AD) + pbrainheckv0_1_0_2r0 + + , (,) (Revision 1) $ + Patch + (Fingerprint 0xC6BE5EA37ABFE415 0x8B359EB49B205421) + (Fingerprint 0x6E75742134B1E8E8 0xB84BD42D0C9C19BA) + pbrainheckv0_1_0_2r1 + + , (,) (Revision 2) $ + Patch + (Fingerprint 0x34DC909D52E06238 0x95D33074FE2B7E6D) + (Fingerprint 0x0FA4BACB6375393C 0xA7C282376A3FC705) + pbrainheckv0_1_0_2r1 + + , (,) (Revision 3) $ + Patch + (Fingerprint 0xC058A86CB59A1986 0xAD313DF7C594203B) + (Fingerprint 0x410D4A84DF32C967 0x6F354C7201CBA589) + pbrainheckv0_1_0_2r3 + ] + ] + + , (,) (Package "wordchoice") + [ (,) (Version (0 :| [1,0,1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0xE10A7D801867688B 0xD86C50D43C82657B) + (Fingerprint 0xD1D773B8881CBCA7 0x250037DC8B71CC6F) + pwordchoicev0_1_0_1r0 + + , (,) (Revision 1) $ + Patch + (Fingerprint 0xE646AC35EE3DC624 0x383EDC5EC98842A1) + (Fingerprint 0x31A5692403466649 0x9F57E6A8D36F3881) + pwordchoicev0_1_0_1r1 + ] + + , (,) (Version (0 :| [1,0,2])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x815BEA1C3E893F6E 0x1244C43323724B5F) + (Fingerprint 0x3485B3B51896D6B5 0xAFBABC8808D4879B) + pwordchoicev0_1_0_2r0 + + , (,) (Revision 1) $ + Patch + (Fingerprint 0x235869B28A5C92B9 0x1C95A3FDDD0D5298) + (Fingerprint 0x702946A4E678DA64 0x0888F313490A70FB) + pwordchoicev0_1_0_2r1 + ] + + , (,) (Version (0 :| [1,0,3])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x1FACA5302AF8DFDF 0xACE2200B88C6A658) + (Fingerprint 0xF06DE6E5F6D18500 0xEE527055DEAC380D) + pwordchoicev0_1_0_2r0 + + , (,) (Revision 1) $ + Patch + (Fingerprint 0xB3226381A5C8D219 0x99BEA513FBF8FE1E) + (Fingerprint 0xB7D3E761206EB8C8 0x40B6850797D82996) + pwordchoicev0_1_0_2r1 + ] + ] + + , (,) (Package "hw-prim-bits") + [ (,) (Version (0 :| [1,0,0])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0xABE6ACB775B44A54 0xF1AB834894A2EB1F) + (Fingerprint 0x2FE8FFC90F9E8542 0xC3B7851BC6FC5278) + phw_prim_bitsv0_1_0_0 + ] + + , (,) (Version (0 :| [1,0,1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x5F58FE271203A97C 0xC9F8445A7DCF4BFC) + (Fingerprint 0xAD357E86BFE9F6C7 0xCC28494F12A6D59A) + phw_prim_bitsv0_1_0_1 + ] + ] + + -- leading zeros in version digits + + , (,) (Package "Sit") + [ (,) (Version (0 :| [2017,2,26])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x7562BD095EBB7296 0x2CCE12E1BEA2BA25) + (Fingerprint 0xC8D18D5E8A7BF819 0xF30F7C37B959F9AB) + pSitv0_2017_2_26r0 + ] + + , (,) (Version (0 :| [2017,5,1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x141FE653145FFA81 0xA2F451615E61A39C) + (Fingerprint 0xE77A6C0635F39A45 0x3B0843C3A4CAFC96) + pSitv0_2017_5_1r0 + ] + + , (,) (Version (0 :| [2017,5,2])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x042009F71F9E4B19 0xF06653CF9B9D9C00) + (Fingerprint 0x08CF4E3110EA71A0 0x185D1467F9317E4E) + pSitv0_2017_5_2r0 + + , (,) (Revision 1) $ + Patch + (Fingerprint 0x335178C5ED248D35 0x36B8497E6845E530) + (Fingerprint 0xC711FE80329F135A 0xE368304D783836D8) + pSitv0_2017_5_2r1 + ] + ] + + , (,) (Package "MiniAgda") + [ (,) (Version (0 :| [2017,2,18])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0xEE3DE4D3EBC68B27 0x3BADEA07A42CAC39) + (Fingerprint 0xAC1D98C61052D989 0x6B117CD15B4AFD7E) + pMiniAgdav0_2017_2_18r0 + ] + ] + + , (,) (Package "fast-downward") + [ (,) (Version (0 :| [1,0,0])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x9C359D852F0B0D03 0x5F4FB1C2EB822810) + (Fingerprint 0xA8C058E0E3813C6A 0x493F470A9D17364D) + pfast_downwardv0_1_0_0r0 + + , (,) (Revision 1) $ + Patch + (Fingerprint 0x7FE67F96CEAEC267 0x0C6628B7437A2C1C) + (Fingerprint 0x8B0ECB1CC737517B 0x195F8E966829AB93) + pfast_downwardv0_1_0_0r1 + ] + + , (,) (Version (0 :| [1,0,1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x89637669C71F6278 0x52FEC4B6E40D8FA6) + (Fingerprint 0xA6A319AB7ECC3AE6 0x737BC9BCAA4B63DF) + pfast_downwardv0_1_0_1 + ] + + , (,) (Version (0 :| [1,1,0])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0xB02C7AF973EAA227 0x1A661FE3FEFE65FF) + (Fingerprint 0xD62D9218636B49C9 0x1FB4EE2DD01F92F0) + pfast_downwardv0_1_1_0 + ] + ] + + -- version length exceeds nine digits + + , (,) (Package "SGplus") + [ (,) (Version (1 :| [1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0xF621AF4C72ED375D 0x9F8215632E481FBA) + (Fingerprint 0x84BF56197F02764C 0xDD6E4BA447FCE21C) + pSGplusv1_1 + ] + ] + + , (,) (Package "control-dotdotdot") + [ (,) (Version (0 :| [1,0,1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x1503B8E06D892BF6 0x6BA307216B485FB5) + (Fingerprint 0xC36DA4A5D743B1CF 0xFF927C718CA487CB) + pcontrol_dotdotdotv0_1_0_1 + ] + ] + + , (,) (Package "data-foldapp") + [ (,) (Version (0 :| [1,1,0])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x3E9B1F90498A69F3 0xA262D8AB2B943DAC) + (Fingerprint 0xA40B00F5C25DF6DD 0x4408398749AFBBC4) + pdata_foldappv0_1_1_0 + ] + ] + + , (,) (Package "data-list-zigzag") + [ (,) (Version (0 :| [1,1,1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0xAD2314015488BB4B 0xFA8C1A9B73E5A5E1) + (Fingerprint 0xE1EDF596316CF59E 0xDA9F23F125C46345) + pdata_list_zigzagv0_1_1_1 + ] + ] + + -- Not UTF-8 encoding + + , (,) (Package "nat") + [ (,) (Version (0 :| [1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x7FFCF20BA0E0B894 0xB5985D5FA7FC4227) + (Fingerprint 0xF26E135671D11FBE 0xB77B8D1D49D20634) + pnatv0_1 + ] + ] + + -- cabal-version: 2 + + , (,) (Package "streaming-bracketed") + [ (,) (Version (0 :| [1,0,0])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0xCB9677E55A5C6BF7 0x13CF7D7DD4CA3B55) + (Fingerprint 0x80223BA2D7D55031 0x5B346DC4F94858D6) + pstreaming_bracketedv0_1_0_0 + ] + + , (,) (Version (0 :| [1,0,1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x654A5453500AA567 0x8CBE884D34B36822) + (Fingerprint 0x12BBFC2295577719 0x31DF53F9B9DFA62D) + pstreaming_bracketedv0_1_0_1 + ] + ] + + , (,) (Package "zsyntax") + [ (,) (Version (0 :| [2,0,0])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0xF7321CE9FD54C553 0x29B4F2B864C5F9D7) + (Fingerprint 0x2FD27FDF9480E134 0xAD16C19E721A1B5A) + pzsyntaxv0_2_0_0 + ] + ] + + -- empty hs-source-dirs field + + , (,) (Package "wai-middleware-hmac-client") + [ (,) (Version (0 :| [1,0,1])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x2B323327DD3EF4BB 0xA651E107CCAC410B) + (Fingerprint 0x5FFC1B28D862BCA4 0x5BE3E6C65561AA50) + pwai_middleware_hmac_clientv0_1_0_1 + ] + + , (,) (Version (0 :| [1,0,2])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0xAE662EDE54B9AFAA 0xF3B913407DB727DD) + (Fingerprint 0xDA83E7AD0A344FEA 0x9280370898F79C0C) + pwai_middleware_hmac_clientv0_1_0_2 + ] + ] + + -- absolute license path + + , (,) (Package "reheat") + [ (,) (Version (0 :| [1,4])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x7F0E8419E7B61A45 0xCD922EE0B34FE702) + (Fingerprint 0x6AADE64A5BB9C363 0xD580A03AB7034580) + preheatv0_1_4 + ] + + , (,) (Version (0 :| [1,5])) + [ (,) (Revision 0) $ + Patch + (Fingerprint 0x296AAFEF8A70E42D 0xA2C30F7C82EE1D19) + (Fingerprint 0xA75852D61D776BF5 0xC289B81E96F9E9C2) + preheatv0_1_5 + ] + ] + ] + + + +-- line 193, column 1: " other-modules:\n .\n" -> "" +punicode_transformsv0_3_3 :: BSLC.ByteString -> BSLC.ByteString +punicode_transformsv0_3_3 bsl = + let (before, after) = BSLC.splitAt 5652 bsl + in before <> BSLC.drop 25 after + + + +-- line 60, column 3: "Other modules:" -> "Other-modules:" +pDSTMv0_1 :: BSLC.ByteString -> BSLC.ByteString +pDSTMv0_1 bsl = + let (before, after) = BSLC.splitAt 1999 bsl + in before <> "-- " <> BSLC.drop 14 after + +-- line 60, column 3: "Other modules:" -> "-- " +pDSTMv0_1_1 :: BSLC.ByteString -> BSLC.ByteString +pDSTMv0_1_1 bsl = + let (before, after) = BSLC.splitAt 2001 bsl + in before <> "-- " <> BSLC.drop 14 after + +-- line 69, column 3: "Other modules:" -> "Other-modules:" +pDSTMv0_1_2 :: BSLC.ByteString -> BSLC.ByteString +pDSTMv0_1_2 bsl = + let (before, after) = BSLC.splitAt 2225 bsl + in before <> "-- " <> BSLC.drop 14 after + + + +-- line 26, column 2: "default- extensions:" -> " default-extensions:" +pcontrol_monad_exception_mtlv0_10_3 :: BSLC.ByteString -> BSLC.ByteString +pcontrol_monad_exception_mtlv0_10_3 bsl = + let (before, after) = BSLC.splitAt 704 bsl + in before <> " default-" <> BSLC.drop 9 after + +-- line 26, column 2: " default- extensions:" -> "unknown-section" +-- +-- Fingerprint 0x9E24163ECAD97FFB 0x3BB8750A5516E854 +_pcontrol_monad_exception_mtlv0_10_3' :: BSLC.ByteString -> BSLC.ByteString +_pcontrol_monad_exception_mtlv0_10_3' bsl = + let (before, after) = BSLC.splitAt 703 bsl + in before <> "unknown-section" <> BSLC.drop 21 after + + + +-- line 4, column 22: "\DEL" -> "" +pvacuum_openglv0_0 :: BSLC.ByteString -> BSLC.ByteString +pvacuum_openglv0_0 bsl = + let (before, after) = BSLC.splitAt 176 bsl + in before <> BSLC.drop 1 after + + +-- line 4, column 22: "\DEL" -> "" +pvacuum_openglv0_0_1 :: BSLC.ByteString -> BSLC.ByteString +pvacuum_openglv0_0_1 bsl = + let (before, after) = BSLC.splitAt 178 bsl + in before <> BSLC.drop 1 after + + + +-- line 49, column 1: "{-...eof" -> "" +pixsetv1_0_4r0 :: BSLC.ByteString -> BSLC.ByteString +pixsetv1_0_4r0 = BSLC.take 1268 + + + +-- line 80, column 1: "Test-Suite test-unify:" -> "Test-Suite \"test-unify:\"" +-- line 91, column 1: "Test-Suite test-list-ops:" -> "Test-Suite \"test-list-ops:\"" +-- +-- Fingerprint 0x886CF947F5364109 0xB1CDBFB920AD3589 +_pds_kanrenv0_2_0_0e0 :: BSLC.ByteString -> BSLC.ByteString +_pds_kanrenv0_2_0_0e0 bsl = + let (before, middle_) = BSLC.splitAt 2509 bsl + (middle, after) = BSLC.splitAt 349 middle_ + in before <> "\"test-unify:\"" <> BSLC.drop 11 middle + <> "\"test-list-ops:\"" <> BSLC.drop 14 after + +-- line 27, column 1: "Test-Suite test-unify:" -> "Test-Suite \"test-unify:\"" +-- line 38, column 1: "Test-Suite test-list-ops:" -> "Test-Suite \"test-list-ops:\"" +-- +-- Fingerprint 0x19A55F8211A75AB0 0x3FCEA17BED62D029 +_pds_kanrenv0_2_0_1e0 :: BSLC.ByteString -> BSLC.ByteString +_pds_kanrenv0_2_0_1e0 bsl = + let (before, middle_) = BSLC.splitAt 839 bsl + (middle, after) = BSLC.splitAt 349 middle_ + in before <> "\"test-unify:\"" <> BSLC.drop 11 middle + <> "\"test-list-ops:\"" <> BSLC.drop 14 after + + + +-- line 80, column 1: "Test-Suite test-unify:" -> "Test-Suite test-unify" +-- line 91, column 1: "Test-Suite test-list-ops:" -> "Test-Suite test-list-ops" +pds_kanrenv0_2_0_0e1 :: BSLC.ByteString -> BSLC.ByteString +pds_kanrenv0_2_0_0e1 bsl = + let (before, middle_) = BSLC.splitAt 2519 bsl + (middle, after) = BSLC.splitAt 352 middle_ + in before <> BSLC.drop 1 middle <> BSLC.drop 1 after + +-- line 27, column 1: "Test-Suite test-unify:" -> "Test-Suite test-unify" +-- line 38, column 1: "Test-Suite test-list-ops:" -> "Test-Suite test-list-ops" +pds_kanrenv0_2_0_1e1 :: BSLC.ByteString -> BSLC.ByteString +pds_kanrenv0_2_0_1e1 bsl = + let (before, middle_) = BSLC.splitAt 849 bsl + (middle, after) = BSLC.splitAt 352 middle_ + in before <> BSLC.drop 1 middle <> BSLC.drop 1 after + + + +-- line 28, column 1: "Test-Suite metric-tests:" -> "Test-Suite \"metric-tests:\"" +-- +-- Fingerprint 0x7EA1E4EB98FD4E64 0xD8E7DD349B7A8884 +_pmetricv0_1_4e0 :: BSLC.ByteString -> BSLC.ByteString +_pmetricv0_1_4e0 bsl = + let (before, after) = BSLC.splitAt 927 bsl + in before <> "\"metric-tests:\"" <> BSLC.drop 13 after + +-- line 28, column 1: "Test-Suite metric-tests:" -> "Test-Suite \"metric-tests:\"" +-- +-- Fingerprint 0x4D3F31AEA567A1EF 0x0C1E383D1EC6C7AF +_pmetricv0_2_0e0 :: BSLC.ByteString -> BSLC.ByteString +_pmetricv0_2_0e0 = _pmetricv0_1_4e0 + + + +-- line 28, column 1: "Test-Suite metric-tests:" -> "Test-Suite metric-tests" +pmetricv0_1_4e1 :: BSLC.ByteString -> BSLC.ByteString +pmetricv0_1_4e1 bsl = + let (before, after) = BSLC.splitAt 939 bsl + in before <> BSLC.drop 1 after + +-- line 28, column 1: "Test-Suite metric-tests:" -> "Test-Suite metric-tests" +pmetricv0_2_0e1 :: BSLC.ByteString -> BSLC.ByteString +pmetricv0_2_0e1 = pmetricv0_1_4e1 + + + +-- line 49, column 5: "impl(ghc >= 7.4):" -> "erroneous-section" +-- line 54, column 5: "impl(ghc >= 7.6):" -> "erroneous-section" +pphasechangev0_1 :: BSLC.ByteString -> BSLC.ByteString +pphasechangev0_1 bsl = + let (before, middle_) = BSLC.splitAt 2104 bsl + (middle, after) = BSLC.splitAt 102 middle_ + in before <> "erroneous-section" <> BSLC.drop 17 middle + <> "erroneous-section" <> BSLC.drop 17 after + + + +-- line 3438, column 3: "build depends:" -> "--" +psmartwordv0_0_0_5 :: BSLC.ByteString -> BSLC.ByteString +psmartwordv0_0_0_5 bsl = + let (before, after) = BSLC.splitAt 65767 bsl + in before <> "--" <> BSLC.drop 14 after + + + +-- line 28, column 3: "other modules:" -> "--" +pshelltestrunnerv1_3 :: BSLC.ByteString -> BSLC.ByteString +pshelltestrunnerv1_3 bsl = + let (before, after) = BSLC.splitAt 956 bsl + in before <> "--" <> BSLC.drop 14 after + + + +-- line 97, column 13: "&&!" -> "&& !" +phblasv0_2_0_0 :: BSLC.ByteString -> BSLC.ByteString +phblasv0_2_0_0 bsl = + let (before, after) = BSLC.splitAt 2714 bsl + in before <> " " <> after + +-- line 98, column 13: "&&!" -> "&& !" +phblasv0_3_0_0 :: BSLC.ByteString -> BSLC.ByteString +phblasv0_3_0_0 bsl = + let (before, after) = BSLC.splitAt 2749 bsl + in before <> " " <> after + +-- line 125, column 13: "&&!" -> "&& !" +phblasv0_3_0_1 :: BSLC.ByteString -> BSLC.ByteString +phblasv0_3_0_1 bsl = + let (before, after) = BSLC.splitAt 4066 bsl + in before <> " " <> after + +-- line 132, column 13: "&&!" -> "&& !" +phblasv0_3_1_0 :: BSLC.ByteString -> BSLC.ByteString +phblasv0_3_1_0 bsl = + let (before, after) = BSLC.splitAt 4167 bsl + in before <> " " <> after + +-- line 132, column 13: "&&!" -> "&& !" +phblasv0_3_1_1 :: BSLC.ByteString -> BSLC.ByteString +phblasv0_3_1_1 = phblasv0_3_1_0 + +-- line 132, column 13: "&&!" -> "&& !" +phblasv0_3_2_1r0 :: BSLC.ByteString -> BSLC.ByteString +phblasv0_3_2_1r0 bsl = + let (before, after) = BSLC.splitAt 4167 bsl + in before <> " " <> after + +-- line 133, column 13: "&&!" -> "&& !" +phblasv0_3_2_1r1 :: BSLC.ByteString -> BSLC.ByteString +phblasv0_3_2_1r1 bsl = + let (before, after) = BSLC.splitAt 4313 bsl + in before <> " " <> after + +-- line 133, column 13: "&&!" -> "&& !" +phblasv0_3_2_1r2 :: BSLC.ByteString -> BSLC.ByteString +phblasv0_3_2_1r2 bsl = + let (before, after) = BSLC.splitAt 4314 bsl + in before <> " " <> after + +-- line 148, column 13: "&&!" -> "&& !" +phblasv0_4_0_0 :: BSLC.ByteString -> BSLC.ByteString +phblasv0_4_0_0 bsl = + let (before, after) = BSLC.splitAt 4693 bsl + in before <> " " <> after + + + +-- line 55, column 6: "flag(llvm-fast)" -> "False" +pbrainheckv0_1_0_2r0 :: BSLC.ByteString -> BSLC.ByteString +pbrainheckv0_1_0_2r0 bsl = + let (before, after) = BSLC.splitAt 1786 bsl + in before <> "False" <> BSLC.drop 15 after + +-- line 56, column 6: "flag(llvm-fast)" -> "False" +pbrainheckv0_1_0_2r1 :: BSLC.ByteString -> BSLC.ByteString +pbrainheckv0_1_0_2r1 bsl = + let (before, after) = BSLC.splitAt 1863 bsl + in before <> "False" <> BSLC.drop 15 after + +-- line 56, column 6: "flag(llvm-fast)" -> "False" +pbrainheckv0_1_0_2r3 :: BSLC.ByteString -> BSLC.ByteString +pbrainheckv0_1_0_2r3 bsl = + let (before, after) = BSLC.splitAt 1874 bsl + in before <> "False" <> BSLC.drop 15 after + + + +-- line 62, column 6: "flag(llvm-fast)" -> "False" +pwordchoicev0_1_0_1r0 :: BSLC.ByteString -> BSLC.ByteString +pwordchoicev0_1_0_1r0 bsl = + let (before, after) = BSLC.splitAt 2079 bsl + in before <> "False" <> BSLC.drop 15 after + +-- line 63, column 6: "flag(llvm-fast)" -> "False" +pwordchoicev0_1_0_1r1 :: BSLC.ByteString -> BSLC.ByteString +pwordchoicev0_1_0_1r1 bsl = + let (before, after) = BSLC.splitAt 2161 bsl + in before <> "False" <> BSLC.drop 15 after + +-- line 63, column 6: "flag(llvm-fast)" -> "False" +pwordchoicev0_1_0_2r0 :: BSLC.ByteString -> BSLC.ByteString +pwordchoicev0_1_0_2r0 bsl = + let (before, after) = BSLC.splitAt 2107 bsl + in before <> "False" <> BSLC.drop 15 after + +-- line 64, column 6: "flag(llvm-fast)" -> "False" +pwordchoicev0_1_0_2r1 :: BSLC.ByteString -> BSLC.ByteString +pwordchoicev0_1_0_2r1 bsl = + let (before, after) = BSLC.splitAt 2190 bsl + in before <> "False" <> BSLC.drop 15 after + + + +-- line 46, column 8: "flag(sse42)" -> "False" +phw_prim_bitsv0_1_0_0 :: BSLC.ByteString -> BSLC.ByteString +phw_prim_bitsv0_1_0_0 bsl = + let (before, after) = BSLC.splitAt 1421 bsl + in before <> "False" <> BSLC.drop 11 after + +-- line 46, column 6: "flag(sse42)" -> "False" +phw_prim_bitsv0_1_0_1 :: BSLC.ByteString -> BSLC.ByteString +phw_prim_bitsv0_1_0_1 bsl = + let (before, after) = BSLC.splitAt 1458 bsl + in before <> "False" <> BSLC.drop 11 after + + + +-- line 2, column 18: "0.2017.02.26" -> "0.2017.2.26" +pSitv0_2017_2_26r0 :: BSLC.ByteString -> BSLC.ByteString +pSitv0_2017_2_26r0 bsl = + let (before, after) = BSLC.splitAt 45 bsl + in before <> BSLC.drop 1 after + +-- line 2, column 18: "0.2017.05.01" -> "0.2017.5.1" +pSitv0_2017_5_1r0 :: BSLC.ByteString -> BSLC.ByteString +pSitv0_2017_5_1r0 bsl = + let (before, after) = BSLC.splitAt 45 bsl + in before <> "5." <> BSLC.drop 4 after + +-- line 2, column 18: "0.2017.05.02" -> "0.2017.5.2" +pSitv0_2017_5_2r0 :: BSLC.ByteString -> BSLC.ByteString +pSitv0_2017_5_2r0 bsl = + let (before, after) = BSLC.splitAt 45 bsl + in before <> "5." <> BSLC.drop 4 after + +-- line 2, column 18: "0.2017.5.02" -> "0.2017.5.2" +pSitv0_2017_5_2r1 :: BSLC.ByteString -> BSLC.ByteString +pSitv0_2017_5_2r1 bsl = + let (before, after) = BSLC.splitAt 47 bsl + in before <> BSLC.drop 1 after + + + +-- line 2, column 18: "0.2017.02.18" -> "0.2017.2.18" +pMiniAgdav0_2017_2_18r0 :: BSLC.ByteString -> BSLC.ByteString +pMiniAgdav0_2017_2_18r0 bsl = + let (before, after) = BSLC.splitAt 50 bsl + in before <> BSLC.drop 1 after + + + +-- line 56, column 5: "1.2.03.0" -> "1.2.3.0" +pfast_downwardv0_1_0_0r0 :: BSLC.ByteString -> BSLC.ByteString +pfast_downwardv0_1_0_0r0 bsl = + let (before, after) = BSLC.splitAt 1486 bsl + in before <> BSLC.drop 1 after + +-- line 65, column 5: "1.2.03.0" -> "1.2.3.0" +pfast_downwardv0_1_0_0r1 :: BSLC.ByteString -> BSLC.ByteString +pfast_downwardv0_1_0_0r1 bsl = + let (before, after) = BSLC.splitAt 1792 bsl + in before <> BSLC.drop 1 after + +-- line 66, column 5: "1.2.03.0" -> "1.2.3.0" +pfast_downwardv0_1_0_1 :: BSLC.ByteString -> BSLC.ByteString +pfast_downwardv0_1_0_1 bsl = + let (before, after) = BSLC.splitAt 1708 bsl + in before <> BSLC.drop 1 after + +-- line 66, column 5: "1.2.03.0" -> "1.2.3.0" +pfast_downwardv0_1_1_0 :: BSLC.ByteString -> BSLC.ByteString +pfast_downwardv0_1_1_0 bsl = + let (before, after) = BSLC.splitAt 1735 bsl + in before <> BSLC.drop 1 after + + + +-- line 24, column 38: "1000000000.0" -> "100000000.0" +pSGplusv1_1 :: BSLC.ByteString -> BSLC.ByteString +pSGplusv1_1 bsl = + let (before, after) = BSLC.splitAt 1010 bsl + in before <> BSLC.drop 1 after + + + +-- line 41, column 39: "9223372036854775807" -> "5" +pcontrol_dotdotdotv0_1_0_1 :: BSLC.ByteString -> BSLC.ByteString +pcontrol_dotdotdotv0_1_0_1 bsl = + let (before, after) = BSLC.splitAt 1363 bsl + in before <> "5" <> BSLC.drop 19 after + + + +-- line 37, column 38: "9223372036854775807" -> "999" +-- line 38, column 44: "9223372036854775807" -> "999" +pdata_foldappv0_1_1_0 :: BSLC.ByteString -> BSLC.ByteString +pdata_foldappv0_1_1_0 bsl = + let (before, middle_) = BSLC.splitAt 1051 bsl + (middle, after) = BSLC.splitAt 64 middle_ + in before <> "999" <> BSLC.drop 19 middle + <> "999" <> BSLC.drop 19 after + + + +-- line 23, column 40: "9223372036854775807" -> "999" +pdata_list_zigzagv0_1_1_1 :: BSLC.ByteString -> BSLC.ByteString +pdata_list_zigzagv0_1_1_1 bsl = + let (before, after) = BSLC.splitAt 845 bsl + in before <> "999" <> BSLC.drop 19 after + + + +-- line 10, column 36: "\xF6" (Latin-1) -> "รถ" +pnatv0_1 :: BSLC.ByteString -> BSLC.ByteString +pnatv0_1 bsl = + let (before, after) = BSLC.splitAt 615 bsl + in before <> "\xC3\xB6" <> BSLC.drop 1 after + + + +-- line 25, column 1: "cabal-version: 2" "cabal-version: 2.0" +pstreaming_bracketedv0_1_0_0 :: BSLC.ByteString -> BSLC.ByteString +pstreaming_bracketedv0_1_0_0 bsl = + let (before, after) = BSLC.splitAt 1043 bsl + in before <> "2.0" <> BSLC.drop 7 after + +-- line 25, column 1: "cabal-version: 2" "cabal-version: 2.0" +pstreaming_bracketedv0_1_0_1 :: BSLC.ByteString -> BSLC.ByteString +pstreaming_bracketedv0_1_0_1 bsl = + let (before, after) = BSLC.splitAt 1031 bsl + in before <> "2.0" <> BSLC.drop 7 after + + + +-- line 31, column 1: "cabal-version: 2" "cabal-version: 2.0" +pzsyntaxv0_2_0_0 :: BSLC.ByteString -> BSLC.ByteString +pzsyntaxv0_2_0_0 bsl = + let (before, after) = BSLC.splitAt 1460 bsl + in before <> "2.0" <> BSLC.drop 2 after + + + +-- line 55, column 21: "\"\"" -> "." +pwai_middleware_hmac_clientv0_1_0_1 :: BSLC.ByteString -> BSLC.ByteString +pwai_middleware_hmac_clientv0_1_0_1 bsl = + let (before, after) = BSLC.splitAt 1802 bsl + in before <> "." <> BSLC.drop 2 after + +-- line 55, column 21: "\"\"" -> "." +pwai_middleware_hmac_clientv0_1_0_2 :: BSLC.ByteString -> BSLC.ByteString +pwai_middleware_hmac_clientv0_1_0_2 bsl = + let (before, after) = BSLC.splitAt 1798 bsl + in before <> "." <> BSLC.drop 2 after + + + +-- line 6, column 15: "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" -> "" +preheatv0_1_4 :: BSLC.ByteString -> BSLC.ByteString +preheatv0_1_4 bsl = + let (before, after) = BSLC.splitAt 95 bsl + in before <> BSLC.drop 62 after + +-- line 6, column 15: "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" -> "" +preheatv0_1_5 :: BSLC.ByteString -> BSLC.ByteString +preheatv0_1_5 = preheatv0_1_4 diff --git a/Cabal-layout/test/hackage/Main.hs b/Cabal-layout/test/hackage/Main.hs new file mode 100644 index 00000000000..60fb4222910 --- /dev/null +++ b/Cabal-layout/test/hackage/Main.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE OverloadedStrings + , ScopedTypeVariables #-} + +module Main where + +import Codec.Manifest.Cabal.Internal.Parse +import Codec.Manifest.Cabal.Internal.Render +import Codec.Manifest.Cabal.Internal.Version +import Hackage.Cabal.Patches + +import Test.Strictness.Layout () + +import Data.ByteString.Builder +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy.Char8 as BSLC +import qualified Data.ByteString.Unsafe as BS +import Data.Foldable +import Data.Function +import qualified Data.List as List +import Data.Maybe +import Data.Ord +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as Lazy +import qualified Data.Text.Lazy.Encoding as Lazy +import Foreign.Ptr +import GHC.Fingerprint +import System.Directory +import System.Environment +import System.FilePath +import System.IO +import Text.Parsec +import NoThunks.Class + + + +main :: IO () +main = do + as <- getArgs + case as of + [] -> fail "Expecting path to the Hackage index as an argument" + [path] -> hackage path + _:_:_ -> fail "Too many arguments provided" + + + +-- | Convert "\r\n" to "\n", and '\t' and '\160' to ' '. +normalize :: Lazy.Text -> Lazy.Text +normalize = go . Lazy.toChunks + where + go (b:bs) = + let -- Whether or not the next chunk starts with a newline + new + | c:_ <- bs, Just ('\n', _) <- Text.uncons c = True + | otherwise = False + + in squeeze new b <> go bs + + go [] = Lazy.empty + + + squeeze new b = + let (before, after) = Text.break (\c -> c == '\t' || c == '\r' || c == '\160') b + in case Text.uncons after of + Just (c, rest) -> + case c of + '\t' -> Lazy.fromStrict before <> " " <> squeeze new rest + '\r' -> + case Text.uncons rest of + Just (d, _) -> + case d of + '\n' -> Lazy.fromStrict before <> squeeze new rest + _ -> + Lazy.fromStrict before <> "\r" <> squeeze new rest + + Nothing -> + if new + then Lazy.fromStrict before + else Lazy.fromStrict before <> "\r" + + '\160' -> Lazy.fromStrict before <> " " <> squeeze new rest + + _ -> Lazy.fromStrict before <> Lazy.cons c (squeeze new rest) + + Nothing -> Lazy.fromStrict b + + + +-- | Fold two lists into one, combining elements from the second list +-- with matching entries from the first list. +-- +-- Used over dumb dictionary lookups for performance: O(n) instead of O(n * log n). +arrange + :: (a -> b -> Ordering) + -> [a] + -> [(b, [c])] + -> [Either b (a, [c])] +arrange cmp = go + where + go as bs = + case bs of + (b, c) : bt -> align as + where + align xs = + case xs of + x:ys -> + case cmp x b of + LT -> Right (x, []) : go ys bs + EQ -> Right (x, c) : go ys bt + GT -> Left b : align ys + + [] -> [] + + [] -> fmap (\x -> Right (x, [])) as + + + +arrangePackages + :: [String] + -> [Either Package (String, [(Version, [(Revision, Patch)])])] +arrangePackages manifests = + arrange + (\name (Package pkg) -> Text.pack name `compare` Text.decodeASCII pkg) + (List.sort manifests) + (List.sortOn ((\(Package pkg) -> pkg) . fst) patches) + +arrangeVersions + :: [Version] + -> [(Version, [(Revision, Patch)])] + -> [Either Version (Version, [(Revision, Patch)])] +arrangeVersions versions verPatches = + arrange + (\(Version v0) (Version v1) -> compare v0 v1) + (List.sortOn (\(Version ver) -> ver) versions) + (List.sortOn ((\(Version ver) -> ver) . fst) verPatches) + + + +-- | Check whether the file is a directory and then whether it's a proper Version. +-- +-- Nothing is returned if it's not a directory. +checkVersion :: FilePath -> String -> String -> IO (Maybe Version) +checkVersion path manifest version = do + exists <- doesDirectoryExist $ path manifest version + if exists + then case parse versionP "" $ Lazy.pack version of + Left err -> fail $ "Version " <> version <> " of package " <> manifest + <> " is unparseable:\n" <> show err + Right ver -> pure $ Just ver + + else pure Nothing + + + +checkMD5 :: BSC.ByteString -> IO Fingerprint +checkMD5 bs = BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> + fingerprintData (castPtr ptr) len + + + +-- | Go through patches in order of descending revision, apply if MD5 hashes match +-- both for the original file and for its modified version respectively. +applyPatches + :: [(Revision, Patch)] -> BSLC.ByteString -> IO BSLC.ByteString +applyPatches patches_ bs = + go $ List.sortBy (compare `on` \(Revision rev, _) -> Down rev) patches_ + where + go ((Revision rev, Patch origRef modRef patch):xs) = do + ref0 <- checkMD5 $ BSLC.toStrict bs + if ref0 /= origRef + then do + putStrLn $ "Revision " <> show rev <> " patch does not match the original file" + go xs + + else do + let modified = patch bs + ref1 <- checkMD5 $ BSLC.toStrict modified + if ref1 /= modRef + then do + putStrLn $ "Revision " <> show rev <> " patch matches the original file, " + <> "however the modified file does not" + go xs + + else do + putStrLn $ "Using patched version of the manifest under revision " + <> show rev + pure modified + + go [] = pure bs + + + +hackage :: FilePath -> IO () +hackage path = do + manifests <- listDirectory path + for_ (arrangePackages manifests) $ \pkgpoint -> + case pkgpoint of + Left (Package pkg) -> + putStrLn $ "Package " <> BSC.unpack pkg <> " is not a part of the index" + + Right (manifest, verPatches) -> do + rawVersions <- listDirectory $ path manifest + mayVersions <- traverse (checkVersion path manifest) rawVersions + for_ (arrangeVersions (catMaybes mayVersions) verPatches) $ \verpoint -> + case verpoint of + Left version -> + putStrLn $ "Version " <> show version <> " of package " <> manifest + <> " is not a part of the index" + + Right (version, patches_) -> do + let rawVersion = BSLC.unpack . toLazyByteString $ versionB version + filepath = path manifest rawVersion manifest <.> "cabal" + + putStrLn filepath + + withBinaryFile filepath ReadMode $ \h -> do + file <- BSLC.hGetContents h + + file' <- applyPatches patches_ file + + let utf8File = normalize $ Lazy.decodeUtf8 file' + + case parse layoutP "" utf8File of + Left err -> do + fail $ "Layout could not be parsed:\n" <> show err + + Right layout -> do + mayThunks <- wNoThunks [] layout + case mayThunks of + Just (ThunkInfo ctx) -> do + fail $ "Layout is not fully evaluated: " <> show (reverse ctx) + + Nothing -> + if utf8File == Lazy.decodeUtf8 (toLazyByteString $ layoutB layout) + then putStrLn "Correct" + else fail "Rendered layout is not the same as the original file" diff --git a/Cabal-layout/test/hackage/README.md b/Cabal-layout/test/hackage/README.md new file mode 100644 index 00000000000..0bdd8ac3081 --- /dev/null +++ b/Cabal-layout/test/hackage/README.md @@ -0,0 +1,11 @@ +# Hackage parsing test + +Usage: main DIR + +Checks that every single manifest in the index can be parsed and rendered back +into an identical representation. Not all manifests are processed verbatim: +irrelevant whitespace is altered to make identity checks possible and +patches from `Hackage.Cabal.Patches` are applied to relevant files. + +DIR is the root of the unarchived Hackage index. The archive at the time of writing this +can be downloaded [here](https://hackage.haskell.org/packages/archive/00-index.tar.gz). diff --git a/Cabal-layout/test/patches/Main.hs b/Cabal-layout/test/patches/Main.hs new file mode 100644 index 00000000000..71ff47ee78a --- /dev/null +++ b/Cabal-layout/test/patches/Main.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE BangPatterns #-} + +module Main + ( main + ) where + +import Hackage.Cabal.Patches + +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.ByteString.Unsafe +import Data.List.NonEmpty (NonEmpty (..)) +import Foreign.Ptr +import GHC.Fingerprint +import System.Exit +import System.Process + + + +flatten + :: (Package -> Version -> Revision -> Patch -> a -> a) + -> a + -> [(Package, [(Version, [(Revision, Patch)])])] + -> a +flatten f = + let revisions pkg ver (rev, patch) acc = f pkg ver rev patch acc + versions pkg (ver, revs) acc = foldr (revisions pkg ver) acc revs + packages (pkg, vers) acc = foldr (versions pkg) acc vers + + in foldr packages + + + +showsLink :: Package -> Version -> Revision -> ShowS +showsLink (Package pkg) (Version (v :| ver)) (Revision rev) = do + showString "https://hackage.haskell.org/package/" + . (BSC.unpack pkg <>) + . showChar '-' + . shows v + . (\s -> foldr (\i -> showChar '.' . shows i) s ver) + . showString "/revision/" + . shows rev + . showString ".cabal" + + + +download :: Package -> Version -> Revision -> IO BSC.ByteString +download pkg ver rev = do + let cmd = (shell (showString "curl -s " $ showsLink pkg ver rev [])) + { std_out = CreatePipe + } + + putStrLn $ showsLink pkg ver rev [] + withCreateProcess cmd $ \_mayIn mayOut _mayErr process -> do + case mayOut of + Nothing -> fail "No output handle" + Just outh -> do + raw <- BSLC.hGetContents outh + let !bs = BSLC.toStrict raw + + code <- waitForProcess process + case code of + ExitFailure c -> fail $ "Error code " <> showsPrec 11 c [] + ExitSuccess -> pure bs + + + +checkMD5 :: BSC.ByteString -> IO Fingerprint +checkMD5 bs = unsafeUseAsCStringLen bs $ \(ptr, len) -> + fingerprintData (castPtr ptr) len + + + +verify :: BSC.ByteString -> Patch -> IO () +verify bs (Patch refMD5 refMD5' patch) = do + md5 <- checkMD5 bs + if md5 /= refMD5 + then fail "Pre-patch MD5 mismatch" + else do + md5' <- checkMD5 (BSLC.toStrict . patch $ BSLC.fromStrict bs) + if md5' /= refMD5' + then fail "Post-patch MD5 mismatch" + else putStrLn "Correct" + + + +main :: IO () +main = do + let run pkg ver rev patch acc = do + bs <- download pkg ver rev + verify bs patch + acc + + flatten run (pure ()) patches diff --git a/Cabal-layout/test/sanity/Main.hs b/Cabal-layout/test/sanity/Main.hs new file mode 100644 index 00000000000..f57d1b3d0e0 --- /dev/null +++ b/Cabal-layout/test/sanity/Main.hs @@ -0,0 +1,14 @@ +module Main where + +import Test.Sanity.Layout.Parse + +import Test.Tasty + + + +main :: IO () +main = + defaultMain $ + testGroup "Tests" + [ parseT + ] diff --git a/Cabal-layout/test/sanity/Test/Sanity/Layout/Parse.hs b/Cabal-layout/test/sanity/Test/Sanity/Layout/Parse.hs new file mode 100644 index 00000000000..b98332cd4aa --- /dev/null +++ b/Cabal-layout/test/sanity/Test/Sanity/Layout/Parse.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving + , OverloadedStrings + , StandaloneDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Sanity.Layout.Parse + ( parseT + ) where + +import Codec.Manifest.Cabal.Internal.Layout +import Codec.Manifest.Cabal.Internal.Parse + +import Data.String +import qualified Data.Text.Lazy as Lazy (Text) +import Text.Parsec hiding (Line) +import Test.Tasty +import Test.Tasty.HUnit + + + +deriving instance Eq Offset +deriving instance Eq Whitespace +deriving instance Eq Comment +deriving instance Eq Heading +deriving instance Eq Inline +deriving instance Eq Line +deriving instance Eq Filler +deriving instance Eq Section +deriving instance Eq Contents +deriving instance Eq Field +deriving instance Eq Node +deriving instance Eq Layout + +deriving instance Num Offset +deriving instance Num Whitespace + +deriving instance IsString Heading + + + +(==>) :: Lazy.Text -> [Node] -> Assertion +input ==> output = parse layoutP "" input @?= Right (Layout output) + +fails :: Lazy.Text -> Assertion +fails input = + case parse layoutP "" input of + Left _ -> pure () + Right res -> assertFailure . showString "Succeeded: " $ show res + +parseT :: TestTree +parseT = do + testGroup "Parse" + [ testCase "Empty" $ + "" ==> [] + + , testCase "Lone C0" $ + fails "\0" + + , testCase "Lone colon" $ + fails ":" + + , testCase "Lone left curly" $ + fails "{" + + , testCase "Lone right curly" $ + fails "{" + + , testCase "Lone bracket section" $ + fails "{}" + + , testGroup "Newlines" + [ testCase "n" + newline1 + + , testCase "1n2" + newline2 + + , testCase "4n2n3n1n" + newline3 + ] + + , testGroup "Comments" + [ testCase "C0" $ + fails "--c\0mment" + + , testCase "Curlies and colons" + comment1 + + , testCase "c" + comment2 + + , testCase "c1+2" + comment3 + + , testCase "c4+2 c3+1 n" + comment4 + ] + + , testGroup "Fields" + [ testGroup "Normal" + [ testCase "f" + fieldN1 + + , testCase "f1+2 n" + fieldN2 + + , testCase "f c1+2" + fieldN3 + + , testCase "f c4+3 n c2+1 n" + fieldN4 + + , testCase "f c n n l" + fieldN5 + + , testCase "f n n c n f" + fieldN6 + ] + + , testGroup "Curled" + [ testCase "f" + fieldC1 + + , testCase "f1+2+3{4}" + fieldC2 + + , testCase "f c n { l n c }" + fieldC3 + ] + ] + + , testGroup "Section" + [ testGroup "Normal" + [ testCase "s" + sectionN1 + + , testCase "s1+2 n" + sectionN2 + + , testCase "s c1+2" + sectionN3 + + , testCase "s c4+3 n c2+1 n" + sectionN4 + + , testCase "s c n n s'" + sectionN5 + + , testCase "s n n c n s" + sectionN6 + ] + + , testGroup "Curled" + [ testCase "f" + sectionC1 + + , testCase "f1+2+3{4}" + sectionC2 + + , testCase "f c n { l n c }" + sectionC3 + ] + + ] + ] + + + +newline1 :: Assertion +newline1 = "\n" ==> [EmptyN 0, EmptyN 0] + +newline2 :: Assertion +newline2 = " \n " ==> [EmptyN 1, EmptyN 2] + +newline3 :: Assertion +newline3 = " \n \n \n \n" ==> [EmptyN 4, EmptyN 2, EmptyN 3, EmptyN 1, EmptyN 0] + + + +comment1 :: Assertion +comment1 = "--c{m:e}t" ==> [CommentN $ Comment 0 0 "c{m:e}t"] + +comment2 :: Assertion +comment2 = "--comment" ==> [CommentN $ Comment 0 0 "comment"] + +comment3 :: Assertion +comment3 = " -- com ment" ==> [CommentN $ Comment 1 2 "com ment"] + +comment4 :: Assertion +comment4 = + " -- this \n -- that\n" + ==> [ CommentN (Comment 4 2 "this ") + , CommentN (Comment 3 1 "that") + , EmptyN 0 + ] + + + +fieldN1 :: Assertion +fieldN1 = + "field:" ==> [ Field 0 "field" 0 $ + NormalF (Contents (EmptyI 0) []) + ] + +fieldN2 :: Assertion +fieldN2 = + " field :\n" + ==> [ Field 1 "field" 2 $ + NormalF (Contents (EmptyI 0) []) + , EmptyN 0 + ] + +fieldN3 :: Assertion +fieldN3 = + "field: -- comment\n" + ==> [ Field 0 "field" 0 $ + NormalF (Contents (Inline 1 "-- comment") []) + , EmptyN 0 + ] + +fieldN4 :: Assertion +fieldN4 = + "field: -- comment\n -- comment \n" + ==> [ Field 0 "field" 0 $ + NormalF (Contents (Inline 4 "-- comment") []) + , CommentN $ Comment 2 1 "comment " + , EmptyN 0 + ] + +fieldN5 :: Assertion +fieldN5 = + "field: -- comment\n \n \n foo" + ==> [ Field 0 "field" 0 $ + NormalF $ Contents (Inline 4 "-- comment") + [ EmptyL 2 + , EmptyL 1 + , Line 1 "foo" + ] + ] + +fieldN6 :: Assertion +fieldN6 = + "field: \n \n -- comment \nfoo:" + ==> [ Field 0 "field" 0 $ + NormalF (Contents (EmptyI 2) []) + , EmptyN 3 + , CommentN $ Comment 2 1 "comment " + , Field 0 "foo" 0 $ + NormalF (Contents (EmptyI 0) []) + ] + + +fieldC1 :: Assertion +fieldC1 = + "field:{}" + ==> [ Field 0 "field" 0 $ + CurlF [EmptyF 0] (Contents (EmptyI 0) []) + ] + +fieldC2 :: Assertion +fieldC2 = + " field : { }" + ==> [ Field 1 "field" 2 $ + CurlF [EmptyF 3] (Contents (EmptyI 4) []) + ] + +fieldC3 :: Assertion +fieldC3 = + "foo: -- bar \n { ba{z: \n -- th is \n}" + ==> [ Field 0 "foo" 0 $ + CurlF + [ CommentF (Comment 1 2 "bar ") + , EmptyF 1 + ] + $ Contents (Inline 2 "ba{z: ") + [ CommentL (Comment 2 3 "th is ") + , EmptyL 0 + ] + ] + + + +sectionN1 :: Assertion +sectionN1 = + "section" ==> [ Section 0 "section" $ + NormalS (EmptyF 0) [] + ] + +sectionN2 :: Assertion +sectionN2 = + " section \n" + ==> [ Section 1 "section" $ + NormalS (EmptyF 2) [] + , EmptyN 0 + ] + +sectionN3 :: Assertion +sectionN3 = + "section -- comment\n" + ==> [ Section 0 "section" $ + NormalS (CommentF $ Comment 1 2 "comment") [] + , EmptyN 0 + ] + +sectionN4 :: Assertion +sectionN4 = + "section -- comment\n -- comment \n" + ==> [ Section 0 "section" $ + NormalS (CommentF $ Comment 4 3 "comment") [] + , CommentN $ Comment 2 1 "comment " + , EmptyN 0 + ] + +sectionN5 :: Assertion +sectionN5 = + "section -- comment\n \n \n foo" + ==> [ Section 0 "section" $ + NormalS (CommentF $ Comment 4 3 "comment") + [ EmptyN 2 + , EmptyN 1 + , Section 1 "foo" $ + NormalS (EmptyF 0) [] + ] + ] + +sectionN6 :: Assertion +sectionN6 = + "section \n \n -- comment \nfoo:" + ==> [ Section 0 "section" $ + NormalS (EmptyF 2) [] + , EmptyN 3 + , CommentN $ Comment 2 1 "comment " + , Field 0 "foo" 0 $ + NormalF (Contents (EmptyI 0) []) + ] + + +sectionC1 :: Assertion +sectionC1 = + "field:{}" ==> [ Field 0 "field" 0 $ + CurlF [EmptyF 0] (Contents (EmptyI 0) []) + ] + +sectionC2 :: Assertion +sectionC2 = + " field : { }" + ==> [ Field 1 "field" 2 $ + CurlF [EmptyF 3] (Contents (EmptyI 4) []) + ] + +sectionC3 :: Assertion +sectionC3 = + "foo: -- bar \n { ba{z: \n -- th is \n}" + ==> [ Field 0 "foo" 0 $ + CurlF + [ CommentF (Comment 1 2 "bar ") + , EmptyF 1 + ] + $ Contents (Inline 2 "ba{z: ") + [ CommentL (Comment 2 3 "th is ") + , EmptyL 0 + ] + ] diff --git a/Cabal-layout/test/strictness/Test/Strictness/Layout.hs b/Cabal-layout/test/strictness/Test/Strictness/Layout.hs new file mode 100644 index 00000000000..eea12914ac8 --- /dev/null +++ b/Cabal-layout/test/strictness/Test/Strictness/Layout.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE DerivingStrategies + , GeneralizedNewtypeDeriving + , StandaloneDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Strictness.Layout () where + +import Codec.Manifest.Cabal.Internal.Layout + +import NoThunks.Class + + + +instance NoThunks Offset where + wNoThunks ctx (Offset off) = wNoThunks ctx off + showTypeOf _ = "Offset" + +instance NoThunks Whitespace where + wNoThunks ctx (Whitespace space) = wNoThunks ctx space + showTypeOf _ = "Whitespace" + + +instance NoThunks Comment where + wNoThunks ctx (Comment space0 space1 comment space2) = + allNoThunks + [ noThunks ("(0)":ctx) space0 + , noThunks ("(1)":ctx) space1 + , noThunks ctx comment + , noThunks ("(2)":ctx) space2 + ] + + showTypeOf _ = "Comment" + + +instance NoThunks Heading where + wNoThunks ctx (Heading heading) = wNoThunks ctx heading + showTypeOf _ = "Heading" + +instance NoThunks Name where + wNoThunks ctx (Name name) = wNoThunks ctx name + showTypeOf _ = "Name" + + + +instance NoThunks Inline where + wNoThunks ctx inline = + case inline of + Inline space0 text space1 -> + allNoThunks + [ noThunks ("{I}":"(0)":ctx) space0 + , noThunks ("{I}":ctx) text + , noThunks ("{I}":"(1)":ctx) space1 + ] + + EmptyI space -> noThunks ("{E}":ctx) space + + showTypeOf _ = "Inline" + + +instance NoThunks Line where + wNoThunks ctx line = + case line of + Line off text space -> + allNoThunks + [ noThunks ("{L}":ctx) off + , noThunks ("{L}":ctx) text + , noThunks ("{L}":ctx) space + ] + + CommentL comment -> wNoThunks ("{C}":ctx) comment + + EmptyL space -> noThunks ("{E}":ctx) space + + showTypeOf _ = "Line" + + +instance NoThunks Filler where + wNoThunks ctx filler = + case filler of + CommentF comment -> wNoThunks ("{C}":ctx) comment + + EmptyF space -> noThunks ("{E}":ctx) space + + showTypeOf _ = "Filler" + + +newtype List a = List [a] + +instance NoThunks a => NoThunks (List a) where + wNoThunks ctx (List xs) = + let brackets :: Int -> String + brackets n = showChar '[' . shows n $ showChar ']' [] + + in allNoThunks . fmap (\(n, x) -> wNoThunks (brackets n : ctx) x) $ zip [0 :: Int ..] xs + + showTypeOf _ = "List" + + +instance NoThunks Section where + wNoThunks ctx section = + case section of + CurlS fillers nodes -> + allNoThunks + [ wNoThunks ("{C}":ctx) (List fillers) + , wNoThunks ("{C}":ctx) (List nodes) + ] + + NormalS inline nodes -> + allNoThunks + [ wNoThunks ("{N}":ctx) inline + , wNoThunks ("{N}":ctx) (List nodes) + ] + + showTypeOf _ = "Section" + + +instance NoThunks Contents where + wNoThunks ctx (Contents inline lines_) = + allNoThunks + [ wNoThunks ("<0>":ctx) inline + , wNoThunks ("<1>":ctx) (List lines_) + ] + + showTypeOf _ = "Contents" + +instance NoThunks Field where + wNoThunks ctx field = + case field of + CurlF fillers contents -> + allNoThunks + [ wNoThunks ("{C}":ctx) (List fillers) + , wNoThunks ("{C}":ctx) contents + ] + + NormalF contents -> wNoThunks ("{N}":ctx) contents + + showTypeOf _ = "Field" + + +instance NoThunks Node where + wNoThunks ctx node = + case node of + Section off heading section -> + allNoThunks + [ noThunks ("{S}":ctx) off + , noThunks ("{S}":ctx) heading + , wNoThunks ("{S}":ctx) section + ] + + Field off name space field -> + allNoThunks + [ noThunks ("{F}":ctx) off + , noThunks ("{F}":ctx) name + , noThunks ("{F}":ctx) space + , wNoThunks ("{F}":ctx) field + ] + + CommentN comment -> wNoThunks ("{C}":ctx) comment + EmptyN space -> noThunks ("{E}":ctx) space + + showTypeOf _ = "Node" + + +instance NoThunks Layout where + wNoThunks ctx (Layout nodes) = wNoThunks ctx (List nodes) + showTypeOf _ = "Layout" diff --git a/cabal.project b/cabal.project index f98fec9889b..e2a07246e9a 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,7 @@ packages: Cabal/ packages: cabal-testsuite/ packages: Cabal-syntax/ +packages: Cabal-layout/ packages: cabal-install/ packages: cabal-install-solver/ packages: solver-benchmarks/