{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RankNTypes         #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE TupleSections      #-}

module Ide.Plugin.Eval.Parse.Comments where

import qualified Control.Applicative.Combinators.NonEmpty as NE
import           Control.Arrow                            (first, (&&&), (>>>))
import           Control.Lens                             (lensField, lensRules,
                                                           view, (.~), (^.))
import           Control.Lens.Extras                      (is)
import           Control.Lens.TH                          (makeLensesWith,
                                                           makePrisms,
                                                           mappingNamer)
import           Control.Monad                            (guard, void, when)
import           Control.Monad.Combinators                ()
import           Control.Monad.Reader                     (ask)
import           Control.Monad.Trans.Reader               (Reader, runReader)
import qualified Data.Char                                as C
import qualified Data.DList                               as DL
import qualified Data.Foldable                            as F
import           Data.Function                            ((&))
import           Data.Functor                             ((<&>))
import           Data.Functor.Identity
import           Data.List.NonEmpty                       (NonEmpty ((:|)))
import qualified Data.List.NonEmpty                       as NE
import           Data.Map.Strict                          (Map)
import qualified Data.Map.Strict                          as Map
import qualified Data.Text                                as T
import           Data.Void                                (Void)
import           GHC.Generics                             hiding (UInt, to)
import           Ide.Plugin.Eval.Types
import qualified Language.LSP.Protocol.Lens               as L
import           Language.LSP.Protocol.Types

import qualified Text.Megaparsec                          as P
import           Text.Megaparsec
import           Text.Megaparsec.Char                     (alphaNumChar, char,
                                                           eol, hspace,
                                                           letterChar)

{-
We build parsers combining the following three kinds of them:

    *   Line parser - paring a single line into an input,
        works both for line- and block-comments.
        A line should be a proper content of lines contained in comment:
        doesn't include starting @--@ and @{\-@ and no ending @-\}@

    *   Line comment group parser: parses a contiguous group of
        tuples of position and line comment into sections of line comments.
        Each input MUST start with @--@.

    *   Block comment parser: Parsing entire block comment into sections.
        Input must be surrounded by @{\-@ and @-\}@.
-}

-- | Line parser
type LineParser a = forall m. Monad m => ParsecT Void String m a

-- | Line comment group parser
type LineGroupParser = Parsec Void [(Range, RawLineComment)]

data BlockEnv = BlockEnv
    { BlockEnv -> Bool
isLhs      :: Bool
    , BlockEnv -> Range
blockRange :: Range
    }
    deriving (Int -> BlockEnv -> ShowS
[BlockEnv] -> ShowS
BlockEnv -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockEnv] -> ShowS
$cshowList :: [BlockEnv] -> ShowS
show :: BlockEnv -> String
$cshow :: BlockEnv -> String
showsPrec :: Int -> BlockEnv -> ShowS
$cshowsPrec :: Int -> BlockEnv -> ShowS
Show, BlockEnv -> BlockEnv -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockEnv -> BlockEnv -> Bool
$c/= :: BlockEnv -> BlockEnv -> Bool
== :: BlockEnv -> BlockEnv -> Bool
$c== :: BlockEnv -> BlockEnv -> Bool
Eq, Eq BlockEnv
BlockEnv -> BlockEnv -> Bool
BlockEnv -> BlockEnv -> Ordering
BlockEnv -> BlockEnv -> BlockEnv
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BlockEnv -> BlockEnv -> BlockEnv
$cmin :: BlockEnv -> BlockEnv -> BlockEnv
max :: BlockEnv -> BlockEnv -> BlockEnv
$cmax :: BlockEnv -> BlockEnv -> BlockEnv
>= :: BlockEnv -> BlockEnv -> Bool
$c>= :: BlockEnv -> BlockEnv -> Bool
> :: BlockEnv -> BlockEnv -> Bool
$c> :: BlockEnv -> BlockEnv -> Bool
<= :: BlockEnv -> BlockEnv -> Bool
$c<= :: BlockEnv -> BlockEnv -> Bool
< :: BlockEnv -> BlockEnv -> Bool
$c< :: BlockEnv -> BlockEnv -> Bool
compare :: BlockEnv -> BlockEnv -> Ordering
$ccompare :: BlockEnv -> BlockEnv -> Ordering
Ord)

makeLensesWith
    (lensRules & lensField .~ mappingNamer (pure . (++ "L")))
    ''BlockEnv

-- | Block comment parser
type BlockCommentParser = ParsecT Void String (Reader BlockEnv)

-- | Prop line, with "prop>" stripped off
newtype PropLine = PropLine {PropLine -> String
getPropLine :: String}
    deriving (Int -> PropLine -> ShowS
[PropLine] -> ShowS
PropLine -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PropLine] -> ShowS
$cshowList :: [PropLine] -> ShowS
show :: PropLine -> String
$cshow :: PropLine -> String
showsPrec :: Int -> PropLine -> ShowS
$cshowsPrec :: Int -> PropLine -> ShowS
Show)

-- | Example line, with @>>>@ stripped off
newtype ExampleLine = ExampleLine {ExampleLine -> String
getExampleLine :: String}
    deriving (Int -> ExampleLine -> ShowS
[ExampleLine] -> ShowS
ExampleLine -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExampleLine] -> ShowS
$cshowList :: [ExampleLine] -> ShowS
show :: ExampleLine -> String
$cshow :: ExampleLine -> String
showsPrec :: Int -> ExampleLine -> ShowS
$cshowsPrec :: Int -> ExampleLine -> ShowS
Show)

