{-# 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           Development.IDE                          (Position,
                                                           Range (Range))
import           Development.IDE.Types.Location           (Position (..))
import           GHC.Generics                             hiding (UInt, to)
import           Ide.Plugin.Eval.Types
import           Language.LSP.Types                       (UInt)
import           Language.LSP.Types.Lens                  (character, end, line,
                                                           start)
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 (ReadPrec [BlockEnv]
ReadPrec BlockEnv
Int -> ReadS BlockEnv
ReadS [BlockEnv]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BlockEnv]
$creadListPrec :: ReadPrec [BlockEnv]
readPrec :: ReadPrec BlockEnv
$creadPrec :: ReadPrec BlockEnv
readList :: ReadS [BlockEnv]
$creadList :: ReadS [BlockEnv]
readsPrec :: Int -> ReadS BlockEnv
$creadsPrec :: Int -> ReadS BlockEnv
Read, 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 (ReadPrec [CommentStyle]
ReadPrec CommentStyle
Int -> ReadS CommentStyle
ReadS [CommentStyle]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CommentStyle]
$creadListPrec :: ReadPrec [CommentStyle]
readPrec :: ReadPrec CommentStyle
$creadPrec :: ReadPrec CommentStyle
readList :: ReadS [CommentStyle]
$creadList :: ReadS [CommentStyle]
readsPrec :: Int -> ReadS CommentStyle
$creadsPrec :: Int -> ReadS CommentStyle
Read, 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
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
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
start forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasCharacter s a => Lens' s a
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
start forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasCharacter s a => Lens' s a
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
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
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
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
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
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 v s (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 v s (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 :: (Ord v, TraversableStream s) => ParsecT v s m Position
getPosition :: forall v s (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
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
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
character)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList