{-# 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
import           Ide.Plugin.Eval.Types
import           Language.LSP.Types.Lens                  (character, end, line,
                                                           start)
import           Text.Megaparsec
import qualified Text.Megaparsec                          as P
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]
(Int -> ReadS BlockEnv)
-> ReadS [BlockEnv]
-> ReadPrec BlockEnv
-> ReadPrec [BlockEnv]
-> Read 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
(Int -> BlockEnv -> ShowS)
-> (BlockEnv -> String) -> ([BlockEnv] -> ShowS) -> Show BlockEnv
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
(BlockEnv -> BlockEnv -> Bool)
-> (BlockEnv -> BlockEnv -> Bool) -> Eq BlockEnv
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
Eq BlockEnv
-> (BlockEnv -> BlockEnv -> Ordering)
-> (BlockEnv -> BlockEnv -> Bool)
-> (BlockEnv -> BlockEnv -> Bool)
-> (BlockEnv -> BlockEnv -> Bool)
-> (BlockEnv -> BlockEnv -> Bool)
-> (BlockEnv -> BlockEnv -> BlockEnv)
-> (BlockEnv -> BlockEnv -> BlockEnv)
-> Ord 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
$cp1Ord :: Eq BlockEnv
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
(Int -> PropLine -> ShowS)
-> (PropLine -> String) -> ([PropLine] -> ShowS) -> Show PropLine
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
(Int -> ExampleLine -> ShowS)
-> (ExampleLine -> String)
-> ([ExampleLine] -> ShowS)
-> Show ExampleLine
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
(Int -> TestComment -> ShowS)
-> (TestComment -> String)
-> ([TestComment] -> ShowS)
-> Show TestComment
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]
(Int -> ReadS CommentFlavour)
-> ReadS [CommentFlavour]
-> ReadPrec CommentFlavour
-> ReadPrec [CommentFlavour]
-> Read 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
(Int -> CommentFlavour -> ShowS)
-> (CommentFlavour -> String)
-> ([CommentFlavour] -> ShowS)
-> Show CommentFlavour
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
(CommentFlavour -> CommentFlavour -> Bool)
-> (CommentFlavour -> CommentFlavour -> Bool) -> Eq CommentFlavour
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
Eq CommentFlavour
-> (CommentFlavour -> CommentFlavour -> Ordering)
-> (CommentFlavour -> CommentFlavour -> Bool)
-> (CommentFlavour -> CommentFlavour -> Bool)
-> (CommentFlavour -> CommentFlavour -> Bool)
-> (CommentFlavour -> CommentFlavour -> Bool)
-> (CommentFlavour -> CommentFlavour -> CommentFlavour)
-> (CommentFlavour -> CommentFlavour -> CommentFlavour)
-> Ord 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
$cp1Ord :: Eq CommentFlavour
Ord)

-- | Single line or block comments?

data CommentStyle = Line | Block Range
    deriving (ReadPrec [CommentStyle]
ReadPrec CommentStyle
Int -> ReadS CommentStyle
ReadS [CommentStyle]
(Int -> ReadS CommentStyle)
-> ReadS [CommentStyle]
-> ReadPrec CommentStyle
-> ReadPrec [CommentStyle]
-> Read 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
(Int -> CommentStyle -> ShowS)
-> (CommentStyle -> String)
-> ([CommentStyle] -> ShowS)
-> Show CommentStyle
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
(CommentStyle -> CommentStyle -> Bool)
-> (CommentStyle -> CommentStyle -> Bool) -> Eq CommentStyle
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
Eq CommentStyle
-> (CommentStyle -> CommentStyle -> Ordering)
-> (CommentStyle -> CommentStyle -> Bool)
-> (CommentStyle -> CommentStyle -> Bool)
-> (CommentStyle -> CommentStyle -> Bool)
-> (CommentStyle -> CommentStyle -> Bool)
-> (CommentStyle -> CommentStyle -> CommentStyle)
-> (CommentStyle -> CommentStyle -> CommentStyle)
-> Ord 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
$cp1Ord :: Eq CommentStyle
Ord, (forall x. CommentStyle -> Rep CommentStyle x)
-> (forall x. Rep CommentStyle x -> CommentStyle)
-> Generic CommentStyle
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) =
            (NonEmpty (Range, RawLineComment)
 -> (Map Range (CommentFlavour, [TestComment]),
     Map Range (DList (CommentStyle, [TestComment]))))
-> [NonEmpty (Range, RawLineComment)]
-> (Map Range (CommentFlavour, [TestComment]),
    Map Range (DList (CommentStyle, [TestComment])))
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
                                (Getting Position Range Position -> Range -> Position
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Position Range Position
forall s a. HasStart s a => Lens' s a
start (Range -> Position) -> Range -> Position
forall a b. (a -> b) -> a -> b
$ (Range, RawLineComment) -> Range
forall a b. (a, b) -> a
fst ((Range, RawLineComment) -> Range)
-> (Range, RawLineComment) -> Range
forall a b. (a -> b) -> a -> b
$ NonEmpty (Range, RawLineComment) -> (Range, RawLineComment)
forall a. NonEmpty a -> a
NE.head NonEmpty (Range, RawLineComment)
lcs)
                                (Getting Position Range Position -> Range -> Position
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Position Range Position
forall s a. HasEnd s a => Lens' s a
end (Range -> Position) -> Range -> Position
forall a b. (a -> b) -> a -> b
$ (Range, RawLineComment) -> Range
forall a b. (a, b) -> a
fst ((Range, RawLineComment) -> Range)
-> (Range, RawLineComment) -> Range
forall a b. (a -> b) -> a -> b
$ NonEmpty (Range, RawLineComment) -> (Range, RawLineComment)
forall a. NonEmpty a -> a
NE.last NonEmpty (Range, RawLineComment)
lcs)
                     in case Parsec
  Void
  [(Range, RawLineComment)]
  (Maybe (CommentFlavour, [TestComment]), [TestComment])
-> [(Range, RawLineComment)]
-> Maybe (Maybe (CommentFlavour, [TestComment]), [TestComment])
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
parseMaybe Parsec
  Void
  [(Range, RawLineComment)]
  (Maybe (CommentFlavour, [TestComment]), [TestComment])
lineGroupP ([(Range, RawLineComment)]
 -> Maybe (Maybe (CommentFlavour, [TestComment]), [TestComment]))
-> [(Range, RawLineComment)]
-> Maybe (Maybe (CommentFlavour, [TestComment]), [TestComment])
forall a b. (a -> b) -> a -> b
$ NonEmpty (Range, RawLineComment) -> [(Range, RawLineComment)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Range, RawLineComment)
lcs of
                            Maybe (Maybe (CommentFlavour, [TestComment]), [TestComment])
Nothing -> (Map Range (CommentFlavour, [TestComment]),
 Map Range (DList (CommentStyle, [TestComment])))