data TestComment
    = AProp
        { TestComment -> Range
testCommentRange :: Range
        , TestComment -> PropLine
lineProp         :: PropLine
        , TestComment -> [String]
propResults      :: [String]
        }
    | AnExample
        { testCommentRange :: Range
        , TestComment -> NonEmpty ExampleLine
lineExamples     :: NonEmpty ExampleLine
        , TestComment -> [String]
exampleResults   :: [String]
        }
    deriving (Int -> TestComment -> ShowS
[TestComment] -> ShowS
TestComment -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestComment] -> ShowS
$cshowList :: [TestComment] -> ShowS
show :: TestComment -> String
$cshow :: TestComment -> String
showsPrec :: Int -> TestComment -> ShowS
$cshowsPrec :: Int -> TestComment -> ShowS
Show)

-- | Classification of comments
data CommentFlavour = Vanilla | HaddockNext | HaddockPrev | Named String
    deriving (ReadPrec [CommentFlavour]
ReadPrec CommentFlavour
Int -> ReadS CommentFlavour
ReadS [CommentFlavour]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CommentFlavour]
$creadListPrec :: ReadPrec [CommentFlavour]
readPrec :: ReadPrec CommentFlavour
$creadPrec :: ReadPrec CommentFlavour
readList :: ReadS [CommentFlavour]
$creadList :: ReadS [CommentFlavour]
readsPrec :: Int -> ReadS CommentFlavour
$creadsPrec :: Int -> ReadS CommentFlavour
Read, Int -> CommentFlavour -> ShowS
[CommentFlavour] -> ShowS
CommentFlavour -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CommentFlavour] -> ShowS
$cshowList :: [CommentFlavour] -> ShowS
show :: CommentFlavour -> String
$cshow :: CommentFlavour -> String
showsPrec :: Int -> CommentFlavour -> ShowS
$cshowsPrec :: Int -> CommentFlavour -> ShowS
Show, CommentFlavour -> CommentFlavour -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommentFlavour -> CommentFlavour -> Bool
$c/= :: CommentFlavour -> CommentFlavour -> Bool
== :: CommentFlavour -> CommentFlavour -> Bool
$c== :: CommentFlavour -> CommentFlavour -> Bool
Eq, Eq CommentFlavour
CommentFlavour -> CommentFlavour -> Bool
CommentFlavour -> CommentFlavour -> Ordering
CommentFlavour -> CommentFlavour -> CommentFlavour
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CommentFlavour -> CommentFlavour -> CommentFlavour
$cmin :: CommentFlavour -> CommentFlavour -> CommentFlavour
max :: CommentFlavour -> CommentFlavour -> CommentFlavour
$cmax :: CommentFlavour -> CommentFlavour -> CommentFlavour
>= :: CommentFlavour -> CommentFlavour -> Bool
$c>= :: CommentFlavour -> CommentFlavour -> Bool
> :: CommentFlavour -> CommentFlavour -> Bool
$c> :: CommentFlavour -> CommentFlavour -> Bool
<= :: CommentFlavour -> CommentFlavour -> Bool
$c<= :: CommentFlavour -> CommentFlavour -> Bool
< :: CommentFlavour -> CommentFlavour -> Bool
$c< :: CommentFlavour -> CommentFlavour -> Bool
compare :: CommentFlavour -> CommentFlavour -> Ordering
$ccompare :: CommentFlavour -> CommentFlavour -> Ordering
Ord)

-- | Single line or block comments?
data CommentStyle = Line | Block Range
    deriving (Int -> CommentStyle -> ShowS
[CommentStyle] -> ShowS
CommentStyle -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CommentStyle] -> ShowS
$cshowList :: [CommentStyle] -> ShowS
show :: CommentStyle -> String
$cshow :: CommentStyle -> String
showsPrec :: Int -> CommentStyle -> ShowS
$cshowsPrec :: Int -> CommentStyle -> ShowS
Show, CommentStyle -> CommentStyle -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommentStyle -> CommentStyle -> Bool
$c/= :: CommentStyle -> CommentStyle -> Bool
== :: CommentStyle -> CommentStyle -> Bool
$c== :: CommentStyle -> CommentStyle -> Bool
Eq, Eq CommentStyle
CommentStyle -> CommentStyle -> Bool
CommentStyle -> CommentStyle -> Ordering
CommentStyle -> CommentStyle -> CommentStyle
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CommentStyle -> CommentStyle -> CommentStyle
$cmin :: CommentStyle -> CommentStyle -> CommentStyle
max :: CommentStyle -> CommentStyle -> CommentStyle
$cmax :: CommentStyle -> CommentStyle -> CommentStyle
>= :: CommentStyle -> CommentStyle -> Bool
$c>= :: CommentStyle -> CommentStyle -> Bool
> :: CommentStyle -> CommentStyle -> Bool
$c> :: CommentStyle -> CommentStyle -> Bool
<= :: CommentStyle -> CommentStyle -> Bool
$c<= :: CommentStyle -> CommentStyle -> Bool
< :: CommentStyle -> CommentStyle -> Bool
$c< :: CommentStyle -> CommentStyle -> Bool
compare :: CommentStyle -> CommentStyle -> Ordering
$ccompare :: CommentStyle -> CommentStyle -> Ordering
Ord, forall x. Rep CommentStyle x -> CommentStyle
forall x. CommentStyle -> Rep CommentStyle x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CommentStyle x -> CommentStyle
$cfrom :: forall x. CommentStyle -> Rep CommentStyle x
Generic)

makePrisms ''CommentStyle

commentsToSections ::
    -- | True if it is literate Haskell
    Bool ->
    Comments ->
    Sections
