{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE TemplateHaskell    #-}

module Ide.Plugin.Eval.Parse.Comments where

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

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

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

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

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

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

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

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

data BlockEnv = BlockEnv
    { BlockEnv -> Bool
isLhs      :: Bool
    , BlockEnv -> Range
blockRange :: Range
    }
    deriving (Int -> BlockEnv -> ShowS
[BlockEnv] -> ShowS
BlockEnv -> String
(Int -> BlockEnv -> ShowS)
-> (BlockEnv -> String) -> ([BlockEnv] -> ShowS) -> Show BlockEnv
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BlockEnv -> ShowS
showsPrec :: Int -> BlockEnv -> ShowS
$cshow :: BlockEnv -> String
show :: BlockEnv -> String
$cshowList :: [BlockEnv] -> ShowS
showList :: [BlockEnv] -> ShowS
Show, BlockEnv -> BlockEnv -> Bool
(BlockEnv -> BlockEnv -> Bool)
-> (BlockEnv -> BlockEnv -> Bool) -> Eq BlockEnv
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BlockEnv -> BlockEnv -> Bool
== :: BlockEnv -> BlockEnv -> Bool
$c/= :: BlockEnv -> BlockEnv -> Bool
/= :: 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
$ccompare :: BlockEnv -> BlockEnv -> Ordering
compare :: BlockEnv -> BlockEnv -> Ordering
$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
>= :: BlockEnv -> BlockEnv -> Bool
$cmax :: BlockEnv -> BlockEnv -> BlockEnv
max :: BlockEnv -> BlockEnv -> BlockEnv
$cmin :: BlockEnv -> BlockEnv -> BlockEnv
min :: BlockEnv -> BlockEnv -> 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
$cshowsPrec :: Int -> PropLine -> ShowS
showsPrec :: Int -> PropLine -> ShowS
$cshow :: PropLine -> String
show :: PropLine -> String
$cshowList :: [PropLine] -> ShowS
showList :: [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
$cshowsPrec :: Int -> ExampleLine -> ShowS
showsPrec :: Int -> ExampleLine -> ShowS
$cshow :: ExampleLine -> String
show :: ExampleLine -> String
$cshowList :: [ExampleLine] -> ShowS
showList :: [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
$cshowsPrec :: Int -> TestComment -> ShowS
showsPrec :: Int -> TestComment -> ShowS
$cshow :: TestComment -> String
show :: TestComment -> String
$cshowList :: [TestComment] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS CommentFlavour
readsPrec :: Int -> ReadS CommentFlavour
$creadList :: ReadS [CommentFlavour]
readList :: ReadS [CommentFlavour]
$creadPrec :: ReadPrec CommentFlavour
readPrec :: ReadPrec CommentFlavour
$creadListPrec :: ReadPrec [CommentFlavour]
readListPrec :: ReadPrec [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
$cshowsPrec :: Int -> CommentFlavour -> ShowS
showsPrec :: Int -> CommentFlavour -> ShowS
$cshow :: CommentFlavour -> String
show :: CommentFlavour -> String
$cshowList :: [CommentFlavour] -> ShowS
showList :: [CommentFlavour] -> ShowS
Show, CommentFlavour -> CommentFlavour -> Bool
(CommentFlavour -> CommentFlavour -> Bool)
-> (CommentFlavour -> CommentFlavour -> Bool) -> Eq CommentFlavour
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CommentFlavour -> CommentFlavour -> Bool
== :: CommentFlavour -> CommentFlavour -> Bool
$c/= :: CommentFlavour -> CommentFlavour -> Bool
/= :: 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
$ccompare :: CommentFlavour -> CommentFlavour -> Ordering
compare :: CommentFlavour -> CommentFlavour -> Ordering
$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
>= :: CommentFlavour -> CommentFlavour -> Bool
$cmax :: CommentFlavour -> CommentFlavour -> CommentFlavour
max :: CommentFlavour -> CommentFlavour -> CommentFlavour
$cmin :: CommentFlavour -> CommentFlavour -> CommentFlavour
min :: CommentFlavour -> CommentFlavour -> CommentFlavour
Ord)

-- | Single line or block comments?
data CommentStyle = Line | Block Range
    deriving (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
$cshowsPrec :: Int -> CommentStyle -> ShowS
showsPrec :: Int -> CommentStyle -> ShowS
$cshow :: CommentStyle -> String
show :: CommentStyle -> String
$cshowList :: [CommentStyle] -> ShowS
showList :: [CommentStyle] -> ShowS
Show, CommentStyle -> CommentStyle -> Bool
(CommentStyle -> CommentStyle -> Bool)
-> (CommentStyle -> CommentStyle -> Bool) -> Eq CommentStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CommentStyle -> CommentStyle -> Bool
== :: CommentStyle -> CommentStyle -> Bool
$c/= :: CommentStyle -> CommentStyle -> Bool
/= :: 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
$ccompare :: CommentStyle -> CommentStyle -> Ordering
compare :: CommentStyle -> CommentStyle -> Ordering
$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
>= :: CommentStyle -> CommentStyle -> Bool
$cmax :: CommentStyle -> CommentStyle -> CommentStyle
max :: CommentStyle -> CommentStyle -> CommentStyle
$cmin :: CommentStyle -> CommentStyle -> CommentStyle
min :: CommentStyle -> CommentStyle -> 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
$cfrom :: forall x. CommentStyle -> Rep CommentStyle x
from :: forall x. CommentStyle -> Rep CommentStyle x
$cto :: forall x. Rep CommentStyle x -> CommentStyle
to :: forall x. Rep CommentStyle x -> CommentStyle
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
lineComments :: Map Range RawLineComment
blockComments :: Map Range RawBlockComment
lineComments :: Comments -> Map Range RawLineComment
blockComments :: Comments -> Map Range RawBlockComment
..} =
    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 m a. Monoid m => (a -> m) -> [a] -> m
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
Lens' Range Position
L.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
Lens' Range Position
L.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 a. [a] -> 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
Lens' Range Position
L.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
Lens' Position UInt
L.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
Lens' Range Position
L.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
Lens' Position UInt
L.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 m a. Monoid m => (a -> m) -> [a] -> m
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 m. Monoid m => Map Range m -> m
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 a. Map Range a -> [a]
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]
setupSections :: [Section]
nonSetupSections :: [Section]
nonSetupSections :: [Section]
setupSections :: [Section]
..}

parseBlockMaybe :: Bool -> Range -> BlockCommentParser a -> String -> Maybe a
parseBlockMaybe :: forall a.
Bool -> Range -> BlockCommentParser a -> String -> Maybe a
parseBlockMaybe Bool
isLhs Range
blockRange BlockCommentParser a
p String
i =
    case 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
isLhs :: Bool
blockRange :: Range
isLhs :: Bool
blockRange :: Range
..} 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 =
                        (statePosState st)
                            { pstateSourcePos = positionToSourcePos $ blockRange ^. L.start
                            }
                    }
            BlockCommentParser a