forall a. Monoid a => a
mempty
                            Just (Maybe (CommentFlavour, [TestComment])
mls, [TestComment]
rs) ->
                                ( Map Range (CommentFlavour, [TestComment])
-> ((Range, (CommentFlavour, [TestComment]))
    -> Map Range (CommentFlavour, [TestComment]))
-> Maybe (Range, (CommentFlavour, [TestComment]))
-> Map Range (CommentFlavour, [TestComment])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map Range (CommentFlavour, [TestComment])
forall a. Monoid a => a
mempty ((Range
 -> (CommentFlavour, [TestComment])
 -> Map Range (CommentFlavour, [TestComment]))
-> (Range, (CommentFlavour, [TestComment]))
-> Map Range (CommentFlavour, [TestComment])
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Range
-> (CommentFlavour, [TestComment])
-> Map Range (CommentFlavour, [TestComment])
forall k a. k -> a -> Map k a
Map.singleton) ((Range
theRan,) ((CommentFlavour, [TestComment])
 -> (Range, (CommentFlavour, [TestComment])))
-> Maybe (CommentFlavour, [TestComment])
-> Maybe (Range, (CommentFlavour, [TestComment]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CommentFlavour, [TestComment])
mls)
                                , -- orders setup sections in ascending order

                                  if [TestComment] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestComment]
rs
                                    then Map Range (DList (CommentStyle, [TestComment]))
forall a. Monoid a => a
mempty
                                    else
                                        Range
-> DList (CommentStyle, [TestComment])
-> Map Range (DList (CommentStyle, [TestComment]))
forall k a. k -> a -> Map k a
Map.singleton Range
theRan (DList (CommentStyle, [TestComment])
 -> Map Range (DList (CommentStyle, [TestComment])))
-> DList (CommentStyle, [TestComment])
-> Map Range (DList (CommentStyle, [TestComment]))
forall a b. (a -> b) -> a -> b
$
                                            (CommentStyle, [TestComment])
-> DList (CommentStyle, [TestComment])
forall a. a -> DList a
DL.singleton (CommentStyle
Line, [TestComment]
rs)
                                )
                )
                ([NonEmpty (Range, RawLineComment)]
 -> (Map Range (CommentFlavour, [TestComment]),
     Map Range (DList (CommentStyle, [TestComment]))))
-> [NonEmpty (Range, RawLineComment)]
-> (Map Range (CommentFlavour, [TestComment]),
    Map Range (DList (CommentStyle, [TestComment])))
forall a b. (a -> b) -> a -> b
$ Map Range RawLineComment -> [NonEmpty (Range, RawLineComment)]
forall a. Map Range a -> [NonEmpty (Range, a)]
groupLineComments (Map Range RawLineComment -> [NonEmpty (Range, RawLineComment)])
-> Map Range RawLineComment -> [NonEmpty (Range, RawLineComment)]
forall a b. (a -> b) -> a -> b
$
                    (Range -> RawLineComment -> Bool)
-> Map Range RawLineComment -> Map Range RawLineComment
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 Range -> Getting Int Range Int -> Int
forall s a. s -> Getting a s a -> a
^. (Position -> Const Int Position) -> Range -> Const Int Range
forall s a. HasStart s a => Lens' s a
start ((Position -> Const Int Position) -> Range -> Const Int Range)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> Getting Int Range Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasCharacter s a => Lens' s a
character Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
                                else Range
pos Range -> Getting Int Range Int -> Int
forall s a. s -> Getting a s a -> a
^. (Position -> Const Int Position) -> Range -> Const Int Range
forall s a. HasStart s a => Lens' s a
start ((Position -> Const Int Position) -> Range -> Const Int Range)
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> Getting Int Range Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasCharacter s a => Lens' s a
character Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                        )
                        Map Range RawLineComment
lineComments
        (Map Range (CommentFlavour, [TestComment])
blockSeed, Map Range (DList (CommentStyle, [TestComment]))
blockSetupSeeds) =
            ((Range, RawBlockComment)
 -> (Map Range (CommentFlavour, [TestComment]),
     Map Range (DList (CommentStyle, [TestComment]))))
-> [(Range, RawBlockComment)]
-> (Map Range (CommentFlavour, [TestComment]),
    Map Range (DList (CommentStyle, [TestComment])))
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
                ( \(Range
ran, RawBlockComment
lcs) ->
                    case Bool
-> Range
-> BlockCommentParser (CommentFlavour, [TestComment])
-> String
-> Maybe (CommentFlavour, [TestComment])
forall a.
Bool -> Range -> BlockCommentParser a -> String -> Maybe a
parseBlockMaybe Bool
isLHS Range
ran BlockCommentParser (CommentFlavour, [TestComment])
blockCommentBP (String -> Maybe (CommentFlavour, [TestComment]))
-> String -> Maybe (CommentFlavour, [TestComment])
forall a b. (a -> b) -> a -> b
$
                        RawBlockComment -> String
getRawBlockComment RawBlockComment
lcs of
                        Maybe (CommentFlavour, [TestComment])
Nothing -> (Map Range (CommentFlavour, [TestComment]),
 Map Range (DList (CommentStyle, [TestComment])))
forall a. Monoid a => a
mempty
                        Just (Named String
"setup", [TestComment]
grp) ->
                            -- orders setup sections in ascending order

                            ( Map Range (CommentFlavour, [TestComment])
forall a. Monoid a => a
mempty
                            , Range
-> DList (CommentStyle, [TestComment])
-> Map Range (DList (CommentStyle, [TestComment]))
forall k a. k -> a -> Map k a
Map.singleton Range
ran (DList (CommentStyle, [TestComment])
 -> Map Range (DList (CommentStyle, [TestComment])))
-> DList (CommentStyle, [TestComment])
-> Map Range (DList (CommentStyle, [TestComment]))
forall a b. (a -> b) -> a -> b
$
                                (CommentStyle, [TestComment])
-> DList (CommentStyle, [TestComment])
forall a. a -> DList a
DL.singleton (Range -> CommentStyle
Block Range
ran, [TestComment]
grp)
                            )
                        Just (CommentFlavour, [TestComment])
grp ->
                            ( Range
-> (CommentFlavour, [TestComment])
-> Map Range (CommentFlavour, [TestComment])
forall k a. k -> a -> Map k a
Map.singleton Range
ran (CommentFlavour, [TestComment])
grp
                            , Map Range (DList (CommentStyle, [TestComment]))
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.

                ([(Range, RawBlockComment)]
 -> (Map Range (CommentFlavour, [TestComment]),
     Map Range (DList (CommentStyle, [TestComment]))))
-> [(Range, RawBlockComment)]
-> (Map Range (CommentFlavour, [TestComment]),
    Map Range (DList (CommentStyle, [TestComment])))
forall a b. (a -> b) -> a -> b
$ Map Range RawBlockComment -> [(Range, RawBlockComment)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Range RawBlockComment
blockComments
        lineSections :: Map Range Section
lineSections =
            Map Range (CommentFlavour, [TestComment])
lineSectionSeeds Map Range (CommentFlavour, [TestComment])
-> ((CommentFlavour, [TestComment]) -> Section)
-> Map Range Section
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (CommentFlavour -> [TestComment] -> Section)
-> (CommentFlavour, [TestComment]) -> Section
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (CommentStyle -> CommentFlavour -> [TestComment] -> Section
testsToSection CommentStyle
Line)
        multilineSections :: Map Range Section
multilineSections =
            (Range -> (CommentFlavour, [TestComment]) -> Section)
-> Map Range (CommentFlavour, [TestComment]) -> Map Range Section
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey
                ((CommentFlavour -> [TestComment] -> Section)
-> (CommentFlavour, [TestComment]) -> Section
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((CommentFlavour -> [TestComment] -> Section)
 -> (CommentFlavour, [TestComment]) -> Section)
-> (Range -> CommentFlavour -> [TestComment] -> Section)
-> Range
-> (CommentFlavour, [TestComment])
-> Section
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommentStyle -> CommentFlavour -> [TestComment] -> Section
testsToSection (CommentStyle -> CommentFlavour -> [TestComment] -> Section)
-> (Range -> CommentStyle)
-> Range
-> CommentFlavour
-> [TestComment]
-> Section
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

            ((CommentStyle, [TestComment]) -> Section)
-> [(CommentStyle, [TestComment])] -> [Section]
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
                )
                ([(CommentStyle, [TestComment])] -> [Section])
-> [(CommentStyle, [TestComment])] -> [Section]
forall a b. (a -> b) -> a -> b
$ DList (CommentStyle, [TestComment])
-> [(CommentStyle, [TestComment])]
forall a. DList a -> [a]
DL.toList (DList (CommentStyle, [TestComment])
 -> [(CommentStyle, [TestComment])])
-> DList (CommentStyle, [TestComment])
-> [(CommentStyle, [TestComment])]
forall a b. (a -> b) -> a -> b
$
                    Map Range (DList (CommentStyle, [TestComment]))
-> DList (CommentStyle, [TestComment])
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold (Map Range (DList (CommentStyle, [TestComment]))
 -> DList (CommentStyle, [TestComment]))
-> Map Range (DList (CommentStyle, [TestComment]))
-> DList (CommentStyle, [TestComment])
forall a b. (a -> b) -> a -> b
$
                        (DList (CommentStyle, [TestComment])
 -> DList (CommentStyle, [TestComment])
 -> DList (CommentStyle, [TestComment]))
-> Map Range (DList (CommentStyle, [TestComment]))
-> Map Range (DList (CommentStyle, [TestComment]))
-> Map Range (DList (CommentStyle, [TestComment]))
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith DList (CommentStyle, [TestComment])
-> DList (CommentStyle, [TestComment])
-> DList (CommentStyle, [TestComment])
forall a. Semigroup a => a -> a -> a
(<>) Map Range (DList (CommentStyle, [TestComment]))
lineSetupSeeds Map Range (DList (CommentStyle, [TestComment]))
blockSetupSeeds
        nonSetupSections :: [Section]
nonSetupSections = Map Range Section -> [Section]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Map Range Section -> [Section]) -> Map Range Section -> [Section]
forall a b. (a -> b) -> a -> b
$ Map Range Section
lineSections Map Range Section -> Map Range Section -> Map Range Section
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Range Section
multilineSections
     in Sections :: [Section] -> [Section] -> Sections
Sections {[Section]
setupSections :: [Section]
nonSetupSections :: [Section]
nonSetupSections :: [Section]
setupSections :: [Section]
..}

parseBlockMaybe :: Bool -> Range -> BlockCommentParser a -> String -> Maybe a
parseBlockMaybe :: Bool -> Range -> BlockCommentParser a -> String -> Maybe a
parseBlockMaybe Bool
isLhs Range
blockRange BlockCommentParser a
p String
i =
    case Reader BlockEnv (Either (ParseErrorBundle String Void) a)
-> BlockEnv -> Either (ParseErrorBundle String Void) a
forall r a. Reader r a -> r -> a
runReader (BlockCommentParser a
-> String
-> String
-> Reader BlockEnv (Either (ParseErrorBundle String Void) a)
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 -> BlockEnv
BlockEnv {Bool
Range
blockRange :: Range
isLhs :: Bool
blockRange :: Range
isLhs :: Bool
..} of
        Left {} -> Maybe a
forall a. Maybe a
Nothing
        Right a
a -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
    where
        p' :: BlockCommentParser a
p' = do
            (State String Void -> State String Void)
-> ParsecT Void String (Reader BlockEnv) ()
forall e s (m :: * -> *).
MonadParsec e s m =>
(State s e -> State s e) -> m ()
updateParserState ((State String Void -> State String Void)
 -> ParsecT Void String (Reader BlockEnv) ())
-> (State String Void -> State String Void)
-> ParsecT Void String (Reader BlockEnv) ()
forall a b. (a -> b) -> a -> b
$ \State String Void
st ->
                State String Void
st
                    { statePosState :: PosState String
statePosState =
                        (State String Void -> PosState String
forall s e. State s e -> PosState s
statePosState State String Void
st)
                            { pstateSourcePos :: SourcePos
pstateSourcePos = Position -> SourcePos
positionToSourcePos (Position -> SourcePos) -> Position -> SourcePos
forall a b. (a -> b) -> a -> b
$ Range
blockRange Range -> Getting Position Range Position -> Position
forall s a. s -> Getting a s a -> a
^. Getting Position Range Position
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 = (TestComment -> Test) -> [TestComment] -> [Test]
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 -> Section
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 :: String -> [String] -> Range -> Test
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 :: NonEmpty String -> [String] -> Range -> Test
Example
        { testLines :: NonEmpty String
testLines = ExampleLine -> String
getExampleLine (ExampleLine -> String) -> NonEmpty ExampleLine -> NonEmpty String
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
    Int
-> ParsecT Void String (Reader BlockEnv) Char
-> ParsecT Void String (Reader BlockEnv) ()
forall (m :: * -> *) a. Monad m => Int -> m a -> m ()
skipCount Int
2 ParsecT Void String (Reader BlockEnv) Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle -- "{-"

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

            (CommentFlavour, [TestComment])
-> BlockCommentParser (CommentFlavour, [TestComment])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommentFlavour
flav, [TestComment]
body)
        else (CommentFlavour, [TestComment])
-> BlockCommentParser (CommentFlavour, [TestComment])
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
..} <- ParsecT Void String (Reader BlockEnv) BlockEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
    ParsecT Void String (Reader BlockEnv) (String, Position)
-> BlockCommentParser Bool -> BlockCommentParser Bool
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m end
skipManyTill (Bool -> CommentStyle -> LineParser (String, Position)
normalLineP Bool
isLhs (CommentStyle -> LineParser (String, Position))
-> CommentStyle -> LineParser (String, Position)
forall a b. (a -> b) -> a -> b
$ Range -> CommentStyle
Block Range
blockRange) (BlockCommentParser Bool -> BlockCommentParser Bool)
-> BlockCommentParser Bool -> BlockCommentParser Bool
forall a b. (a -> b) -> a -> b
$
        Bool
False Bool
-> ParsecT Void String (Reader BlockEnv) ()
-> BlockCommentParser Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT Void String (Reader BlockEnv) ()
-> ParsecT Void String (Reader BlockEnv) ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void String (Reader BlockEnv) String
-> ParsecT Void String (Reader BlockEnv) (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Tokens String
-> ParsecT Void String (Reader BlockEnv) (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"-}") ParsecT Void String (Reader BlockEnv) (Maybe String)
-> ParsecT Void String (Reader BlockEnv) ()
-> ParsecT Void String (Reader BlockEnv) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String (Reader BlockEnv) ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof)
            BlockCommentParser Bool
-> BlockCommentParser Bool -> BlockCommentParser Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool
True Bool
-> ParsecT Void String (Reader BlockEnv) ()
-> BlockCommentParser Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT Void String (Reader BlockEnv) ()
-> ParsecT Void String (Reader BlockEnv) ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (ParsecT Void String (Reader BlockEnv) ()
-> ParsecT Void String (Reader BlockEnv) ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void String (Reader BlockEnv) ()
 -> ParsecT Void String (Reader BlockEnv) ())
-> ParsecT Void String (Reader BlockEnv) ()
-> ParsecT Void String (Reader BlockEnv) ()
forall a b. (a -> b) -> a -> b
$ Bool -> CommentStyle -> LineParser ()
testSymbol Bool
isLhs (CommentStyle -> LineParser ()) -> CommentStyle -> LineParser ()
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.

    Bool -> ParsecT Void String m () -> ParsecT Void String m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isLHS Bool -> Bool -> Bool
&& APrism CommentStyle CommentStyle Range Range
-> CommentStyle -> Bool
forall s t a b. APrism s t a b -> s -> Bool
is APrism CommentStyle CommentStyle Range Range
Prism' CommentStyle Range
_Block CommentStyle
style) (ParsecT Void String m String -> ParsecT Void String m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String m String -> ParsecT Void String m ())
-> ParsecT Void String m String -> ParsecT Void String m ()
forall a b. (a -> b) -> a -> b
$ Int
-> Int
-> ParsecT Void String m Char
-> ParsecT Void String m String
forall (m :: * -> *) a. MonadPlus m => Int -> Int -> m a -> m [a]
count' Int
0 Int
2 (ParsecT Void String m Char -> ParsecT Void String m String)
-> ParsecT Void String m Char -> ParsecT Void String m String
forall a b. (a -> b) -> a -> b
$ Token String -> ParsecT Void String m (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
' ')
        ParsecT Void String m ()
-> ParsecT Void String m () -> ParsecT Void String m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ParsecT Void String m ()
LineParser ()
exampleSymbol ParsecT Void String m ()
-> ParsecT Void String m () -> ParsecT Void String m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void String m ()
LineParser ()
propSymbol)

eob :: LineParser ()
eob :: ParsecT Void String m ()
eob = ParsecT Void String m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof ParsecT Void String m ()
-> ParsecT Void String m () -> ParsecT Void String m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void String m () -> ParsecT Void String m ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void String m String
-> ParsecT Void String m (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Tokens String -> ParsecT Void String m (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"-}") ParsecT Void String m (Maybe String)
-> ParsecT Void String m () -> ParsecT Void String m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) ParsecT Void String m ()
-> ParsecT Void String m () -> ParsecT Void String m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void String m String -> ParsecT Void String m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void String m String
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
..} <- ParsecT Void String (Reader BlockEnv) BlockEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
    (Range
ran, NonEmpty ExampleLine
examples) <- ParsecT
  Void String (Reader BlockEnv) (NonEmpty (ExampleLine, Position))
-> ParsecT
     Void String (Reader BlockEnv) (Range, NonEmpty ExampleLine)
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
   Void String (Reader BlockEnv) (NonEmpty (ExampleLine, Position))
 -> ParsecT
      Void String (Reader BlockEnv) (Range, NonEmpty ExampleLine))