commentsToSections :: Bool -> Comments -> Sections
commentsToSections Bool
isLHS Comments {Map Range RawLineComment
Map Range RawBlockComment
blockComments :: Comments -> Map Range RawBlockComment
lineComments :: Comments -> Map Range RawLineComment
blockComments :: Map Range RawBlockComment
lineComments :: Map Range RawLineComment
..} =
    let (Map Range (CommentFlavour, [TestComment])
lineSectionSeeds, Map Range (DList (CommentStyle, [TestComment]))
lineSetupSeeds) =
            forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
                ( \NonEmpty (Range, RawLineComment)
lcs ->
                    let theRan :: Range
theRan =
                            Position -> Position -> Range
Range
                                (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s a. HasStart s a => Lens' s a
L.start forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NE.head NonEmpty (Range, RawLineComment)
lcs)
                                (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s a. HasEnd s a => Lens' s a
L.end forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NE.last NonEmpty (Range, RawLineComment)
lcs)
                     in case forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
parseMaybe LineGroupParser
  (Maybe (CommentFlavour, [TestComment]), [TestComment])
lineGroupP forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Range, RawLineComment)
lcs of
                            Maybe (Maybe (CommentFlavour, [TestComment]), [TestComment])
Nothing -> forall a. Monoid a => a
mempty
                            Just (Maybe (CommentFlavour, [TestComment])
mls, [TestComment]
rs) ->
                                ( forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall k a. k -> a -> Map k a
Map.singleton) ((Range
theRan,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CommentFlavour, [TestComment])
mls)
                                , -- orders setup sections in ascending order
                                  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestComment]
rs
                                    then forall a. Monoid a => a
mempty
                                    else
                                        forall k a. k -> a -> Map k a
Map.singleton Range
theRan forall a b. (a -> b) -> a -> b
$
                                            forall a. a -> DList a
DL.singleton (CommentStyle
Line, [TestComment]
rs)
                                )
                )
                forall a b. (a -> b) -> a -> b
$ forall a. Map Range a -> [NonEmpty (Range, a)]
groupLineComments forall a b. (a -> b) -> a -> b
$
                    forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey
                        -- FIXME:
                        -- To comply with the initial behaviour of
                        -- Extended Eval Plugin;
                        -- but it also rejects modules with
                        -- non-zero base indentation level!
                        ( \Range
pos RawLineComment
_ ->
                            if Bool
isLHS
                                then Range
pos forall s a. s -> Getting a s a -> a
^. forall s a. HasStart s a => Lens' s a
L.start forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasCharacter s a => Lens' s a
L.character forall a. Eq a => a -> a -> Bool
== UInt
2
                                else Range
pos forall s a. s -> Getting a s a -> a
^. forall s a. HasStart s a => Lens' s a
L.start forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasCharacter s a => Lens' s a
L.character forall a. Eq a => a -> a -> Bool
== UInt
0
                        )
                        Map Range RawLineComment
lineComments
        (Map Range (CommentFlavour, [TestComment])
blockSeed, Map Range (DList (CommentStyle, [TestComment]))
blockSetupSeeds) =
            forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
                ( \(Range
ran, RawBlockComment
lcs) ->
                    case forall a.
Bool -> Range -> BlockCommentParser a -> String -> Maybe a
parseBlockMaybe Bool
isLHS Range
ran BlockCommentParser (CommentFlavour, [TestComment])
blockCommentBP forall a b. (a -> b) -> a -> b
$
                        RawBlockComment -> String
getRawBlockComment RawBlockComment
lcs of
                        Maybe (CommentFlavour, [TestComment])
Nothing -> forall a. Monoid a => a
mempty
                        Just (Named String
"setup", [TestComment]
grp) ->
                            -- orders setup sections in ascending order
                            ( forall a. Monoid a => a
mempty
                            , forall k a. k -> a -> Map k a
Map.singleton Range
ran forall a b. (a -> b) -> a -> b
$
                                forall a. a -> DList a
DL.singleton (Range -> CommentStyle
Block Range
ran, [TestComment]
grp)
                            )
                        Just (CommentFlavour, [TestComment])
grp ->
                            ( forall k a. k -> a -> Map k a
Map.singleton Range
ran (CommentFlavour, [TestComment])
grp
                            , forall a. Monoid a => a
mempty
                            )
                )
                -- It seems Extended Eval Plugin doesn't constraint
                -- starting indentation level for block comments.
                -- Rather, it constrains the indentation level /inside/
                -- block comment body.
                forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map Range RawBlockComment
blockComments
        lineSections :: Map Range Section
lineSections =
            Map Range (CommentFlavour, [TestComment])
lineSectionSeeds forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (CommentStyle -> CommentFlavour -> [TestComment] -> Section
testsToSection CommentStyle
Line)
        multilineSections :: Map Range Section
multilineSections =
            forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey
                (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommentStyle -> CommentFlavour -> [TestComment] -> Section
testsToSection forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> CommentStyle
Block)
                Map Range (CommentFlavour, [TestComment])
blockSeed
        setupSections :: [Section]
setupSections =
            -- Setups doesn't need Dummy position
            forall a b. (a -> b) -> [a] -> [b]
map
                ( \(CommentStyle
style, [TestComment]
tests) ->
                    CommentStyle -> CommentFlavour -> [TestComment] -> Section
testsToSection
                        CommentStyle
style
                        (String -> CommentFlavour
Named String
"setup")
                        [TestComment]
tests
                )
                forall a b. (a -> b) -> a -> b
$ forall a. DList a -> [a]
DL.toList forall a b. (a -> b) -> a -> b
$
                    forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold forall a b. (a -> b) -> a -> b