p

type CommentRange = Range

type SectionRange = Range

testsToSection ::
    CommentStyle ->
    CommentFlavour ->
    [TestComment] ->
    Section
testsToSection :: CommentStyle -> CommentFlavour -> [TestComment] -> Section
testsToSection CommentStyle
style CommentFlavour
flav [TestComment]
tests =
    let sectionName :: String
sectionName
            | Named String
name <- CommentFlavour
flav = String
name
            | Bool
otherwise = String
""
        sectionLanguage :: Language
sectionLanguage = case CommentFlavour
flav of
            CommentFlavour
HaddockNext -> Language
Haddock
            CommentFlavour
HaddockPrev -> Language
Haddock
            CommentFlavour
_           -> Language
Plain
        sectionTests :: [Test]
sectionTests = (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
sectionName :: String
sectionLanguage :: Language
sectionTests :: [Test]
sectionFormat :: Format
sectionName :: String
sectionTests :: [Test]
sectionLanguage :: Language
sectionFormat :: Format
..}

fromTestComment :: TestComment -> Test
fromTestComment :: TestComment -> Test
fromTestComment AProp {[String]
Range
PropLine
testCommentRange :: TestComment -> Range
lineProp :: TestComment -> PropLine
propResults :: TestComment -> [String]
testCommentRange :: Range
lineProp :: PropLine
propResults :: [String]
..} =
    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