-> ParsecT
     Void String (Reader BlockEnv) (NonEmpty (ExampleLine, Position))
-> ParsecT
     Void String (Reader BlockEnv) (Range, NonEmpty ExampleLine)
forall a b. (a -> b) -> a -> b
$ ParsecT Void String (Reader BlockEnv) (ExampleLine, Position)
-> ParsecT
     Void String (Reader BlockEnv) (NonEmpty (ExampleLine, Position))
forall (m :: * -> *) a. Alternative m => m a -> m (NonEmpty a)
NE.some (ParsecT Void String (Reader BlockEnv) (ExampleLine, Position)
 -> ParsecT
      Void String (Reader BlockEnv) (NonEmpty (ExampleLine, Position)))
-> ParsecT Void String (Reader BlockEnv) (ExampleLine, Position)
-> ParsecT
     Void String (Reader BlockEnv) (NonEmpty (ExampleLine, Position))
forall a b. (a -> b) -> a -> b
$ Bool -> CommentStyle -> LineParser (ExampleLine, Position)
exampleLineStrP Bool
isLhs (CommentStyle -> LineParser (ExampleLine, Position))
-> CommentStyle -> LineParser (ExampleLine, Position)
forall a b. (a -> b) -> a -> b
$ Range -> CommentStyle
Block Range
blockRange
    Range -> NonEmpty ExampleLine -> [String] -> TestComment
AnExample Range
ran NonEmpty ExampleLine
examples ([String] -> TestComment)
-> ParsecT Void String (Reader BlockEnv) [String]
-> ParsecT Void String (Reader BlockEnv) TestComment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String (Reader BlockEnv) [String]
resultBlockP
blockProp :: ParsecT Void String (Reader BlockEnv) TestComment
blockProp = do
    BlockEnv {Bool
Range
blockRange :: Range
isLhs :: Bool
blockRange :: BlockEnv -> Range
isLhs :: BlockEnv -> Bool
..} <- ParsecT Void String (Reader BlockEnv) BlockEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
    (Range
ran, Identity PropLine
prop) <- ParsecT
  Void String (Reader BlockEnv) (Identity (PropLine, Position))
-> ParsecT Void String (Reader BlockEnv) (Range, Identity PropLine)
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
   Void String (Reader BlockEnv) (Identity (PropLine, Position))
 -> ParsecT
      Void String (Reader BlockEnv) (Range, Identity PropLine))
-> ParsecT
     Void String (Reader BlockEnv) (Identity (PropLine, Position))