$
                        forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Semigroup a => a -> a -> a
(<>) Map Range (DList (CommentStyle, [TestComment]))
lineSetupSeeds Map Range (DList (CommentStyle, [TestComment]))
blockSetupSeeds
        nonSetupSections :: [Section]
nonSetupSections = forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList forall a b. (a -> b) -> a -> b
$ Map Range Section
lineSections forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Range Section
multilineSections
     in Sections {[Section]
setupSections :: [Section]
nonSetupSections :: [Section]
nonSetupSections :: [Section]
setupSections :: [Section]
..}

parseBlockMaybe :: Bool -> Range -> BlockCommentParser a -> String -> Maybe a
parseBlockMaybe :: forall a.
Bool -> Range -> BlockCommentParser a -> String -> Maybe a
parseBlockMaybe Bool
isLhs Range
blockRange BlockCommentParser a
p String
i =
    case forall r a. Reader r a -> r -> a
runReader (forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> String -> s -> m (Either (ParseErrorBundle s e) a)
runParserT BlockCommentParser a
p' String
"" String
i) BlockEnv {Bool
Range
blockRange :: Range
isLhs :: Bool
blockRange :: Range
isLhs :: Bool
..} of
        Left {} -> forall a. Maybe a
Nothing
        Right a
a -> forall a. a -> Maybe a
Just a
a
    where
        p' :: BlockCommentParser a
p' = do
            forall e s (m :: * -> *).
MonadParsec e s m =>
(State s e -> State s e) -> m ()
updateParserState forall a b. (a -> b) -> a -> b
$ \State String Void
st ->
                State String Void
st
                    { statePosState :: PosState String
statePosState =
                        (forall s e. State s e -> PosState s
statePosState State String Void
st)
                            { pstateSourcePos :: SourcePos
pstateSourcePos = Position -> SourcePos
positionToSourcePos forall a b. (a -> b) -> a -> b
$ Range
blockRange forall s a. s -> Getting a s a -> a
^. forall s a. HasStart s a => Lens' s a
L.start
                            }
                    }
            BlockCommentParser a
p

type CommentRange = Range

type SectionRange = Range

testsToSection ::
    CommentStyle ->
    CommentFlavour ->
    [TestComment] ->
    Section
testsToSection :: CommentStyle -> CommentFlavour -> [TestComment] -> Section
testsToSection CommentStyle
style CommentFlavour
flav [TestComment]
tests =
    let sectionName :: String
sectionName
            | Named String
name <- CommentFlavour
flav = String
name
            | Bool
otherwise = String
""
        sectionLanguage :: Language
sectionLanguage = case CommentFlavour
flav of
            CommentFlavour
HaddockNext -> Language
Haddock
            CommentFlavour
HaddockPrev -> Language
Haddock
            CommentFlavour
_           -> Language
Plain
        sectionTests :: [Test]
sectionTests = forall a b. (a -> b) -> [a] -> [b]
map TestComment -> Test
fromTestComment [TestComment]
tests
        sectionFormat :: Format
sectionFormat =
            case CommentStyle
style of
                CommentStyle
Line      -> Format
SingleLine
                Block Range
ran -> Range -> Format
MultiLine Range
ran
     in Section {String
[Test]
Language
Format
sectionFormat :: Format
sectionLanguage :: Language
sectionTests :: [Test]
sectionName :: String
sectionFormat :: Format
sectionTests :: [Test]
sectionLanguage :: Language
sectionName :: String
..}

fromTestComment :: TestComment -> Test
fromTestComment :: TestComment -> Test
fromTestComment AProp {[String]
Range
PropLine
propResults :: [String]
lineProp :: PropLine
testCommentRange :: Range
propResults :: TestComment -> [String]
lineProp :: TestComment -> PropLine
testCommentRange :: TestComment -> Range
..} =
    Property
        { testline :: String
testline = PropLine -> String
getPropLine PropLine
lineProp
        , testOutput :: [String]
testOutput = [String]
propResults
        , testRange :: Range
testRange = Range
testCommentRange
        }
fromTestComment AnExample {[String]
NonEmpty ExampleLine
Range
exampleResults :: [String]
lineExamples :: NonEmpty ExampleLine
testCommentRange :: Range
exampleResults :: TestComment -> [String]
lineExamples :: TestComment -> NonEmpty ExampleLine
testCommentRange :: TestComment -> Range
..} =
    Example
        { testLines :: NonEmpty String
testLines = ExampleLine -> String
getExampleLine forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty ExampleLine
lineExamples
        , testOutput :: [String]
testOutput = [String]
exampleResults
        , testRange :: Range
testRange = Range
testCommentRange
        }

-- * Block comment parser

{- $setup
>>> dummyPos = Position 0 0
>>> parseE p = either (error . errorBundlePretty) id . parse p ""
-}

-- >>> parseE (blockCommentBP True dummyPos) "{- |\n  >>> 5+5\n  11\n  -}"
-- (HaddockNext,[AnExample {testCommentRange = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " 5+5"} :| [], exampleResults = ["  11"]}])

blockCommentBP ::
    -- | True if Literate Haskell
    BlockCommentParser (CommentFlavour, [TestComment])
blockCommentBP :: BlockCommentParser (CommentFlavour, [TestComment])
blockCommentBP = do
    forall (m :: * -> *) a. Monad m => Int -> m a -> m ()
skipCount Int
2 forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle -- "{-"
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
' '
    CommentFlavour
flav <- LineParser CommentFlavour
commentFlavourP
    Bool
