tilia-0.1.2.0: tests/Tilia/CppSpec.hs
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Whether documents printed from different configurations line up.
module Tilia.CppSpec (spec) where
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (isJust, maybeToList)
import Data.Text (Text)
import Data.Text qualified as T
import Test.Hspec
import Tilia.Cpp
import Tilia.Cpp.Directives (implied)
import Tilia.Cpp.Place (regionsIn)
import Tilia.Doc.Internal (Doc)
import Tilia.Equivalence (syntaxDifference)
import Tilia.Parser (parseModule, pmModule)
import Tilia.Render (defaultRenderConfig, renderModule)
import Tilia.Source (directiveOnLine)
import Tilia.Span (Span)
import Tilia.TestUtils
( configurations,
countLeaves,
defaultParserConfig,
leaves,
linearLeaves,
)
-- | Format a module which uses the C preprocessor, configured with nothing.
formatCpp :: Text -> Either Text Text
formatCpp = said . formatWithCpp defaultParserConfig defaultRenderConfig "example.hs"
spec :: Spec
spec = do
describe "matching configurations before and after formatting" $ do
it "does not mistake different whitespace for another configuration" $ do
let input = "module M where\n#if FLAG\nf=1\n#else\nf = 1\n#endif\n"
(said (correspondingBranches input "module M where\nf = 1\n") >>= mapM_ sameBranch)
`shouldBe` Right ()
it "keeps branch identity when sorting the source text would swap it" $ do
let input = "module M where\n#if FLAG\nf=1\n#else\nf = 2\n#endif\n"
output = "module M where\n#if FLAG\nf = 1\n#else\nf = 2\n#endif\n"
(said (correspondingBranches input output) >>= mapM_ sameBranch) `shouldBe` Right ()
it "detects moving an error to a different branch" $ do
let input = "module M where\n#if FLAG\n#error no\n#else\nf = 1\n#endif\n"
output = "module M where\n#if FLAG\nf = 1\n#else\n#error no\n#endif\n"
(said (correspondingBranches input output) >>= mapM_ sameBranch) `shouldSatisfy` isLeft
describe "splitting a module on its conditional" $ do
it "keeps the directive as written, keyword and all" $
cfgGuards <$> configurations atDeclarations
`shouldBe` Just (fmap Guard ["ifdef FOO"])
it "keeps every line where it was" $
let sameLength c = all ((== length (T.lines atDeclarations)) . length . T.lines) (cfgTexts c)
in (sameLength <$> configurations atDeclarations) `shouldBe` Just True
it "has one more configuration than it has directives" $
let balanced c = length (cfgTexts c) == length (cfgGuards c) + 1
in fmap (fmap balanced . configurations) [atDeclarations, withoutElse, withElif]
`shouldBe` [Just True, Just True, Just True]
it "finds every directive of an #elif chain, in order" $
cfgGuards <$> configurations withElif
`shouldBe` Just (fmap Guard ["if A", "elif B"])
it "takes only the outermost conditional, leaving the nested one alone" $
cfgGuards <$> configurations nested
`shouldBe` Just (fmap Guard ["if OUTER"])
it "takes only the first of two conditionals side by side" $
cfgGuards <$> configurations twoConditionals
`shouldBe` Just (fmap Guard ["if FIRST"])
it "declines a module with no conditional at all" $
configurations "module M where\nf = 1\n" `shouldBe` Nothing
describe "the regions the conditional does not touch" $ do
it "are most of the module, so the comparison is not vacuous" $
overlap atDeclarations `shouldSatisfy` either (const False) (> 10)
it "print identically in every configuration, at a declaration boundary" $
disagreements atDeclarations `shouldBe` Right []
it "print identically when the branches are of different lengths" $
disagreements unevenBranches `shouldBe` Right []
it "print identically when a comment sits next to the conditional" $
disagreements withComments `shouldBe` Right []
it "print identically when a comment lives inside one branch" $
disagreements commentInsideBranch `shouldBe` Right []
it "print identically with nothing to separate the conditional" $
disagreements packedTogether `shouldBe` Right []
it "print identically when the conditional has no alternative" $
disagreements withoutElse `shouldBe` Right []
it "print identically across all three branches of an #elif" $
disagreements withElif `shouldBe` Right []
describe "conditionals nested inside one another"
$ it "reach three leaf configurations rather than four"
$ said (length <$> leaves nested) `shouldBe` Right 3
describe "several conditionals side by side" $ do
it "multiply, as configurations" $
said (length <$> leaves twoConditionals) `shouldBe` Right 4
it "add, as formattings: twenty of them are twenty-one, not a million" $
formatCpp (sideBySide 20) `shouldSatisfy` isRight
it "cost only the declarations each of them reaches" $
formatCpp (apart 400) `shouldSatisfy` isRight
it "are refused once even the sum is more than the budget allows" $
formatCpp (oneDeclaration 100 1000) `shouldSatisfy` isLeft
describe "counting the configurations" $ do
it "agrees with enumerating them, where enumerating them is possible" $
let counted m = (said (countLeaves m), said (toInteger . length <$> leaves m))
in fmap
counted
[ atDeclarations,
withElif,
elifWithoutElse,
withoutElse,
nested,
twoConditionals,
sideBySide 8
]
`shouldSatisfy` all (uncurry (==))
it "does not enumerate them, where enumerating them is not" $
said (countLeaves (sideBySide 63)) `shouldBe` Right (2 ^ (63 :: Int))
it "counts two conditionals behind one guard as one conditional" $
said (countLeaves (sameGuard 20)) `shouldBe` Right 2
describe "one guard asked at two depths" $ do
it "is one question, however deep the second asking is" $
said (countLeaves guardAtTwoDepths) `shouldBe` Right 4
it "counts what enumerating them produces" $
(said (countLeaves guardAtTwoDepths), said (toInteger . length <$> leaves guardAtTwoDepths))
`shouldSatisfy` uncurry (==)
it "is never answered one way at the top and the other way inside" $
said (leaves guardAtTwoDepths)
`shouldSatisfy` either
(const False)
(all (\l -> not ("inner" `T.isInfixOf` l) || "outer" `T.isInfixOf` l))
describe "what answers imply about the macros" $ do
it "rules out an #if X holding where #ifdef X fails" $
implied [([Guard "ifdef X"], 1), ([Guard "if X"], 0)] `shouldBe` Nothing
it "allows an #if X failing where #ifdef X holds, as X defined as 0" $
implied [([Guard "ifdef X"], 0), ([Guard "if X"], 1)] `shouldSatisfy` isJust
it "rules out #ifdef X and #ifndef X both holding" $
implied [([Guard "ifdef X"], 0), ([Guard "ifndef X"], 0)] `shouldBe` Nothing
it "takes an #if 0 to ask something, as code is put aside with it" $
implied [([Guard "if 0"], 0)] `shouldSatisfy` isJust
it "rules out a version below one and at least a later one" $
implied
[ ([Guard "if MIN_VERSION_base(4,10,0)"], 1),
([Guard "if MIN_VERSION_base(4,11,0)"], 0)
]
`shouldBe` Nothing
it "allows a version at least one and below a later one" $
implied
[ ([Guard "if MIN_VERSION_base(4,10,0)"], 0),
([Guard "if MIN_VERSION_base(4,11,0)"], 1)
]
`shouldSatisfy` isJust
it "takes a version with zeros at its end for the same version" $
implied
[ ([Guard "if MIN_VERSION_base(4,10)"], 0),
([Guard "if MIN_VERSION_base(4,10,0)"], 1)
]
`shouldBe` Nothing
it "rules out a range whose bound another answer contradicts" $
implied
[ ([Guard "if MIN_VERSION_base(4,10,0)"], 1),
([Guard "if MIN_VERSION_base(4,10,0) && !(MIN_VERSION_base(4,12,0))"], 0)
]
`shouldBe` Nothing
it "rules out a compiler below one version and at least a later one" $
implied
[ ([Guard "if __GLASGOW_HASKELL__ >= 908", Guard "elif __GLASGOW_HASKELL__ >= 906"], 2),
([Guard "if __GLASGOW_HASKELL__ > 906"], 0)
]
`shouldBe` Nothing
describe "configurations no definition of the macros gives" $ do
it "are left out of every configuration of a module" $
said (length <$> leaves askedTwoWays) `shouldBe` Right 3
it "are left out of what is compared before and after formatting" $
(all parses . concatMap (maybeToList . fst) <$> said (correspondingBranches askedTwoWays askedTwoWays))
`shouldBe` Right True
it "are not taken to cover a branch" $
(all parses <$> said (branchLeaves askedTwoWays)) `shouldBe` Right True
describe "covering every branch" $ do
it "gives a module with no conditionals one configuration, its own" $
said (length <$> branchLeaves "module M where\nx = 1\n") `shouldBe` Right 1
it "gives one per branch of a conditional" $ do
said (length <$> branchLeaves "module M where\n#if A\nx = 1\n#endif\n") `shouldBe` Right 2
said (length <$> branchLeaves "module M where\n#if A\nx = 1\n#else\nx = 2\n#endif\n")
`shouldBe` Right 2
-- A module written on Windows ends every line with a carriage return,
-- @#endif@ included, and one that closes no group leaves the whole
-- module unsplittable. Every module of @crypton-pem@ is written this
-- way, and refusing them refused everything that reads a certificate.
it "gives one per branch when the lines end in a carriage return" $
said (length <$> branchLeaves "module M where\r\n#if A\r\nx = 1\r\n#else\r\nx = 2\r\n#endif\r\n")
`shouldBe` Right 2
it "is their sum where enumerating them would be their product" $
(said (length <$> branchLeaves (sideBySide 20)), said (countLeaves (sideBySide 20)))
`shouldBe` (Right 21, Right (2 ^ (20 :: Int)))
describe "parsing every branch" $ do
it "parses branches that parse together as one module" $
branchesParsed atDeclarations `shouldBe` Just 1
it "parses alternatives that do not parse together a branch leaf at a time" $
branchesParsed alternatives `shouldBe` Just 2
it "leaves out a branch leaf that does not parse" $
branchesParsed oneAlternativeParses `shouldBe` Just 1
it "has nothing where no branch leaf parses" $
branchesParsed noAlternativeParses `shouldBe` Nothing
describe "varying one conditional at a time" $ do
it "is the baseline and one configuration per further branch" $
said (length <$> linearLeaves (sideBySide 63)) `shouldBe` Right 64
it "agrees with enumerating them where a module has one conditional" $
(said (linearLeaves atDeclarations), said (leaves atDeclarations))
`shouldSatisfy` uncurry (==)
describe "directives it cannot read" $ do
it "refuses a module whose conditionals do not balance" $
formatCpp unbalanced `shouldBe` Left "the #ifdef at line 3 is never closed"
it "refuses an #endif with no conditional to close" $
formatCpp strayEndif `shouldBe` Left "the #endif at line 4 has no conditional to belong to"
it "refuses an #else that comes before an #elif" $
formatCpp elseBeforeElif
`shouldBe` Left "the #elif at line 7 comes after the #else of its conditional"
it "refuses a directive inside a quasiquote" $
formatCpp includeInQuasiquote
`shouldBe` Left "the #include at line 7 is inside a quasi-quote or a multi-line string"
it "refuses an alternative aborting with #error that it cannot format" $
formatCpp abortingAlternative
`shouldBe` Left "the alternative that the #error at line 7 aborts cannot be formatted without parsing it"
it "refuses a branch that a conditional around it asking the same question rules out" $
formatCpp ruledOut
`shouldBe` Left "the branch at line 6 is ruled out by a conditional around it that asks the same question"
describe "telling a directive line from code" $ do
it "reads the keyword and everything after the hash" $
directiveOnLine " # if FOO" `shouldBe` Just ("if", "if FOO")
it "does not take a label at the start of a line for a directive" $
directiveOnLine " #field" `shouldBe` Nothing
----------------------------------------------------------------------------
-- The modules the question is asked of
-- | A conditional between two whole declarations, which is the case the
-- design is meant to handle.
atDeclarations :: Text
atDeclarations =
T.unlines
[ "module M where",
"",
"before :: Int",
"before = 1",
"",
"#ifdef FOO",
"mid :: Int",
"mid = 2",
"#else",
"mid :: Int",
"mid = 3",
"#endif",
"",
"after :: Int",
"after = 4"
]
-- | Branches that print to different numbers of lines, so that anything
-- downstream of them would shift if positions were being followed.
unevenBranches :: Text
unevenBranches =
T.unlines
[ "module M where",
"",
"before = 1",
"",
"#ifdef FOO",
"mid = case x of",
" A -> 1",
" B -> 2",
"#else",
"mid = 3",
"#endif",
"",
"after = 4"
]
-- | A comment inside one branch and not the other. Comment placement reads
-- every region in the document, so the declarations outside the conditional
-- are being asked about under two different comment streams.
commentInsideBranch :: Text
commentInsideBranch =
T.unlines
[ "module M where",
"",
"before = 1",
"",
"#ifdef FOO",
"-- a note only this branch has",
"mid = 2 -- and a trailing one",
"#else",
"mid = 3",
"#endif",
"",
"after = 4"
]
-- | No blank lines anywhere, so that whether one is printed between
-- declarations is decided by what lies between their spans.
packedTogether :: Text
packedTogether =
T.unlines
[ "module M where",
"before = 1",
"#ifdef FOO",
"mid = 2",
"#else",
"mid = 3",
"#endif",
"after = 4"
]
-- | A comment on either side of the conditional. Comment attachment reads
-- the whole document, so this is where context-sensitivity would show.
withComments :: Text
withComments =
T.unlines
[ "module M where",
"",
"-- above",
"before = 1 -- trailing",
"",
"#ifdef FOO",
"mid = 2",
"#else",
"mid = 3",
"#endif",
"",
"-- below",
"after = 4"
]
-- | A conditional with no alternative, which is what most conditionals in
-- real Haskell source are: a @MIN_VERSION@ test around a definition that
-- newer or older compilers do not want.
withoutElse :: Text
withoutElse =
T.unlines
[ "module M where",
"",
"before = 1",
"",
"#if MIN_VERSION_base(4,19,0)",
"mid = 2",
"#endif",
"",
"after = 4"
]
-- | Three branches, so that the choice is genuinely n-ary and not a pair
-- with extra steps.
withElif :: Text
withElif =
T.unlines
[ "module M where",
"",
"before = 1",
"",
"#if A",
"mid = 1",
"#elif B",
"mid = 2",
"#else",
"mid = 3",
"#endif",
"",
"after = 4"
]
-- | An @#elif@ chain that stops without an @#else@, so that the last
-- configuration is the one where nothing at all is taken.
elifWithoutElse :: Text
elifWithoutElse =
T.unlines
[ "module M where",
"",
"#if A",
"mid = 1",
"#elif B",
"mid = 2",
"#endif",
"",
"after = 4"
]
-- | A conditional inside a branch of another, which the splitter must leave
-- to the recursion rather than read as a chain.
nested :: Text
nested =
T.unlines
[ "module M where",
"",
"#if OUTER",
"a = 1",
"#if INNER",
"b = 2",
"#endif",
"#else",
"a = 3",
"#endif",
"",
"after = 4"
]
-- | Two conditionals with a declaration between them, neither inside the
-- other.
twoConditionals :: Text
twoConditionals =
T.unlines
[ "module M where",
"",
"#if FIRST",
"a = 1",
"#else",
"a = 2",
"#endif",
"",
"between = 0",
"",
"#if SECOND",
"b = 1",
"#endif",
"",
"after = 4"
]
-- | A module with @n@ conditionals in a row, for asking where the budget
-- stops.
sideBySide :: Int -> Text
sideBySide n =
T.unlines $
["module M where", ""]
<> concat
[ [ "#if C" <> T.pack (show i),
"x" <> T.pack (show i) <> " = 1",
"#else",
"x" <> T.pack (show i) <> " = 2",
"#endif"
]
| i <- [1 .. n]
]
-- | A module with @n@ conditionals, each around a declaration of its own
-- and kept apart from the next by one that is not.
apart :: Int -> Text
apart n =
T.unlines $
["module M where", ""]
<> concat
[ [ "#if C" <> T.pack (show i),
"x" <> T.pack (show i) <> " = 1",
"#else",
"x" <> T.pack (show i) <> " = 2",
"#endif",
"",
"y" <> T.pack (show i) <> " = 0",
""
]
| i <- [1 .. n]
]
-- | A module with one declaration holding @n@ conditionals and @m@ lines
-- that are in every configuration.
oneDeclaration :: Int -> Int -> Text
oneDeclaration n m =
T.unlines $
["module M where", "", "x =", " [ 0"]
<> concat
[ ["#if C" <> T.pack (show i), " , 1", "#endif"]
| i <- [1 .. n]
]
<> replicate m " , 0"
<> [" ]"]
-- | A module with @n@ conditionals in a row, all asking the same question.
--
-- Which makes them one question, however many times it is written down. The
-- shape a module reaches by being formatted, since aligning the alternatives
-- can leave one conditional printed as several.
sameGuard :: Int -> Text
sameGuard n =
T.unlines $
["module M where", ""]
<> concat
[ [ "#if C",
"x" <> T.pack (show i) <> " = 1",
"#else",
"x" <> T.pack (show i) <> " = 2",
"#endif"
]
| i <- [1 .. n]
]
-- | One guard asked twice, once at the top level and once inside another
-- conditional's branch.
--
-- Untied this has six configurations where it has four, and one of the two
-- extra ones answers @A@ both ways at once.
guardAtTwoDepths :: Text
guardAtTwoDepths =
T.unlines
[ "module M where",
"",
"#if A",
"outer = 1",
"#endif",
"",
"#ifdef B",
"beside = 2",
"#if A",
"inner = 3",
"#endif",
"#endif"
]
-- | A conditional around two alternatives, which do not parse one after the
-- other.
alternatives :: Text
alternatives =
T.unlines
[ "module M where",
"",
"g =",
"#ifdef CHECK",
" id $",
" do",
" print 1",
"#else",
" do",
" print 1",
"#endif"
]
-- | An @#ifdef@ around a pragma, and an @#if@ asking about the same macro
-- around code that needs the pragma, so that no configuration takes the
-- code without the pragma.
askedTwoWays :: Text
askedTwoWays =
T.unlines
[ "{-# LANGUAGE CPP #-}",
"#ifdef USE_ST",
"{-# LANGUAGE RankNTypes #-}",
"#endif",
"module M where",
"#if USE_ST",
"run :: (forall s. s -> s) -> Int",
"run f = f 1",
"#endif"
]
-- | Two alternatives, only one of which parses.
oneAlternativeParses :: Text
oneAlternativeParses =
T.unlines ["module M where", "", "#ifdef FOO", "f = 1", "#else", "f = (", "#endif"]
-- | Two alternatives, neither of which parses.
noAlternativeParses :: Text
noAlternativeParses =
T.unlines ["module M where", "", "#ifdef FOO", "f = (", "#else", "f = [", "#endif"]
-- | An @#if@ with nothing to close it.
unbalanced :: Text
unbalanced = T.unlines ["module M where", "", "#ifdef FOO", "f = 1"]
-- | An @#endif@ with nothing to close.
strayEndif :: Text
strayEndif = T.unlines ["module M where", "", "f = 1", "#endif"]
-- | A directive that the preprocessor acts on although it is written inside
-- a quasiquote, which is reproduced verbatim.
includeInQuasiquote :: Text
includeInQuasiquote =
T.unlines
[ "{-# LANGUAGE QuasiQuotes #-}",
"",
"module M where",
"",
"banner =",
" [template|",
"#include \"banner.txt\"",
"|]"
]
-- | An alternative that aborts with @#error@ and leaves an expression
-- unfinished, in a module whose conditionals cannot be varied one at a
-- time.
abortingAlternative :: Text
abortingAlternative =
T.unlines
[ "module M where",
"",
"f =",
"#if A",
" 1",
"#else",
"#error \"b\"",
"#endif",
" + 2",
"#if A",
"g = 1",
"#endif"
]
-- | An @#else@ that the @#if@ around it rules out, which no configuration
-- takes.
ruledOut :: Text
ruledOut =
T.unlines
[ "module M where",
"",
"#if FLAG",
"#if FLAG",
"f = 1",
"#else",
"f = 2",
"#endif",
"#endif"
]
-- | An @#else@ with an @#elif@ after it, which no preprocessor would accept
-- and which the splitter must not quietly reorder into something it would.
elseBeforeElif :: Text
elseBeforeElif =
T.unlines
[ "module M where",
"",
"#if A",
"f = 1",
"#else",
"f = 2",
"#elif B",
"f = 3",
"#endif"
]
----------------------------------------------------------------------------
-- Asking it
isLeft, isRight :: Either a b -> Bool
isLeft = either (const True) (const False)
isRight = either (const False) (const True)
sameBranch :: (Maybe Text, Maybe Text) -> Either Text ()
sameBranch (Nothing, Nothing) = Right ()
sameBranch (Just input, Just output) = sameProgram input output
where
sameProgram before' after' = do
a <- moduleOf before'
b <- moduleOf after'
case syntaxDifference a b of
Nothing -> Right ()
Just difference -> Left ("a different program: " <> difference)
moduleOf text = case parseModule defaultParserConfig "<cpp>" text of
Left _ -> Left ("did not parse:\n" <> text)
Right parsed -> Right (pmModule parsed)
sameBranch _ = Left "preprocessing changed between succeeding and failing"
-- | Does a configuration parse, with what its own pragmas turn on?
parses :: Text -> Bool
parses t = either (const False) (const True) (parseModule defaultParserConfig "example.hs" t)
-- | How many modules parsing every branch of a module comes to.
branchesParsed :: Text -> Maybe Int
branchesParsed = fmap length . everyBranch defaultParserConfig "example.hs"
-- | A refusal as words, which is the only place these tests want one.
said :: Either CppError a -> Either Text a
said = either (Left . describeCppError) Right
-- | The spans every configuration printed, but did not all print alike.
--
-- 'Left' when a configuration did not parse or the module had no
-- conditional, so that a broken fixture is not mistaken for agreement.
disagreements :: Text -> Either String [Span]
disagreements = fmap (Map.keys . Map.filter not) . agreement
-- | How many spans every configuration printed.
overlap :: Text -> Either String Int
overlap = fmap Map.size . agreement
-- | The spans every configuration of a module's first conditional printed,
-- and whether they all printed them alike.
agreement :: Text -> Either String (Map.Map Span Bool)
agreement source = do
c <- maybe (Left "no conditional") Right (configurations source)
docs <- traverse documentOf (cfgTexts c)
case fmap regions docs of
[] -> Left "a conditional with no branches"
(first' : rest) -> Right (foldl' (narrow first') (True <$ first') rest)
where
narrow first' acc other =
Map.intersectionWith (&&) acc (Map.intersectionWith (==) first' other)
documentOf :: Text -> Either String Doc
documentOf source = case parseModule defaultParserConfig "<cpp>" source of
Left _ -> Left ("did not parse:\n" <> T.unpack source)
Right parsed -> Right (renderModule defaultRenderConfig parsed)
-- | Every region a document records provenance for, with what was printed
-- there.
--
-- The outermost wins where a span appears twice, which is the one
-- 'Tilia.Comments.Attach.attachComments' gives a comment to.
regions :: Doc -> Map Span Doc
regions = Map.fromListWith (\_ outer -> outer) . regionsIn