-> ParsecT Void String (Reader BlockEnv) (Range, Identity PropLine)
forall a b. (a -> b) -> a -> b
$ ((PropLine, Position) -> Identity (PropLine, Position))
-> ParsecT Void String (Reader BlockEnv) (PropLine, Position)
-> ParsecT
     Void String (Reader BlockEnv) (Identity (PropLine, Position))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PropLine, Position) -> Identity (PropLine, Position)
forall a. a -> Identity a
Identity (ParsecT Void String (Reader BlockEnv) (PropLine, Position)
 -> ParsecT
      Void String (Reader BlockEnv) (Identity (PropLine, Position)))
-> ParsecT Void String (Reader BlockEnv) (PropLine, Position)
-> ParsecT
     Void String (Reader BlockEnv) (Identity (PropLine, Position))
forall a b. (a -> b) -> a -> b
$ Bool -> CommentStyle -> LineParser (PropLine, Position)
propLineStrP Bool
isLhs (CommentStyle -> LineParser (PropLine, Position))
-> CommentStyle -> LineParser (PropLine, Position)
forall a b. (a -> b) -> a -> b
$ Range -> CommentStyle
Block Range
blockRange
    Range -> PropLine -> [String] -> TestComment
AProp Range
ran PropLine
prop ([String] -> TestComment)
-> ParsecT Void String (Reader BlockEnv) [String]
-> ParsecT Void String (Reader BlockEnv) TestComment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String (Reader BlockEnv) [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 :: 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 (SourcePos -> Position)
-> ParsecT v s m SourcePos -> ParsecT v s m Position
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT v s m SourcePos
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
            | t (a, Position) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t (a, Position)
as = Position
beg
            | Bool
otherwise = (a, Position) -> Position
forall a b. (a, b) -> b
snd ((a, Position) -> Position) -> (a, Position) -> Position
forall a b. (a -> b) -> a -> b
$ [(a, Position)] -> (a, Position)
forall a. [a] -> a
last ([(a, Position)] -> (a, Position))
-> [(a, Position)] -> (a, Position)
forall a b. (a -> b) -> a -> b
$ t (a, Position) -> [(a, Position)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList t (a, Position)
as
    (Range, t a) -> ParsecT v s m (Range, t a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Position -> Position -> Range
Range Position
beg Position
fin, (a, Position) -> a
forall a b. (a, b) -> a
fst ((a, Position) -> a) -> t (a, Position) -> t a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (a, Position)
as)

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

positionToSourcePos :: Position -> SourcePos
positionToSourcePos :: Position -> SourcePos
positionToSourcePos Position
pos =
    SourcePos :: String -> Pos -> Pos -> SourcePos
P.SourcePos
        { sourceName :: String
sourceName = String
"<block comment>"
        , sourceLine :: Pos
sourceLine = Int -> Pos
P.mkPos (Int -> Pos) -> Int -> Pos
forall a b. (a -> b) -> a -> b
$ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Position
pos Position
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> Int
forall s a. s -> Getting a s a -> a
^. (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasLine s a => Lens' s a
line
        , sourceColumn :: Pos
sourceColumn = Int -> Pos
P.mkPos (Int -> Pos) -> Int -> Pos
forall a b. (a -> b) -> a -> b
$ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Position
pos Position
-> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> Int
forall s a. s -> Getting a s a -> a
^. (Int -> Const Int Int) -> Position -> Const Int Position
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
..} =
    Int -> Int -> Position
Position (Pos -> Int
unPos Pos
sourceLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Pos -> Int
unPos Pos
sourceColumn Int -> Int -> Int
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 :: Parsec
  Void
  [(Range, RawLineComment)]
  (Maybe (CommentFlavour, [TestComment]), [TestComment])
lineGroupP = do
    (Range
_, CommentFlavour
flav) <- ParsecT
  Void [(Range, RawLineComment)] Identity (Range, CommentFlavour)
-> ParsecT
     Void [(Range, RawLineComment)] Identity (Range, CommentFlavour)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (ParsecT
   Void [(Range, RawLineComment)] Identity (Range, CommentFlavour)
 -> ParsecT
      Void [(Range, RawLineComment)] Identity (Range, CommentFlavour))
-> ParsecT
     Void [(Range, RawLineComment)] Identity (Range, CommentFlavour)
-> ParsecT
     Void [(Range, RawLineComment)] Identity (Range, CommentFlavour)
forall a b. (a -> b) -> a -> b
$ LineParser CommentFlavour
-> ParsecT
     Void [(Range, RawLineComment)] Identity (Range, CommentFlavour)
forall (f :: * -> *) a.
(Ord (f RawLineComment), Traversable f) =>
LineParser a -> Parsec Void [f RawLineComment] (f a)
parseLine (ParsecT Void String m CommentFlavour
LineParser CommentFlavour
commentFlavourP ParsecT Void String m CommentFlavour
-> ParsecT Void String m String
-> ParsecT Void String m CommentFlavour
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String m String
forall e s (m :: * -> *). MonadParsec e s m => m (Tokens s)
takeRest)
    case CommentFlavour
flav of
        Named String
"setup" -> (Maybe (CommentFlavour, [TestComment])
forall a. Maybe a
Nothing,) ([TestComment]
 -> (Maybe (CommentFlavour, [TestComment]), [TestComment]))
-> ParsecT Void [(Range, RawLineComment)] Identity [TestComment]
-> Parsec
     Void
     [(Range, RawLineComment)]
     (Maybe (CommentFlavour, [TestComment]), [TestComment])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void [(Range, RawLineComment)] Identity [TestComment]
lineCommentSectionsP
        CommentFlavour
flav          -> (,[TestComment]
forall a. Monoid a => a
mempty) (Maybe (CommentFlavour, [TestComment])
 -> (Maybe (CommentFlavour, [TestComment]), [TestComment]))
-> ([TestComment] -> Maybe (CommentFlavour, [TestComment]))
-> [TestComment]
-> (Maybe (CommentFlavour, [TestComment]), [TestComment])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CommentFlavour, [TestComment])
-> Maybe (CommentFlavour, [TestComment])
forall a. a -> Maybe a
Just ((CommentFlavour, [TestComment])
 -> Maybe (CommentFlavour, [TestComment]))
-> ([TestComment] -> (CommentFlavour, [TestComment]))
-> [TestComment]
-> Maybe (CommentFlavour, [TestComment])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CommentFlavour
flav,) ([TestComment]
 -> (Maybe (CommentFlavour, [TestComment]), [TestComment]))
-> ParsecT Void [(Range, RawLineComment)] Identity [TestComment]
-> Parsec
     Void
     [(Range, RawLineComment)]
     (Maybe (CommentFlavour, [TestComment]), [TestComment])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void [(Range, RawLineComment)] Identity [TestComment]
lineCommentSectionsP

-- >>>  parse (lineGroupP <*eof) "" $ (dummyPosition, ) . RawLineComment <$> ["-- a", "-- b"]

-- Variable not in scope: dummyPosition :: Position


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

lineCommentHeadP :: LineParser ()
lineCommentHeadP :: ParsecT Void String m ()
lineCommentHeadP = do
    -- and no operator symbol character follows.

    ParsecT Void String m String -> ParsecT Void String m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String m String -> ParsecT Void String m ())
-> ParsecT Void String m String -> ParsecT Void String m ()
forall a b. (a -> b) -> a -> b
$ Tokens String -> ParsecT Void String m (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"--"
    ParsecT Void String m Char -> ParsecT Void String m ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipMany (ParsecT Void String m Char -> ParsecT Void String m ())
-> ParsecT Void String m Char -> ParsecT Void String m ()
forall a b. (a -> b) -> a -> b
$ Token String -> ParsecT Void String m (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-'
    ParsecT Void String m (Maybe Char) -> ParsecT Void String m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String m (Maybe Char) -> ParsecT Void String m ())
-> ParsecT Void String m (Maybe Char) -> ParsecT Void String m ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void String m Char -> ParsecT Void String m (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT Void String m Char -> ParsecT Void String m (Maybe Char))
-> ParsecT Void String m Char -> ParsecT Void String m (Maybe Char)
forall a b. (a -> b) -> a -> b
$ Token String -> ParsecT Void String m (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
' '

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

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

resultLinesP :: LineGroupParser [String]
resultLinesP :: ParsecT Void [(Range, RawLineComment)] Identity [String]
resultLinesP = ParsecT Void [(Range, RawLineComment)] Identity String
-> ParsecT Void [(Range, RawLineComment)] Identity [String]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void [(Range, RawLineComment)] Identity String
nonEmptyLGP

normalLineCommentP :: LineGroupParser (Range, String)
normalLineCommentP :: ParsecT Void [(Range, RawLineComment)] Identity (Range, String)
normalLineCommentP =
    LineParser String
-> ParsecT Void [(Range, RawLineComment)] Identity (Range, String)
forall (f :: * -> *) a.
(Ord (f RawLineComment), Traversable f) =>
LineParser a -> Parsec Void [f RawLineComment] (f a)
parseLine ((String, Position) -> String
forall a b. (a, b) -> a
fst ((String, Position) -> String)
-> ParsecT Void String m CommentFlavour
-> ParsecT Void String m ((String, Position) -> String)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT Void String m CommentFlavour
LineParser CommentFlavour
commentFlavourP ParsecT Void String m ((String, Position) -> String)
-> ParsecT Void String m (String, Position)
-> ParsecT Void String m String
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 :: ParsecT Void [(Range, RawLineComment)] Identity String
nonEmptyLGP =
    ParsecT Void [(Range, RawLineComment)] Identity String
-> ParsecT Void [(Range, RawLineComment)] Identity String
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void [(Range, RawLineComment)] Identity String
 -> ParsecT Void [(Range, RawLineComment)] Identity String)
-> ParsecT Void [(Range, RawLineComment)] Identity String
-> ParsecT Void [(Range, RawLineComment)] Identity String
forall a b. (a -> b) -> a -> b
$
        ((Range, String) -> String)
-> ParsecT Void [(Range, RawLineComment)] Identity (Range, String)
-> ParsecT Void [(Range, RawLineComment)] Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Range, String) -> String
forall a b. (a, b) -> b
snd (ParsecT Void [(Range, RawLineComment)] Identity (Range, String)
 -> ParsecT Void [(Range, RawLineComment)] Identity String)
-> ParsecT Void [(Range, RawLineComment)] Identity (Range, String)
-> ParsecT Void [(Range, RawLineComment)] Identity String
forall a b. (a -> b) -> a -> b
$
            LineParser String
-> ParsecT Void [(Range, RawLineComment)] Identity (Range, String)
forall (f :: * -> *) a.
(Ord (f RawLineComment), Traversable f) =>
LineParser a -> Parsec Void [f RawLineComment] (f a)
parseLine (LineParser String
 -> ParsecT Void [(Range, RawLineComment)] Identity (Range, String))
-> LineParser String
-> ParsecT Void [(Range, RawLineComment)] Identity (Range, String)
forall a b. (a -> b) -> a -> b
$
                (String, Position) -> String
forall a b. (a, b) -> a
fst ((String, Position) -> String)
-> ParsecT Void String m CommentFlavour
-> ParsecT Void String m ((String, Position) -> String)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT Void String m CommentFlavour
LineParser CommentFlavour
commentFlavourP ParsecT Void String m ((String, Position) -> String)
-> ParsecT Void String m (String, Position)
-> ParsecT Void String m String
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 =
    ParsecT Void [(Range, RawLineComment)] Identity TestComment
-> ParsecT Void [(Range, RawLineComment)] Identity TestComment
forall a. LineGroupParser a -> LineGroupParser a
lexemeLine (ParsecT Void [(Range, RawLineComment)] Identity TestComment
 -> ParsecT Void [(Range, RawLineComment)] Identity TestComment)
-> ParsecT Void [(Range, RawLineComment)] Identity TestComment
-> ParsecT Void [(Range, RawLineComment)] Identity TestComment
forall a b. (a -> b) -> a -> b
$
        (Range -> NonEmpty ExampleLine -> [String] -> TestComment)
-> (Range, NonEmpty ExampleLine) -> [String] -> TestComment
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Range -> NonEmpty ExampleLine -> [String] -> TestComment
AnExample ((Range, NonEmpty ExampleLine) -> [String] -> TestComment)
-> (NonEmpty (Range, ExampleLine) -> (Range, NonEmpty ExampleLine))
-> NonEmpty (Range, ExampleLine)
-> [String]
-> TestComment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty Range -> Range)
-> (NonEmpty Range, NonEmpty ExampleLine)
-> (Range, NonEmpty ExampleLine)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first NonEmpty Range -> Range
convexHullRange ((NonEmpty Range, NonEmpty ExampleLine)
 -> (Range, NonEmpty ExampleLine))
-> (NonEmpty (Range, ExampleLine)
    -> (NonEmpty Range, NonEmpty ExampleLine))
-> NonEmpty (Range, ExampleLine)
-> (Range, NonEmpty ExampleLine)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Range, ExampleLine)
-> (NonEmpty Range, NonEmpty ExampleLine)
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
NE.unzip
            (NonEmpty (Range, ExampleLine) -> [String] -> TestComment)