hit <- BlockCommentParser Bool
skipNormalCommentBlock
    if Bool
hit
        then do
            [TestComment]
body <-
                forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$
                    (ParsecT Void String (Reader BlockEnv) TestComment
blockExamples forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void String (Reader BlockEnv) TestComment
blockProp)
                        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* BlockCommentParser Bool
skipNormalCommentBlock
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall e s (m :: * -> *). MonadParsec e s m => m (Tokens s)
takeRest -- just consume the rest
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommentFlavour
flav, [TestComment]
body)
        else forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommentFlavour
flav, [])

skipNormalCommentBlock :: BlockCommentParser Bool
skipNormalCommentBlock :: BlockCommentParser Bool
skipNormalCommentBlock = do
    BlockEnv {Bool
Range
blockRange :: Range
isLhs :: Bool
blockRange :: BlockEnv -> Range
isLhs :: BlockEnv -> Bool
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m end
skipManyTill (Bool -> CommentStyle -> LineParser (String, Position)
normalLineP Bool
isLhs forall a b. (a -> b) -> a -> b
$ Range -> CommentStyle
Block Range
blockRange) forall a b. (a -> b) -> a -> b
$
        Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"-}") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *). MonadParsec e s m => m ()
eof)
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ Bool -> CommentStyle -> LineParser ()
testSymbol Bool
isLhs forall a b. (a -> b) -> a -> b
$ Range -> CommentStyle
Block Range
blockRange)

testSymbol :: Bool -> CommentStyle -> LineParser ()
testSymbol :: Bool -> CommentStyle -> LineParser ()
testSymbol Bool
isLHS CommentStyle
style =
    -- FIXME: To comply with existing Extended Eval Plugin Behaviour;
    -- it must skip one space after a comment!
    -- This prevents Eval Plugin from working on
    -- modules with non-standard base indentation-level.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isLHS Bool -> Bool -> Bool
&& forall s t a b. APrism s t a b -> s -> Bool
is Prism' CommentStyle Range
_Block CommentStyle
style) (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadPlus m => Int -> Int -> m a -> m [a]
count' Int
0 Int
2 forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
' ')
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (LineParser ()
exampleSymbol forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LineParser ()
propSymbol)

eob :: LineParser ()
eob :: LineParser ()
eob = forall e s (m :: * -> *). MonadParsec e s m => m ()
eof forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"-}") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol

blockExamples
    , blockProp ::
        BlockCommentParser TestComment
blockExamples :: ParsecT Void String (Reader BlockEnv) TestComment
blockExamples = do
    BlockEnv {Bool
Range
blockRange :: Range
isLhs :: Bool
blockRange :: BlockEnv -> Range
isLhs :: BlockEnv -> Bool
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    (Range
ran, NonEmpty ExampleLine
examples) <- forall s (m :: * -> *) v (t :: * -> *) a.
(TraversableStream s, Stream s, Monad m, Ord v, Traversable t) =>
ParsecT v s m (t (a, Position)) -> ParsecT v s m (Range, t a)
withRange forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Alternative m => m a -> m (NonEmpty a)
NE.some forall a b. (a -> b) -> a -> b
$ Bool -> CommentStyle -> LineParser (ExampleLine, Position)
exampleLineStrP Bool
isLhs forall a b. (a -> b) -> a -> b
$ Range -> CommentStyle
Block Range
blockRange
    Range -> NonEmpty ExampleLine -> [String] -> TestComment
AnExample Range
ran NonEmpty ExampleLine
examples forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockCommentParser [String]
resultBlockP
blockProp :: ParsecT Void String (Reader BlockEnv) TestComment
blockProp = do
    BlockEnv {Bool
Range
blockRange :: Range
isLhs :: Bool
blockRange :: BlockEnv -> Range
isLhs :: BlockEnv -> Bool
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    (Range
ran, Identity PropLine
prop) <- forall s (m :: * -> *) v (t :: * -> *) a.
(TraversableStream s, Stream s, Monad m, Ord v, Traversable t) =>
ParsecT v s m (t (a, Position)) -> ParsecT v s m (Range, t a)
withRange forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ Bool -> CommentStyle -> LineParser (PropLine, Position)
propLineStrP Bool
isLhs forall a b. (a -> b) -> a -> b
$ Range -> CommentStyle
Block Range
blockRange
    Range -> PropLine -> [String] -> TestComment
AProp Range
ran PropLine
prop forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockCommentParser [String]
resultBlockP

withRange ::
    (TraversableStream s, Stream s, Monad m, Ord v, Traversable t) =>
    ParsecT v s m (t (a, Position)) ->
    ParsecT v s m (Range, t a)
withRange :: forall s (m :: * -> *) v (t :: * -> *) a.
(TraversableStream s, Stream s, Monad m, Ord v, Traversable t) =>
ParsecT v s m (t (a, Position)) -> ParsecT v s m (Range, t a)
withRange ParsecT v s m (t (a, Position))
p = do
    Position
beg <- SourcePos -> Position
sourcePosToPosition forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
    t (a, Position)
as <- ParsecT v s m (t (a, Position))
p
    let fin :: Position
fin
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
null t (a, Position)
as = Position
beg
            | Bool
otherwise = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList t (a, Position)
as
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Position -> Position -> Range
Range Position
beg Position
fin, forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (a, Position)
as)

resultBlockP :: BlockCommentParser [String]
resultBlockP :: BlockCommentParser [String]
resultBlockP = do
    BlockEnv {Bool
Range
blockRange :: Range
isLhs :: Bool
blockRange :: BlockEnv -> Range
isLhs :: BlockEnv -> Bool
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Bool -> CommentStyle -> LineParser (String, Position)
nonEmptyNormalLineP Bool
isLhs forall a b. (a -> b) -> a -> b
$
            Range -> CommentStyle
Block Range
blockRange

positionToSourcePos :: Position -> SourcePos
positionToSourcePos :: Position -> SourcePos
positionToSourcePos Position
pos =
    P.SourcePos
        { sourceName :: String
sourceName = String
"<block comment>"
        , sourceLine :: Pos
sourceLine = Int -> Pos
P.mkPos forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ UInt
1 forall a. Num a => a -> a -> a
+ Position
pos forall s a. s -> Getting a s a -> a
^. forall s a. HasLine s a => Lens' s a
L.line
        , sourceColumn :: Pos
sourceColumn = Int -> Pos
P.mkPos forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ UInt
1 forall a. Num a => a -> a -> a
+ Position
pos forall s a. s -> Getting a s a -> a
^. forall s a. HasCharacter s a => Lens' s a
L.character
        }

sourcePosToPosition :: SourcePos -> Position
sourcePosToPosition :: SourcePos -> Position
sourcePosToPosition SourcePos {String
Pos
sourceColumn :: Pos
sourceLine :: Pos
sourceName :: String
sourceColumn :: SourcePos -> Pos
sourceLine :: SourcePos -> Pos
sourceName :: SourcePos -> String
..} =
    UInt -> UInt -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Pos -> Int
unPos Pos
sourceLine forall a. Num a => a -> a -> a
- Int
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Pos -> Int
unPos Pos
sourceColumn forall a. Num a => a -> a -> a
- Int
1)

-- * Line Group Parser

{- |
Result: a tuple of ordinary line tests and setting sections.

TODO: Haddock comment can adjacent to vanilla comment:

    @
        -- Vanilla comment
        -- Another vanilla
        -- | This parses as Haddock comment as GHC
    @

This behaviour is not yet handled correctly in Eval Plugin;
but for future extension for this, we use a tuple here instead of 'Either'.
-}
lineGroupP ::
    LineGroupParser
        (Maybe (CommentFlavour, [TestComment]), [TestComment])
lineGroupP :: LineGroupParser
  (Maybe (CommentFlavour, [TestComment]), [TestComment])
lineGroupP = do
    (Range
_, CommentFlavour
flav) <- forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a.
(Ord (f RawLineComment), Traversable f) =>
LineParser a -> Parsec Void [f RawLineComment] (f a)
parseLine (LineParser CommentFlavour
commentFlavourP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m (Tokens s)
takeRest)
    case CommentFlavour
flav of
        Named String
"setup" -> (forall a. Maybe a
Nothing,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LineGroupParser [TestComment]
lineCommentSectionsP
        CommentFlavour
flav          -> (,forall a. Monoid a => a
mempty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CommentFlavour
flav,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LineGroupParser [TestComment]
lineCommentSectionsP

-- >>>  parse (lineGroupP <*eof) "" $ (dummyPosition, ) . RawLineComment <$> ["-- a", "-- b"]
-- Variable not in scope: dummyPosition :: Position

commentFlavourP :: LineParser CommentFlavour
commentFlavourP :: LineParser CommentFlavour
commentFlavourP =
    forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option
        CommentFlavour
Vanilla
        ( CommentFlavour
HaddockNext forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'|'
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CommentFlavour
HaddockPrev forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'^'
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> CommentFlavour
Named forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'$'
                forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar)
        )
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
' ')

lineCommentHeadP :: LineParser ()
lineCommentHeadP :: LineParser ()
lineCommentHeadP = do
    -- and no operator symbol character follows.
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"--"
    forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipMany forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'-'
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
' '

lineCommentSectionsP ::
    LineGroupParser [TestComment]
lineCommentSectionsP :: LineGroupParser [TestComment]
lineCommentSectionsP = do
    forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipMany LineGroupParser (Range, String)
normalLineCommentP
    forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$
        ParsecT Void [(Range, RawLineComment)] Identity TestComment
exampleLinesGP
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Range -> PropLine -> [String] -> TestComment
AProp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LineGroupParser (Range, PropLine)
propLineGP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LineGroupParser [String]
resultLinesP
                forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipMany LineGroupParser (Range, String)
normalLineCommentP

lexemeLine :: LineGroupParser a -> LineGroupParser a
lexemeLine :: forall a. LineGroupParser a -> LineGroupParser a
lexemeLine LineGroupParser a
p = LineGroupParser a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipMany LineGroupParser (Range, String)
normalLineCommentP

resultLinesP :: LineGroupParser [String]
resultLinesP :: LineGroupParser [String]
resultLinesP = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many LineGroupParser String
nonEmptyLGP

normalLineCommentP :: LineGroupParser (Range, String)
normalLineCommentP :: LineGroupParser (Range, String)
normalLineCommentP =
    forall (f :: * -> *) a.
(Ord (f RawLineComment), Traversable f) =>
LineParser a -> Parsec Void [f RawLineComment] (f a)
parseLine (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LineParser CommentFlavour
commentFlavourP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> CommentStyle -> LineParser (String, Position)
normalLineP Bool
False CommentStyle
Line)

nonEmptyLGP :: LineGroupParser String
nonEmptyLGP :: LineGroupParser String
nonEmptyLGP =
    forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) a.
(Ord (f RawLineComment), Traversable f) =>
LineParser a -> Parsec Void [f RawLineComment] (f a)
parseLine forall a b. (a -> b) -> a -> b
$
                forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LineParser CommentFlavour