testCommentRange :: TestComment -> Range
lineExamples :: TestComment -> NonEmpty ExampleLine
exampleResults :: TestComment -> [String]
testCommentRange :: Range
lineExamples :: NonEmpty ExampleLine
exampleResults :: [String]
..} =
    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) (Token String)
-> ParsecT Void String (Reader BlockEnv) ()
forall (m :: * -> *) a. Monad m => Int -> m a -> m ()
skipCount Int
2 ParsecT Void String (Reader BlockEnv) (Token String)
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 a.
ParsecT Void String (Reader BlockEnv) a
-> ParsecT Void String (Reader BlockEnv) a
-> ParsecT Void String (Reader BlockEnv) a
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 a b.
ParsecT Void String (Reader BlockEnv) a
-> ParsecT Void String (Reader BlockEnv) b
-> ParsecT Void String (Reader BlockEnv) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* BlockCommentParser Bool
skipNormalCommentBlock
            ParsecT Void String (Reader BlockEnv) (Tokens String)
-> ParsecT Void String (Reader BlockEnv) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void String (Reader BlockEnv) (Tokens String)
forall e s (m :: * -> *). MonadParsec e s m => m (Tokens s)
takeRest -- just consume the rest
            (CommentFlavour, [TestComment])
-> BlockCommentParser (CommentFlavour, [TestComment])
forall a. a -> ParsecT Void String (Reader BlockEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommentFlavour
flav, [TestComment]
body)
        else (CommentFlavour, [TestComment])
-> BlockCommentParser (CommentFlavour, [TestComment])
forall a. a -> ParsecT Void String (Reader BlockEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommentFlavour
flav, [])