-> ParsecT
     Void
     [(Range, RawLineComment)]
     Identity
     (NonEmpty (Range, ExampleLine))
-> ParsecT
     Void [(Range, RawLineComment)] Identity ([String] -> TestComment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT
  Void [(Range, RawLineComment)] Identity (Range, ExampleLine)
-> ParsecT
     Void
     [(Range, RawLineComment)]
     Identity
     (NonEmpty (Range, ExampleLine))
forall (m :: * -> *) a. Alternative m => m a -> m (NonEmpty a)
NE.some ParsecT
  Void [(Range, RawLineComment)] Identity (Range, ExampleLine)
exampleLineGP
            ParsecT
  Void [(Range, RawLineComment)] Identity ([String] -> TestComment)
-> ParsecT Void [(Range, RawLineComment)] Identity [String]
-> ParsecT Void [(Range, RawLineComment)] Identity TestComment
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void [(Range, RawLineComment)] Identity [String]
resultLinesP

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

exampleLineGP :: LineGroupParser (Range, ExampleLine)
exampleLineGP :: ParsecT
  Void [(Range, RawLineComment)] Identity (Range, ExampleLine)
exampleLineGP =
    -- In line-comments, indentation-level inside comment doesn't matter.

    LineParser ExampleLine
-> ParsecT
     Void [(Range, RawLineComment)] Identity (Range, ExampleLine)
forall (f :: * -> *) a.
(Ord (f RawLineComment), Traversable f) =>
LineParser a -> Parsec Void [f RawLineComment] (f a)
parseLine ((ExampleLine, Position) -> ExampleLine
forall a b. (a, b) -> a
fst ((ExampleLine, Position) -> ExampleLine)
-> ParsecT Void String m CommentFlavour
-> ParsecT Void String m ((ExampleLine, Position) -> ExampleLine)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT Void String m CommentFlavour
LineParser CommentFlavour
commentFlavourP ParsecT Void String m ((ExampleLine, Position) -> ExampleLine)
-> ParsecT Void String m (ExampleLine, Position)
-> ParsecT Void String m ExampleLine
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 :: ParsecT Void [(Range, RawLineComment)] Identity (Range, PropLine)
propLineGP =
    -- In line-comments, indentation-level inside comment doesn't matter.

    LineParser PropLine
-> ParsecT
     Void [(Range, RawLineComment)] Identity (Range, PropLine)
forall (f :: * -> *) a.
(Ord (f RawLineComment), Traversable f) =>
LineParser a -> Parsec Void [f RawLineComment] (f a)
parseLine ((PropLine, Position) -> PropLine
forall a b. (a, b) -> a
fst ((PropLine, Position) -> PropLine)
-> ParsecT Void String m CommentFlavour
-> ParsecT Void String m ((PropLine, Position) -> PropLine)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT Void String m CommentFlavour
LineParser CommentFlavour
commentFlavourP ParsecT Void String m ((PropLine, Position) -> PropLine)
-> ParsecT Void String m (PropLine, Position)
-> ParsecT Void String m PropLine
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 :: LineParser a -> Parsec Void [f RawLineComment] (f a)
parseLine LineParser a
p =
    (Token [f RawLineComment] -> Maybe (f a))
-> Set (ErrorItem (Token [f RawLineComment]))
-> Parsec Void [f RawLineComment] (f a)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(Token s -> Maybe a) -> Set (ErrorItem (Token s)) -> m a
P.token
        ((RawLineComment -> Maybe a) -> f RawLineComment -> Maybe (f a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((RawLineComment -> Maybe a) -> f RawLineComment -> Maybe (f a))
-> (RawLineComment -> Maybe a) -> f RawLineComment -> Maybe (f a)
forall a b. (a -> b) -> a -> b
$ Parsec Void String a -> String -> Maybe a
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
parseMaybe (ParsecT Void String Identity ()
LineParser ()
lineCommentHeadP ParsecT Void String Identity ()
-> Parsec Void String a -> Parsec Void String a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void String a
LineParser a
p) (String -> Maybe a)
-> (RawLineComment -> String) -> RawLineComment -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawLineComment -> String
getRawLineComment)
        Set (ErrorItem (Token [f RawLineComment]))
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 = ParsecT Void String m (String, Position)
-> ParsecT Void String m (String, Position)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void String m (String, Position)
 -> ParsecT Void String m (String, Position))
-> ParsecT Void String m (String, Position)
-> ParsecT Void String m (String, Position)
forall a b. (a -> b) -> a -> b
$ do
    (String
ln, Position
pos) <- Bool -> CommentStyle -> LineParser (String, Position)
normalLineP Bool
isLHS CommentStyle
style
    Bool -> ParsecT Void String m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ParsecT Void String m ())
-> Bool -> ParsecT Void String m ()
forall a b. (a -> b) -> a -> b
$
        case CommentStyle
style of
            Block{} -> Text -> Text
T.strip (String -> Text
T.pack String
ln) Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"{-", Text
"-}", Text
""]
            CommentStyle
_       -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
C.isSpace String
ln
    (String, Position) -> ParsecT Void String m (String, Position)
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
    ParsecT Void String m () -> ParsecT Void String m ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy
        (ParsecT Void String m () -> ParsecT Void String m ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void String m () -> ParsecT Void String m ())
-> ParsecT Void String m () -> ParsecT Void String m ()
forall a b. (a -> b) -> a -> b
$ Bool -> CommentStyle -> LineParser ()
testSymbol Bool
isLHS CommentStyle
style)
    Bool -> ParsecT Void String m () -> ParsecT Void String m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isLHS Bool -> Bool -> Bool