commentFlavourP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> CommentStyle -> LineParser (String, Position)
nonEmptyNormalLineP Bool
False CommentStyle
Line

exampleLinesGP :: LineGroupParser TestComment
exampleLinesGP :: ParsecT Void [(Range, RawLineComment)] Identity TestComment
exampleLinesGP =
    forall a. LineGroupParser a -> LineGroupParser a
lexemeLine forall a b. (a -> b) -> a -> b
$
        forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Range -> NonEmpty ExampleLine -> [String] -> TestComment
AnExample forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first NonEmpty Range -> Range
convexHullRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
NE.unzip
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Alternative m => m a -> m (NonEmpty a)
NE.some LineGroupParser (Range, ExampleLine)
exampleLineGP
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LineGroupParser [String]
resultLinesP

convexHullRange :: NonEmpty Range -> Range
convexHullRange :: NonEmpty Range -> Range
convexHullRange NonEmpty Range
nes =
    Position -> Position -> Range
Range (forall a. NonEmpty a -> a
NE.head NonEmpty Range
nes forall s a. s -> Getting a s a -> a
^. forall s a. HasStart s a => Lens' s a
L.start) (forall a. NonEmpty a -> a
NE.last NonEmpty Range
nes forall s a. s -> Getting a s a -> a
^. forall s a. HasEnd s a => Lens' s a
L.end)

exampleLineGP :: LineGroupParser (Range, ExampleLine)
exampleLineGP :: LineGroupParser (Range, ExampleLine)
exampleLineGP =
    -- In line-comments, indentation-level inside comment doesn't matter.
    forall (f :: * -> *) a.
(Ord (f RawLineComment), Traversable f) =>
LineParser a -> Parsec Void [f RawLineComment] (f a)
parseLine (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LineParser CommentFlavour
commentFlavourP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> CommentStyle -> LineParser (ExampleLine, Position)
exampleLineStrP Bool
False CommentStyle
Line)

propLineGP :: LineGroupParser (Range, PropLine)
propLineGP :: LineGroupParser (Range, PropLine)
propLineGP =
    -- In line-comments, indentation-level inside comment doesn't matter.
    forall (f :: * -> *) a.
(Ord (f RawLineComment), Traversable f) =>
LineParser a -> Parsec Void [f RawLineComment] (f a)
parseLine (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LineParser CommentFlavour
commentFlavourP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> CommentStyle -> LineParser (PropLine, Position)
propLineStrP Bool
False CommentStyle
Line)

{- |
Turning a line parser into line group parser consuming a single line comment.
Parses a sinlge line comment, skipping prefix "--[-*]" with optional one horizontal space.
fails if the input does not start with "--".

__N.B.__ We don't strip comment flavours.

>>> pck = (:[]).(:[]) . RawLineComment

>>> parseMaybe (parseLine $ takeRest) $ pck "-- >>> A"
Just [">>> A"]

>>> parseMaybe (parseLine $ takeRest) $ pck "---  >>> A"
Just [" >>> A"]

>>> parseMaybe (parseLine takeRest) $ pck ""
Nothing
-}
parseLine ::
    (Ord (f RawLineComment), Traversable f) =>
    LineParser a ->
    Parsec Void [f RawLineComment] (f a)
parseLine :: forall (f :: * -> *) a.
(Ord (f RawLineComment), Traversable f) =>
LineParser a -> Parsec Void [f RawLineComment] (f a)
parseLine LineParser a
p =
    forall e s (m :: * -> *) a.
MonadParsec e s m =>
(Token s -> Maybe a) -> Set (ErrorItem (Token s)) -> m a
P.token
        (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a b. (a -> b) -> a -> b
$ forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
parseMaybe (LineParser ()
lineCommentHeadP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> LineParser a
p) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawLineComment -> String
getRawLineComment)
        forall a. Monoid a => a
mempty

-- * Line Parsers

-- | Non-empty normal line.
nonEmptyNormalLineP ::
    -- | True if Literate Haskell
    Bool ->
    CommentStyle ->
    LineParser (String, Position)
nonEmptyNormalLineP :: Bool -> CommentStyle -> LineParser (String, Position)
nonEmptyNormalLineP Bool
isLHS CommentStyle
style = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ do
    (String
ln, Position
pos) <- Bool -> CommentStyle -> LineParser (String, Position)
normalLineP Bool
isLHS CommentStyle
style
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$
        case CommentStyle
style of
            Block{} -> Text -> Text
T.strip (String -> Text
T.pack String
ln) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"{-", Text
"-}", Text
""]
            CommentStyle
_       -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
C.isSpace String
ln
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
ln, Position
pos)

{- | Normal line is a line neither a example nor prop.
 Empty line is normal.
-}
normalLineP ::
    -- | True if Literate Haskell
    Bool ->
    CommentStyle ->
    LineParser (String, Position)
normalLineP :: Bool -> CommentStyle -> LineParser (String, Position)
normalLineP Bool
isLHS CommentStyle
style = do
    forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy
        (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ Bool -> CommentStyle -> LineParser ()
testSymbol Bool
isLHS CommentStyle
style)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isLHS Bool -> Bool -> Bool
&& forall s t a b. APrism s t a b -> s -> Bool
is Prism' CommentStyle Range
_Block CommentStyle
style) forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadPlus m => Int -> Int -> m a -> m [a]
count' Int
0 Int
2 forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
' '
    CommentStyle -> LineParser (String, Position)
consume CommentStyle
style

consume :: CommentStyle -> LineParser (String, Position)
consume :: CommentStyle -> LineParser (String, Position)
consume CommentStyle
style =
    case CommentStyle
style of
        CommentStyle