skipNormalCommentBlock :: BlockCommentParser Bool
skipNormalCommentBlock :: BlockCommentParser Bool
skipNormalCommentBlock = do
    BlockEnv {Bool
Range
isLhs :: BlockEnv -> Bool
blockRange :: BlockEnv -> Range
isLhs :: Bool
blockRange :: Range
..} <- 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 a b.
a
-> ParsecT Void String (Reader BlockEnv) b
-> ParsecT Void String (Reader BlockEnv) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT Void String (Reader BlockEnv) ()
-> ParsecT Void String (Reader BlockEnv) ()
forall a.
ParsecT Void String (Reader BlockEnv) a
-> ParsecT Void String (Reader BlockEnv) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void String (Reader BlockEnv) (Tokens String)
-> ParsecT Void String (Reader BlockEnv) (Maybe (Tokens 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 (Tokens String))
-> ParsecT Void String (Reader BlockEnv) ()
-> ParsecT Void String (Reader BlockEnv) ()
forall a b.
ParsecT Void String (Reader BlockEnv) a
-> ParsecT Void String (Reader BlockEnv) b
-> ParsecT Void String (Reader BlockEnv) b
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 a.
ParsecT Void String (Reader BlockEnv) a
-> ParsecT Void String (Reader BlockEnv) a
-> ParsecT Void String (Reader BlockEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool
True Bool
-> ParsecT Void String (Reader BlockEnv) ()
-> BlockCommentParser Bool
forall a b.
a
-> ParsecT Void String (Reader BlockEnv) b
-> ParsecT Void String (Reader BlockEnv) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT Void String (Reader BlockEnv) ()
-> ParsecT Void String (Reader BlockEnv) ()
forall a.
ParsecT Void String (Reader BlockEnv) a
-> ParsecT Void String (Reader BlockEnv) a
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 a.
ParsecT Void String (Reader BlockEnv) a
-> ParsecT Void String (Reader BlockEnv) a
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 a b.
ParsecT Void String m a
-> ParsecT Void String m b -> ParsecT Void String m b
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 a.
ParsecT Void String m a
-> ParsecT Void String m a -> ParsecT Void String m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void String m ()
LineParser ()
propSymbol)

eob :: LineParser ()
eob :: LineParser ()
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 a.
ParsecT Void String m a
-> ParsecT Void String m a -> ParsecT Void String m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void String m () -> ParsecT Void String m ()
forall a. ParsecT Void String m a -> ParsecT Void String m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void String m (Tokens String)
-> ParsecT Void String m (Maybe (Tokens 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 (Tokens String))
-> ParsecT Void String m () -> ParsecT Void String m ()
forall a b.
ParsecT Void String m a
-> ParsecT Void String m b -> ParsecT Void String m b
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 a.
ParsecT Void String m a
-> ParsecT Void String m a -> ParsecT Void String m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void String m (Tokens String) -> ParsecT Void String m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void String m (Tokens 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
isLhs :: BlockEnv -> Bool
blockRange :: BlockEnv -> Range
isLhs :: Bool
blockRange :: Range
..} <- 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 v (t :: * -> *) (m :: * -> *) a.
(TraversableStream s, 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
isLhs :: BlockEnv -> Bool
blockRange :: BlockEnv -> Range
isLhs :: Bool
blockRange :: Range
..} <- 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 v (t :: * -> *) (m :: * -> *) a.
(TraversableStream s, 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 a b.
(a -> b)
-> ParsecT Void String (Reader BlockEnv) a
-> ParsecT Void String (Reader BlockEnv) b
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, Ord v, Traversable t) =>
    ParsecT v s m (t (a, Position)) ->
    ParsecT v s m (Range, t a)
withRange :: forall s v (t :: * -> *) (m :: * -> *) a.
(TraversableStream s, Ord v, Traversable t) =>
ParsecT v s m (t (a, Position)) -> ParsecT v s m (Range, t a)
withRange ParsecT v s m (t (a, Position))
p = do
    Position
beg <- SourcePos -> Position
sourcePosToPosition (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 a. t a -> 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. HasCallStack => [a] -> a
last ([(a, Position)] -> (a, Position))
-> [(a, Position)] -> (a, Position)
forall a b. (a -> b) -> a -> b
$ t (a, Position) -> [(a, Position)]
forall a. t a -> [a]
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 a. a -> ParsecT v s m 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
isLhs :: BlockEnv -> Bool
blockRange :: BlockEnv -> Range
isLhs :: Bool
blockRange :: Range
..} <- 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 a b.
(a -> b)
-> ParsecT Void String (Reader BlockEnv) a
-> ParsecT Void String (Reader BlockEnv) b
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 =
    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
Lens' Position UInt
L.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
Lens' Position UInt
L.character
        }

sourcePosToPosition :: SourcePos -> Position
sourcePosToPosition :: SourcePos -> Position
sourcePosToPosition SourcePos {String
Pos
sourceName :: SourcePos -> String
sourceLine :: SourcePos -> Pos
sourceColumn :: SourcePos -> Pos
sourceName :: String
sourceLine :: Pos
sourceColumn :: Pos
..} =
    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 a.
ParsecT Void [(Range, RawLineComment)] Identity a
-> ParsecT Void [(Range, RawLineComment)] Identity a
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 (Tokens String)
-> ParsecT Void String m CommentFlavour
forall a b.
ParsecT Void String m a
-> ParsecT Void String m b -> ParsecT Void String m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String m (Tokens 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 :: LineParser 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 a b. a -> ParsecT Void String m b -> ParsecT Void String m a
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 a.
ParsecT Void String m a
-> ParsecT Void String m a -> ParsecT Void String m a
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 a b. a -> ParsecT Void String m b -> ParsecT Void String m a
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 a.
ParsecT Void String m a
-> ParsecT Void String m a -> ParsecT Void String m a
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 a b. a -> ParsecT Void String m b -> ParsecT Void String m a
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 a b.
ParsecT Void String m a
-> ParsecT Void String m b -> ParsecT Void String m a
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 a b.
ParsecT Void String m (a -> b)
-> ParsecT Void String m a -> ParsecT Void String m b
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
ParsecT Void String m (Token String)
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 a b.
ParsecT Void String m (a -> b)
-> ParsecT Void String m a -> ParsecT Void String m b
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
ParsecT Void String m (Token String)
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 a b.
ParsecT Void String m a
-> ParsecT Void String m b -> ParsecT Void String m a
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 :: LineParser ()
lineCommentHeadP = do
    -- and no operator symbol character follows.
    ParsecT Void String m (Tokens String) -> ParsecT Void String m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String m (Tokens String) -> ParsecT Void String m ())
-> ParsecT Void String m (Tokens 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 a.
ParsecT Void [(Range, RawLineComment)] Identity a
-> ParsecT Void [(Range, RawLineComment)] Identity a
-> ParsecT Void [(Range, RawLineComment)] Identity a
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 a b.
ParsecT Void [(Range, RawLineComment)] Identity (a -> b)
-> ParsecT Void [(Range, RawLineComment)] Identity a
-> ParsecT Void [(Range, RawLineComment)] Identity b
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 a b.
ParsecT Void [(Range, RawLineComment)] Identity a
-> ParsecT Void [(Range, RawLineComment)] Identity b
-> ParsecT Void [(Range, RawLineComment)] Identity 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

lexemeLine :: LineGroupParser a -> LineGroupParser a
lexemeLine :: forall a.
ParsecT Void [(Range, RawLineComment)] Identity a
-> ParsecT Void [(Range, RawLineComment)] Identity a
lexemeLine LineGroupParser a
p = LineGroupParser a
p LineGroupParser a
-> ParsecT Void [(Range, RawLineComment)] Identity ()
-> LineGroupParser a
forall a b.
ParsecT Void [(Range, RawLineComment)] Identity a
-> ParsecT Void [(Range, RawLineComment)] Identity b
-> ParsecT Void [(Range, RawLineComment)] Identity 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 a b. a -> ParsecT Void String m b -> ParsecT Void String m a
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 a b.
ParsecT Void String m (a -> b)
-> ParsecT Void String m a -> ParsecT Void String m b
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 a.
ParsecT Void [(Range, RawLineComment)] Identity a
-> ParsecT Void [(Range, RawLineComment)] Identity a
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 a b.
(a -> b)
-> ParsecT Void [(Range, RawLineComment)] Identity a
-> ParsecT Void [(Range, RawLineComment)] Identity b
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 a b. a -> ParsecT Void String m b -> ParsecT Void String m a
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 a b.
ParsecT Void String m (a -> b)
-> ParsecT Void String m a -> ParsecT Void String m b
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.
ParsecT Void [(Range, RawLineComment)] Identity a
-> ParsecT Void [(Range, RawLineComment)] Identity 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 b c d. (b -> c) -> (b, d) -> (c, d)
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 a b.
ParsecT Void [(Range, RawLineComment)] Identity (a -> b)
-> ParsecT Void [(Range, RawLineComment)] Identity a
-> ParsecT Void [(Range, RawLineComment)] Identity b
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
Lens' Range Position
L.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
Lens' Range Position
L.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 a b. a -> ParsecT Void String m b -> ParsecT Void String m a
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 a b.
ParsecT Void String m (a -> b)
-> ParsecT Void String m a -> ParsecT Void String m b
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 a b. a -> ParsecT Void String m b -> ParsecT Void String m a
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 a b.
ParsecT Void String m (a -> b)
-> ParsecT Void String m a -> ParsecT Void String m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> CommentStyle -> LineParser (PropLine, Position)
propLineStrP Bool
False CommentStyle
Line)

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

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

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

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

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

>>> parseMaybe (parseLine takeRest) $ pck ""
Nothing
-}
parseLine ::
    (Ord (f RawLineComment), Traversable f) =>
    LineParser a ->
    Parsec Void [f RawLineComment] (f a)
parseLine :: forall (f :: * -> *) a.
(Ord (f RawLineComment), Traversable f) =>
LineParser a -> Parsec Void [f RawLineComment] (f a)
parseLine LineParser a
p =
    (Token [f RawLineComment] -> Maybe (f a))
-> Set (ErrorItem (Token [f RawLineComment]))
-> ParsecT Void [f RawLineComment] Identity (f a)
forall a.
(Token [f RawLineComment] -> Maybe a)
-> Set (ErrorItem (Token [f RawLineComment]))
-> ParsecT Void [f RawLineComment] Identity 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> f a -> m (f 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 a b.
ParsecT Void String Identity a
-> ParsecT Void String Identity b -> ParsecT Void String Identity b
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 (f RawLineComment))
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 a. ParsecT Void String m a -> ParsecT Void String m a
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 a. a -> ParsecT Void String m a
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 a. ParsecT Void String m a -> 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 a. ParsecT Void String m a -> ParsecT Void String m a
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
ParsecT Void String m (Tokens 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 a b.
ParsecT Void String m (a -> b)
-> ParsecT Void String m a -> ParsecT Void String m b
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
ParsecT Void String m (Token String)
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 a b.
ParsecT Void String m a
-> ParsecT Void String m b -> ParsecT Void String m a
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 :: forall v s (m :: * -> *).
(Ord v, TraversableStream s) =>
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 a. ParsecT Void String m a -> ParsecT Void String m a
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 a b.
ParsecT Void String m a
-> ParsecT Void String m b -> ParsecT Void String m b
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 a b.
ParsecT Void String m a
-> ParsecT Void String m b -> ParsecT Void String m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((String -> ExampleLine)
-> (String, Position) -> (ExampleLine, Position)
forall b c d. (b -> c) -> (b, d) -> (c, d)
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 :: LineParser ()
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 (Tokens String)
-> ParsecT Void String m () -> ParsecT Void String m ()
forall a b.
ParsecT Void String m a
-> ParsecT Void String m b -> ParsecT Void String m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String m Char -> ParsecT Void String m ()
forall a. ParsecT Void String m a -> 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 :: LineParser ()
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 (Tokens String)
-> ParsecT Void String m () -> ParsecT Void String m ()
forall a b.
ParsecT Void String m a
-> ParsecT Void String m b -> ParsecT Void String m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String m Char -> ParsecT Void String m ()
forall a. ParsecT Void String m a -> 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 (Tokens String)
-> ParsecT Void String m (Tokens String)
forall a b.
ParsecT Void String m a
-> ParsecT Void String m b -> ParsecT Void String m b
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 (Tokens String)
-> ParsecT Void String m () -> ParsecT Void String m ()
forall a b.
ParsecT Void String m a
-> ParsecT Void String m b -> ParsecT Void String m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String m Char -> ParsecT Void String m ()
forall a. ParsecT Void String m a -> 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 a b.
ParsecT Void String m a
-> ParsecT Void String m b -> ParsecT Void String m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((String -> PropLine) -> (String, Position) -> (PropLine, Position)
forall b c d. (b -> c) -> (b, d) -> (c, d)
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 :: forall a. (a -> (UInt, UInt)) -> [a] -> [NonEmpty a]
contiguousGroupOn a -> (UInt, UInt)
toLineCol = (a -> [NonEmpty a] -> [NonEmpty a])
-> [NonEmpty a] -> [a] -> [NonEmpty a]
forall a b. (a -> b -> b) -> b -> [a] -> b
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 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 a. 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 :: forall a. 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
Lens' Range Position
L.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
Lens' Position UInt
L.line (Position -> UInt)
-> (Position -> UInt) -> Position -> (UInt, UInt)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
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
Lens' Position UInt
L.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