&& APrism CommentStyle CommentStyle Range Range
-> CommentStyle -> Bool
forall s t a b. APrism s t a b -> s -> Bool
is APrism CommentStyle CommentStyle Range Range
Prism' CommentStyle Range
_Block CommentStyle
style) (ParsecT Void String m () -> ParsecT Void String m ())
-> ParsecT Void String m () -> ParsecT Void String m ()
forall a b. (a -> b) -> a -> b
$
        ParsecT Void String m String -> ParsecT Void String m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String m String -> ParsecT Void String m ())
-> ParsecT Void String m String -> ParsecT Void String m ()
forall a b. (a -> b) -> a -> b
$ Int
-> Int
-> ParsecT Void String m Char
-> ParsecT Void String m String
forall (m :: * -> *) a. MonadPlus m => Int -> Int -> m a -> m [a]
count' Int
0 Int
2 (ParsecT Void String m Char -> ParsecT Void String m String)
-> ParsecT Void String m Char -> ParsecT Void String m String
forall a b. (a -> b) -> a -> b
$ Token String -> ParsecT Void String m (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
' '
    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     -> (,) (String -> Position -> (String, Position))
-> ParsecT Void String m String
-> ParsecT Void String m (Position -> (String, Position))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String m String
forall e s (m :: * -> *). MonadParsec e s m => m (Tokens s)
takeRest ParsecT Void String m (Position -> (String, Position))
-> ParsecT Void String m Position
-> ParsecT Void String m (String, Position)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void String m Position
forall v s (m :: * -> *).
(Ord v, TraversableStream s) =>
ParsecT v s m Position
getPosition
        Block {} -> ParsecT Void String m Char
-> ParsecT Void String m Position
-> ParsecT Void String m (String, Position)
forall (m :: * -> *) a end.
MonadPlus m =>
m a -> m end -> m ([a], end)
manyTill_ ParsecT Void String m Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle (ParsecT Void String m Position
forall v s (m :: * -> *).
(Ord v, TraversableStream s) =>
ParsecT v s m Position
getPosition ParsecT Void String m Position
-> ParsecT Void String m () -> ParsecT Void String m Position
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String m ()
LineParser ()
eob)

getPosition :: (Ord v, TraversableStream s) => ParsecT v s m Position
getPosition :: ParsecT v s m Position
getPosition = SourcePos -> Position
sourcePosToPosition (SourcePos -> Position)
-> ParsecT v s m SourcePos -> ParsecT v s m Position
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT v s m SourcePos
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 =
    ParsecT Void String m (ExampleLine, Position)
-> ParsecT Void String m (ExampleLine, Position)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void String m (ExampleLine, Position)
 -> ParsecT Void String m (ExampleLine, Position))
