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

module Ide.Plugin.Eval.Parse.Comments where

import qualified Control.Applicative.Combinators.NonEmpty as NE
import           Control.Arrow                            (first, (&&&), (>>>))
import           Control.Lens                             (lensField, lensRules,
                                                           view, (.~), (^.))
import           Control.Lens.Extras                      (is)
import           Control.Lens.TH                          (makeLensesWith,
                                                           makePrisms,
                                                           mappingNamer)
import           Control.Monad                            (guard, void, when)
import           Control.Monad.Combinators                ()
import           Control.Monad.Reader                     (ask)
import           Control.Monad.Trans.Reader               (Reader, runReader)
import qualified Data.Char                                as C
import qualified Data.DList                               as DL
import qualified Data.Foldable                            as F
import           Data.Function                            ((&))
import           Data.Functor                             ((<&>))
import           Data.Functor.Identity
import           Data.List.NonEmpty                       (NonEmpty ((:|)))
import qualified Data.List.NonEmpty                       as NE
import           Data.Map.Strict                          (Map)
import qualified Data.Map.Strict                          as Map
import qualified Data.Text                                as T
import           Data.Void                                (Void)
import           Development.IDE                          (Position,
                                                           Range (Range))
import           Development.IDE.Types.Location           (Position (..))
import           GHC.Generics                             hiding (UInt, to)
import           Ide.Plugin.Eval.Types
import           Language.LSP.Types                       (UInt)
import           Language.LSP.Types.Lens                  (character, end, line,
                                                           start)
import           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 UInt Range UInt -> UInt
forall s a. s -> Getting a s a -> a
^. (Position -> Const UInt Position) -> Range -> Const UInt Range
forall s a. HasStart s a => Lens' s a
start ((Position -> Const UInt Position) -> Range -> Const UInt Range)
-> ((UInt -> Const UInt UInt) -> Position -> Const UInt Position)
-> Getting UInt Range UInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UInt -> Const UInt UInt) -> Position -> Const UInt Position
forall s a. HasCharacter s a => Lens' s a
character UInt -> UInt -> Bool
forall a. Eq a => a -> a -> Bool
== UInt
2
                                else Range
pos Range -> Getting UInt Range UInt -> UInt
forall s a. s -> Getting a s a -> a
^. (Position -> Const UInt Position) -> Range -> Const UInt Range
forall s a. HasStart s a => Lens' s a
start ((Position -> Const UInt Position) -> Range -> Const UInt Range)
-> ((UInt -> Const UInt UInt) -> Position -> Const UInt Position)
-> Getting UInt Range UInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UInt -> Const UInt UInt) -> Position -> Const UInt Position
forall s a. HasCharacter s a => Lens' s a
character UInt -> UInt -> Bool
forall a. Eq a => a -> a -> Bool
== UInt
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)
-> ParsecT Void String (Reader BlockEnv) (String, Position)
-> ParsecT Void String (Reader BlockEnv) String
forall a b. (a -> b) -> a -> b
$ Bool -> CommentStyle -> LineParser (String, Position)
nonEmptyNormalLineP Bool
isLhs (CommentStyle -> LineParser (String, Position))
-> CommentStyle -> LineParser (String, Position)
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
$ UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt -> Int) -> UInt -> Int
forall a b. (a -> b) -> a -> b
$ UInt
1 UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ Position
pos Position
-> ((UInt -> Const UInt UInt) -> Position -> Const UInt Position)
-> UInt
forall s a. s -> Getting a s a -> a
^. (UInt -> Const UInt UInt) -> Position -> Const UInt 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
$ UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt -> Int) -> UInt -> Int
forall a b. (a -> b) -> a -> b
$ UInt
1 UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ Position
pos Position
-> ((UInt -> Const UInt UInt) -> Position -> Const UInt Position)
-> UInt
forall s a. s -> Getting a s a -> a
^. (UInt -> Const UInt UInt) -> Position -> Const UInt 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
..} =
    UInt -> UInt -> Position
Position (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ Pos -> Int
unPos Pos
sourceLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> Int -> UInt
forall a b. (a -> b) -> a -> b
$ 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 -> (UInt, UInt)) -> [a] -> [NonEmpty a]
contiguousGroupOn :: (a -> (UInt, UInt)) -> [a] -> [NonEmpty a]
contiguousGroupOn a -> (UInt, UInt)
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 (UInt
aLine, UInt
aCol) = a -> (UInt, UInt)
toLineCol a
a
              , let (UInt
bLine, UInt
bCol) = a -> (UInt, UInt)
toLineCol a
b
              , UInt
aLine UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
1 UInt -> UInt -> Bool
forall a. Eq a => a -> a -> Bool
== UInt
bLine Bool -> Bool -> Bool
&& UInt
aCol UInt -> UInt -> Bool
forall a. Eq a => a -> a -> Bool
== UInt
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) -> (UInt, UInt))
-> [(Range, a)] -> [NonEmpty (Range, a)]
forall a. (a -> (UInt, UInt)) -> [a] -> [NonEmpty a]
contiguousGroupOn ((Range, a) -> Range
forall a b. (a, b) -> a
fst ((Range, a) -> Range)
-> (Range -> (UInt, UInt)) -> (Range, a) -> (UInt, UInt)
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 -> (UInt, UInt)) -> Range -> (UInt, UInt)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((UInt -> Const UInt UInt) -> Position -> Const UInt Position)
-> Position -> UInt
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (UInt -> Const UInt UInt) -> Position -> Const UInt Position
forall s a. HasLine s a => Lens' s a
line (Position -> UInt)
-> (Position -> UInt) -> Position -> (UInt, UInt)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ((UInt -> Const UInt UInt) -> Position -> Const UInt Position)
-> Position -> UInt
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (UInt -> Const UInt UInt) -> Position -> Const UInt 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