scripths 0.5.3.1 → 0.5.4.1

raw patch · 3 files changed

+101/−2 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• scripths.cabal +1/−1
• src/ScriptHs/Render.hs +39/−1
• test/Test/Render.hs +61/−0

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               scripths-version:            0.5.3.1+version:            0.5.4.1 synopsis:           GHCi scripts for standalone execution and Markdown documentation. description:        GHCi scripts for standalone execution (with dependency resolution) and Markdown documentation (produces inline output). homepage:           https://www.datahaskell.org/

@@ -31,7 +31,9 @@     Kind (..),     Piece (..),     toPieces,+    mergePieces,     classify,+    bindStatementBody,     lineText,     unRewriteSplice, ) where@@ -160,8 +162,44 @@     let s = T.stripStart t      in "$(" `T.isPrefixOf` s || "_ = ();" `T.isPrefixOf` s +{- | A statement binds monadically when @<-@ separates a pattern from an+expression at the STATEMENT level. Defined through 'bindStatementBody' so the+classifier and the extractor can never disagree about which arrow binds.+-} isIOBindLead :: Text -> Bool-isIOBindLead = T.isInfixOf "<-"+isIOBindLead = isJust . bindStatementBody++{- | The expression a monadic bind runs, with its pattern dropped: the text+after the statement-level @<-@, or 'Nothing' when the line binds nothing. An+arrow nested inside brackets belongs to a list comprehension or an inline+@do@, and one inside a literal is text; neither binds a name a caller can use.+-}+bindStatementBody :: Text -> Maybe Text+bindStatementBody = scan (0 :: Int)+  where+    scan depth t = case T.uncons t of+        Nothing -> Nothing+        Just ('"', rest) -> scan depth (skipString rest)+        Just ('\'', rest) -> scan depth (skipChar rest)+        Just ('<', rest)+            | depth == 0+            , Just body <- T.stripPrefix "-" rest ->+                Just (T.strip body)+        Just (c, rest)+            | c `elem` ("([{" :: String) -> scan (depth + 1) rest+            | c `elem` (")]}" :: String) -> scan (depth - 1) rest+            | otherwise -> scan depth rest+    skipString t = case T.uncons t of+        Nothing -> t+        Just ('\\', rest) -> skipString (T.drop 1 rest)+        Just ('"', rest) -> rest+        Just (_, rest) -> skipString rest+    -- A quote opens a character literal only when one closes it right after+    -- the character; otherwise it is a prime in an identifier like @xs'@.+    skipChar t = case T.uncons t of+        Just ('\\', rest) -> T.drop 1 (T.dropWhile (/= '\'') rest)+        Just (_, rest) | "'" `T.isPrefixOf` rest -> T.drop 1 rest+        _ -> t  isDeclaration :: Text -> [Text] -> Bool isDeclaration leadText contTexts =

@@ -7,16 +7,20 @@ import qualified Data.Text as T import ScriptHs.Parser (CabalMeta (..), Line (..)) import ScriptHs.Render (+    Kind (..),     LhsBlock (..),     ModuleParts (..),+    Piece (..),     TrailKind (..),     actionExprs,+    bindStatementBody,     renderCabalScriptHeader,     renderLiterate,     renderModuleText,     toGhciScript,     toGhciScriptTagged,     toModule,+    toPieces,  )  renderTests :: TestTree@@ -45,6 +49,57 @@                 assertBool "has blank" (T.isInfixOf "\n\n" result || result == "\n")             ]         , testGroup+            "Monadic-bind classification: only a top-level `<-` binds"+            [ testCase "plain bind" $+                kindOf "x <- getLine" @?= Just KIOBind+            , testCase "pattern bind" $+                kindOf "Just y <- pure (Just 1)" @?= Just KIOBind+            , testCase "tuple pattern bind" $+                kindOf "(a, b) <- pure (1, 2)" @?= Just KIOBind+            , testCase "bind whose rhs holds a comprehension" $+                kindOf "ys <- pure [y | y <- [1, 2]]" @?= Just KIOBind+            , -- The live_test19 regression: a list comprehension's `<-` sits+              -- inside brackets and binds nothing at the statement level.+              testCase "comprehension is an action, not a bind" $+                kindOf "print [(x, sin x) | x <- [0, 0.01 .. 2]]" @?= Just KAction+            , testCase "comprehension inside a lambda is an action" $+                kindOf "animate 0 (\\t -> plot [(x, sin x) | x <- xs])"+                    @?= Just KAction+            , testCase "one-line do block is an action" $+                kindOf "mapM_ (\\n -> do { m <- pure n; print m }) [1]"+                    @?= Just KAction+            , testCase "arrow inside a string literal is an action" $+                kindOf "putStrLn \"x <- y\"" @?= Just KAction+            ]+        , testGroup+            "bindStatementBody: the expression a bind runs"+            [ testCase "drops a plain pattern" $+                bindStatementBody "x <- getLine" @?= Just "getLine"+            , testCase "drops a tuple pattern" $+                bindStatementBody "(a, b) <- pure (1, 2)" @?= Just "pure (1, 2)"+            , testCase "keeps a comprehension in the bound expression" $+                bindStatementBody "ys <- pure [y | y <- [1, 2]]"+                    @?= Just "pure [y | y <- [1, 2]]"+            , testCase "a non-bind has no body" $+                bindStatementBody "print [(x, y) | x <- xs]" @?= Nothing+            , -- The classifier and the extractor must never disagree: a line+              -- classified KIOBind is exactly one with a statement body.+              testCase "agrees with the classifier" $+                mapM_+                    ( \t ->+                        assertBool+                            (T.unpack t)+                            ((kindOf t == Just KIOBind) == (bindStatementBody t /= Nothing))+                    )+                    [ "x <- getLine"+                    , "Just y <- pure (Just 1)"+                    , "ys <- pure [y | y <- [1, 2]]"+                    , "print [(x, sin x) | x <- [0, 1]]"+                    , "animate 0 (\\t -> plot [(x, y) | x <- xs])"+                    , "putStrLn \"x <- y\""+                    ]+            ]+        , testGroup             "Isolation: one block per statement"             [ testCase "consecutive IO binds each get own block" $ do                 let result =@@ -641,6 +696,12 @@  nonEmpty :: Text -> [Text] nonEmpty = filter (not . T.null . T.strip) . T.lines++-- | The 'Kind' 'toPieces' assigns a single Haskell line.+kindOf :: Text -> Maybe Kind+kindOf src = case toPieces [HaskellLine src] of+    [PUnit k _] -> Just k+    _ -> Nothing  assertNotWrapped :: Text -> Assertion assertNotWrapped t =