-> ParsecT Void String m (ExampleLine, Position)
-> ParsecT Void String m (ExampleLine, Position)
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.

        Bool -> ParsecT Void String m () -> ParsecT Void String m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isLHS Bool -> Bool -> Bool
&& APrism CommentStyle CommentStyle Range Range
-> CommentStyle -> Bool
forall s t a b. APrism s t a b -> s -> Bool
is APrism CommentStyle CommentStyle Range Range
Prism' CommentStyle Range
_Block CommentStyle
style) (ParsecT Void String m String -> ParsecT Void String m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String m String -> ParsecT Void String m ())
-> ParsecT Void String m String -> ParsecT Void String m ()
forall a b. (a -> b) -> a -> b
$ Int
-> Int
-> ParsecT Void String m Char
-> ParsecT Void String m String
forall (m :: * -> *) a. MonadPlus m => Int -> Int -> m a -> m [a]
count' Int
0 Int
2 (ParsecT Void String m Char -> ParsecT Void String m String)
-> ParsecT Void String m Char -> ParsecT Void String m String
forall a b. (a -> b) -> a -> b
$ Token String -> ParsecT Void String m (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
' ')
            ParsecT Void String m ()
-> ParsecT Void String m () -> ParsecT Void String m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String m ()
LineParser ()
exampleSymbol
            ParsecT Void String m ()
-> ParsecT Void String m (ExampleLine, Position)
-> ParsecT Void String m (ExampleLine, Position)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((String -> ExampleLine)
-> (String, Position) -> (ExampleLine, Position)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first String -> ExampleLine
ExampleLine ((String, Position) -> (ExampleLine, Position))
-> ParsecT Void String m (String, Position)
-> ParsecT Void String m (ExampleLine, Position)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CommentStyle -> LineParser (String, Position)
consume CommentStyle
style)

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

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

-- | 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.

    Bool -> ParsecT Void String m () -> ParsecT Void String m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isLHS Bool -> Bool -> Bool
&& APrism CommentStyle CommentStyle Range Range
-> CommentStyle -> Bool
forall s t a b. APrism s t a b -> s -> Bool
is APrism CommentStyle CommentStyle Range Range
Prism' CommentStyle Range
_Block CommentStyle
style) (ParsecT Void String m String -> ParsecT Void String m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String m String -> ParsecT Void String m ())
-> ParsecT Void String m String -> ParsecT Void String m ()
forall a b. (a -> b) -> a -> b
$ Int
-> Int
-> ParsecT Void String m Char
-> ParsecT Void String m String
forall (m :: * -> *) a. MonadPlus m => Int -> Int -> m a -> m [a]
count' Int
0 Int
2 (ParsecT Void String m Char -> ParsecT Void String m String)
-> ParsecT Void String m Char -> ParsecT Void String m String
forall a b. (a -> b) -> a -> b
$ Token String -> ParsecT Void String m (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
' ')
        ParsecT Void String m ()
-> ParsecT Void String m String -> ParsecT Void String m String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Tokens String -> ParsecT Void String m (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"prop>"
        ParsecT Void String m String
-> ParsecT Void String m () -> ParsecT Void String m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String m Char -> ParsecT Void String m ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
P.notFollowedBy (Token String -> ParsecT Void String m (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'>')
        ParsecT Void String m ()
-> ParsecT Void String m (PropLine, Position)
-> ParsecT Void String m (PropLine, Position)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((String -> PropLine) -> (String, Position) -> (PropLine, Position)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first String -> PropLine
PropLine ((String, Position) -> (PropLine, Position))
-> ParsecT Void String m (String, Position)
-> ParsecT Void String m (PropLine, Position)
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 -> (Int, Int)) -> [a] -> [NonEmpty a]
contiguousGroupOn :: (a -> (Int, Int)) -> [a] -> [NonEmpty a]
contiguousGroupOn a -> (Int, Int)
toLineCol = (a -> [NonEmpty a] -> [NonEmpty a])
-> [NonEmpty a] -> [a] -> [NonEmpty a]
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 [] = [a -> NonEmpty 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 (Int
aLine, Int
aCol) = a -> (Int, Int)
toLineCol a
a
              , let (Int
bLine, Int
bCol) = a -> (Int, Int)
toLineCol a
b
              , Int
aLine Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
bLine Bool -> Bool -> Bool
&& Int
aCol Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
bCol =
                (a
a a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
bs) NonEmpty a -> [NonEmpty a] -> [NonEmpty a]
forall a. a -> [a] -> [a]
: [NonEmpty a]
bss
            | Bool
otherwise = a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a NonEmpty a -> [NonEmpty a] -> [NonEmpty 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 :: Map Range a -> [NonEmpty (Range, a)]
groupLineComments =
    ((Range, a) -> (Int, Int)) -> [(Range, a)] -> [NonEmpty (Range, a)]
forall a. (a -> (Int, Int)) -> [a] -> [NonEmpty a]
contiguousGroupOn ((Range, a) -> Range
forall a b. (a, b) -> a
fst ((Range, a) -> Range)
-> (Range -> (Int, Int)) -> (Range, a) -> (Int, Int)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Getting Position Range Position -> Range -> Position
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Position Range Position
forall s a. HasStart s a => Lens' s a
start (Range -> Position)
-> (Position -> (Int, Int)) -> Range -> (Int, Int)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Int -> Const Int Int) -> Position -> Const Int Position)
-> Position -> Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasLine s a => Lens' s a
line (Position -> Int) -> (Position -> Int) -> Position -> (Int, Int)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ((Int -> Const Int Int) -> Position -> Const Int Position)
-> Position -> Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Int -> Const Int Int) -> Position -> Const Int Position
forall s a. HasCharacter s a => Lens' s a
character)
        ([(Range, a)] -> [NonEmpty (Range, a)])
-> (Map Range a -> [(Range, a)])
-> Map Range a
-> [NonEmpty (Range, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Range a -> [(Range, a)]
forall k a. Map k a -> [(k, a)]
Map.toList