Line     -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *). MonadParsec e s m => m (Tokens s)
takeRest forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) v s.
(Monad m, Ord v, TraversableStream s) =>
ParsecT v s m Position
getPosition
        Block {} -> forall (m :: * -> *) a end.
MonadPlus m =>
m a -> m end -> m ([a], end)
manyTill_ forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle (forall (m :: * -> *) v s.
(Monad m, Ord v, TraversableStream s) =>
ParsecT v s m Position
getPosition forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* LineParser ()
eob)

getPosition :: (Monad m, Ord v, TraversableStream s) => ParsecT v s m Position
getPosition :: forall (m :: * -> *) v s.
(Monad m, Ord v, TraversableStream s) =>
ParsecT v s m Position
getPosition = SourcePos -> Position
sourcePosToPosition forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos

-- | Parses example test line.
exampleLineStrP ::
    -- | True if Literate Haskell
    Bool ->
    CommentStyle ->
    LineParser (ExampleLine, Position)
exampleLineStrP :: Bool -> CommentStyle -> LineParser (ExampleLine, Position)
exampleLineStrP Bool
isLHS CommentStyle
style =
    forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$
        -- FIXME: To comply with existing Extended Eval Plugin Behaviour;
        -- it must skip one space after a comment!
        -- This prevents Eval Plugin from working on
        -- modules with non-standard base indentation-level.
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isLHS Bool -> Bool -> Bool
&& forall s t a b. APrism s t a b -> s -> Bool
is Prism' CommentStyle Range
_Block CommentStyle
style) (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadPlus m => Int -> Int -> m a -> m [a]
count' Int
0 Int
2 forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
' ')
            forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> LineParser ()
exampleSymbol
            forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first String -> ExampleLine
ExampleLine forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CommentStyle -> LineParser (String, Position)
consume CommentStyle
style)

exampleSymbol :: LineParser ()
exampleSymbol :: LineParser ()
exampleSymbol =
    forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
">>>" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
P.notFollowedBy (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'>')

propSymbol :: LineParser ()
propSymbol :: LineParser ()
propSymbol = forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"prop>" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
P.notFollowedBy (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'>')

-- | Parses prop test line.
propLineStrP ::
    -- | True if Literate HAskell
    Bool ->
    CommentStyle ->
    LineParser (PropLine, Position)
propLineStrP :: Bool -> CommentStyle -> LineParser (PropLine, Position)
propLineStrP Bool
isLHS CommentStyle
style =
    -- FIXME: To comply with existing Extended Eval Plugin Behaviour;
    -- it must skip one space after a comment!
    -- This prevents Eval Plugin from working on
    -- modules with non-standard base indentation-level.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isLHS Bool -> Bool -> Bool
&& forall s t a b. APrism s t a b -> s -> Bool
is Prism' CommentStyle Range
_Block CommentStyle
style) (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadPlus m => Int -> Int -> m a -> m [a]
count' Int
0 Int
2 forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
' ')
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"prop>"
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
P.notFollowedBy (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'>')
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first String -> PropLine
PropLine forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CommentStyle -> LineParser (String, Position)
consume CommentStyle
style)

-- * Utilities

{- |
Given a sequence of tokens increasing in their starting position,
groups them into sublists consisting of contiguous tokens;
Two adjacent tokens are considered to be contiguous if

    * line number increases by 1, and
    * they have same starting column.

>>> contiguousGroupOn id [(1,2),(2,2),(3,4),(4,4),(5,4),(7,0),(8,0)]
[(1,2) :| [(2,2)],(3,4) :| [(4,4),(5,4)],(7,0) :| [(8,0)]]
-}
contiguousGroupOn :: (a -> (UInt, UInt)) -> [a] -> [NonEmpty a]
contiguousGroupOn :: forall a. (a -> (UInt, UInt)) -> [a] -> [NonEmpty a]
contiguousGroupOn a -> (UInt, UInt)
toLineCol = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> [NonEmpty a] -> [NonEmpty a]
step []
    where
        step :: a -> [NonEmpty a] -> [NonEmpty a]
step a
a [] = [forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a]
        step a
a bss0 :: [NonEmpty a]
bss0@((a
b :| [a]
bs) : [NonEmpty a]
bss)
            | let (UInt
aLine, UInt
aCol) = a -> (UInt, UInt)
toLineCol a
a
              , let (UInt
bLine, UInt
bCol) = a -> (UInt, UInt)
toLineCol a
b
              , UInt
aLine forall a. Num a => a -> a -> a
+ UInt
1 forall a. Eq a => a -> a -> Bool
== UInt
bLine Bool -> Bool -> Bool
&& UInt
aCol forall a. Eq a => a -> a -> Bool
== UInt
bCol =
                (a
a forall a. a -> [a] -> NonEmpty a
:| a
b forall a. a -> [a] -> [a]
: [a]
bs) forall a. a -> [a] -> [a]
: [NonEmpty a]
bss
            | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a forall a. a -> [a] -> [a]
: [NonEmpty a]
bss0

{- | Given a map from positions, divides them into subgroup
 with contiguous line and columns.
-}
groupLineComments ::
    Map Range a -> [NonEmpty (Range, a)]
groupLineComments :: forall a. Map Range a -> [NonEmpty (Range, a)]
groupLineComments =
    forall a. (a -> (UInt, UInt)) -> [a] -> [NonEmpty a]
contiguousGroupOn (forall a b. (a, b) -> a
fst forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s a. HasStart s a => Lens' s a
L.start forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s a. HasLine s a => Lens' s a
L.line forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s a. HasCharacter s a => Lens' s a
L.character)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList