{-# OPTIONS_GHC -Wwarn #-}

-- | Parse source code into a list of line Tokens.
module Ide.Plugin.Eval.Parse.Token (
    Token (..),
    TokenS,
    tokensFrom,
    unsafeContent,
    isStatement,
    isTextLine,
    isPropLine,
    isCodeLine,
    isBlockOpen,
    isBlockClose,
) where

import Control.Monad.Combinators (
    many,
    optional,
    skipManyTill,
    (<|>),
 )
import Data.Functor (($>))
import Data.List (foldl')
import Ide.Plugin.Eval.Parse.Parser (
    Parser,
    alphaNumChar,
    char,
    letterChar,
    runParser,
    satisfy,
    space,
    string,
    tillEnd,
 )
import Ide.Plugin.Eval.Types (
    Format (..),
    Language (..),
    Loc,
    Located (Located),
 )
import Maybes (fromJust, fromMaybe)

type TParser = Parser Char (State, [TokenS])

data State = InCode | InSingleComment | InMultiComment deriving (State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: State -> State -> Bool
$c/= :: State -> State -> Bool
== :: State -> State -> Bool
$c== :: State -> State -> Bool
Eq, Int -> State -> ShowS
[State] -> ShowS
State -> String
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: Int -> State -> ShowS
$cshowsPrec :: Int -> State -> ShowS
Show)

commentState :: Bool -> State
commentState :: Bool -> State
commentState Bool
True = State
InMultiComment
commentState Bool
False = State
InSingleComment

type TokenS = Token String

data Token s
    = -- | Text, without prefix "(--)? >>>"
      Statement s
    | -- | Text, without prefix "(--)? prop>"
      PropLine s
    | -- | Text inside a comment
      TextLine s
    | -- | Line of code (outside comments)
      CodeLine
    | -- | Open of comment
      BlockOpen {Token s -> Maybe s
blockName :: Maybe s, Token s -> Language
blockLanguage :: Language, Token s -> Format
blockFormat :: Format}
    | -- | Close of multi-line comment
      BlockClose
    deriving (Token s -> Token s -> Bool
(Token s -> Token s -> Bool)
-> (Token s -> Token s -> Bool) -> Eq (Token s)
forall s. Eq s => Token s -> Token s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token s -> Token s -> Bool
$c/= :: forall s. Eq s => Token s -> Token s -> Bool
== :: Token s -> Token s -> Bool
$c== :: forall s. Eq s => Token s -> Token s -> Bool
Eq, Int -> Token s -> ShowS
[Token s] -> ShowS
Token s -> String
(Int -> Token s -> ShowS)
-> (Token s -> String) -> ([Token s] -> ShowS) -> Show (Token s)
forall s. Show s => Int -> Token s -> ShowS
forall s. Show s => [Token s] -> ShowS
forall s. Show s => Token s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token s] -> ShowS
$cshowList :: forall s. Show s => [Token s] -> ShowS
show :: Token s -> String
$cshow :: forall s. Show s => Token s -> String
showsPrec :: Int -> Token s -> ShowS
$cshowsPrec :: forall s. Show s => Int -> Token s -> ShowS
Show)

isStatement :: Token s -> Bool
isStatement :: Token s -> Bool
isStatement (Statement s
_) = Bool
True
isStatement Token s
_ = Bool
False

isTextLine :: Token s -> Bool
isTextLine :: Token s -> Bool
isTextLine (TextLine s
_) = Bool
True
isTextLine Token s
_ = Bool
False

isPropLine :: Token s -> Bool
isPropLine :: Token s -> Bool
isPropLine (PropLine s
_) = Bool
True
isPropLine Token s
_ = Bool
False

isCodeLine :: Token s -> Bool
isCodeLine :: Token s -> Bool
isCodeLine Token s
CodeLine = Bool
True
isCodeLine Token s
_ = Bool
False

isBlockOpen :: Token s -> Bool
isBlockOpen :: Token s -> Bool
isBlockOpen (BlockOpen Maybe s
_ Language
_ Format
_) = Bool
True
isBlockOpen Token s
_ = Bool
False

isBlockClose :: Token s -> Bool
isBlockClose :: Token s -> Bool
isBlockClose Token s
BlockClose = Bool
True
isBlockClose Token s
_ = Bool
False

unsafeContent :: Token a -> a
unsafeContent :: Token a -> a
unsafeContent = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> (Token a -> Maybe a) -> Token a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token a -> Maybe a
forall a. Token a -> Maybe a
contentOf

contentOf :: Token a -> Maybe a
contentOf :: Token a -> Maybe a
contentOf (Statement a
c) = a -> Maybe a
forall a. a -> Maybe a
Just a
c
contentOf (PropLine a
c) = a -> Maybe a
forall a. a -> Maybe a
Just a
c
contentOf (TextLine a
c) = a -> Maybe a
forall a. a -> Maybe a
Just a
c
contentOf Token a
_ = Maybe a
forall a. Maybe a
Nothing

{- | Parse source code and return a list of located Tokens
>>> import           Ide.Plugin.Eval.Types        (unLoc)
>>> tks src = map unLoc . tokensFrom  <$> readFile src

>>> tks "test/testdata/eval/T1.hs"
[CodeLine,CodeLine,CodeLine,CodeLine,BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = SingleLine},Statement " unwords example",CodeLine,CodeLine]

>>> tks "test/testdata/eval/TLanguageOptions.hs"
[BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = SingleLine},TextLine "Support for language options",CodeLine,CodeLine,CodeLine,CodeLine,BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = SingleLine},TextLine "Language options set in the module source (ScopedTypeVariables)",TextLine "also apply to tests so this works fine",Statement " f = (\\(c::Char) -> [c])",CodeLine,BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine},TextLine "Multiple options can be set with a single `:set`",TextLine "",Statement " :set -XMultiParamTypeClasses -XFlexibleInstances",Statement " class Z a b c",BlockClose,CodeLine,BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine},TextLine "",TextLine "",TextLine "Options apply only in the section where they are defined (unless they are in the setup section), so this will fail:",TextLine "",Statement " class L a b c",BlockClose,CodeLine,CodeLine,BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine},TextLine "",TextLine "Options apply to all tests in the same section after their declaration.",TextLine "",TextLine "Not set yet:",TextLine "",Statement " class D",TextLine "",TextLine "Now it works:",TextLine "",Statement ":set -XMultiParamTypeClasses",Statement " class C",TextLine "",TextLine "It still works",TextLine "",Statement " class F",BlockClose,CodeLine,BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine},TextLine "Wrong option names are reported.",Statement " :set -XWrong",BlockClose]
-}
tokensFrom :: String -> [Loc (Token String)]
tokensFrom :: String -> [Loc (Token String)]
tokensFrom = [String] -> [Loc (Token String)]
tokens ([String] -> [Loc (Token String)])
-> (String -> [String]) -> String -> [Loc (Token String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String]) -> ShowS -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r')

{- |
>>> tokens ["-- |$setup >>> 4+7","x=11"]
[Located {location = 0, located = BlockOpen {blockName = Just "setup", blockLanguage = Haddock, blockFormat = SingleLine}},Located {location = 0, located = Statement " 4+7"},Located {location = 1, located = CodeLine}]

>>> tokens ["-- $start"]
[Located {location = 0, located = BlockOpen {blockName = Just "start", blockLanguage = Plain, blockFormat = SingleLine}},Located {location = 0, located = TextLine ""}]

>>> tokens ["--","-- >>> 4+7"]
[Located {location = 0, located = BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = SingleLine}},Located {location = 0, located = TextLine ""},Located {location = 1, located = Statement " 4+7"}]

>>> tokens ["-- |$setup  44","-- >>> 4+7"]
[Located {location = 0, located = BlockOpen {blockName = Just "setup", blockLanguage = Haddock, blockFormat = SingleLine}},Located {location = 0, located = TextLine "44"},Located {location = 1, located = Statement " 4+7"}]

>>> tokens ["{"++"- |$doc",">>> 2+2","4","prop> x-x==0","--minus","-"++"}"]
[Located {location = 0, located = BlockOpen {blockName = Just "doc", blockLanguage = Haddock, blockFormat = MultiLine}},Located {location = 0, located = TextLine ""},Located {location = 1, located = Statement " 2+2"},Located {location = 2, located = TextLine "4"},Located {location = 3, located = PropLine " x-x==0"},Located {location = 4, located = TextLine "--minus"},Located {location = 5, located = BlockClose}]

Multi lines, closed on following line:

>>> tokens ["{"++"-","-"++"}"]
[Located {location = 0, located = BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine}},Located {location = 0, located = TextLine ""},Located {location = 1, located = BlockClose}]

>>> tokens [" {"++"-","-"++"} "]
[Located {location = 0, located = BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine}},Located {location = 0, located = TextLine ""},Located {location = 1, located = BlockClose}]

>>> tokens ["{"++"- SOME TEXT "," MORE -"++"}"]
[Located {location = 0, located = BlockOpen {blockName = Nothing, blockLanguage = Plain, blockFormat = MultiLine}},Located {location = 0, located = TextLine "SOME TEXT "},Located {location = 1, located = BlockClose}]

Multi lines, closed on the same line:

>>> tokens $ ["{","--"++"}"]
[Located {location = 0, located = CodeLine}]

>>> tokens $ ["  {","- IGNORED -","}  "]
[Located {location = 0, located = CodeLine}]

>>> tokens ["{","-# LANGUAGE TupleSections","#-","}"]
[Located {location = 0, located = CodeLine},Located {location = 1, located = CodeLine}]

>>> tokens []
[]
-}
tokens :: [String] -> [Loc TokenS]
tokens :: [String] -> [Loc (Token String)]
tokens = ((Int, [Token String]) -> [Loc (Token String)])
-> [(Int, [Token String])] -> [Loc (Token String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Int
l, [Token String]
vs) -> (Token String -> Loc (Token String))
-> [Token String] -> [Loc (Token String)]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Token String -> Loc (Token String)
forall l a. l -> a -> Located l a
Located Int
l) [Token String]
vs) ([(Int, [Token String])] -> [Loc (Token String)])
-> ([String] -> [(Int, [Token String])])
-> [String]
-> [Loc (Token String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [[Token String]] -> [(Int, [Token String])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] ([[Token String]] -> [(Int, [Token String])])
-> ([String] -> [[Token String]])
-> [String]
-> [(Int, [Token String])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Token String]] -> [[Token String]]
forall a. [a] -> [a]
reverse ([[Token String]] -> [[Token String]])
-> ([String] -> [[Token String]]) -> [String] -> [[Token String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State, [[Token String]]) -> [[Token String]]
forall a b. (a, b) -> b
snd ((State, [[Token String]]) -> [[Token String]])
-> ([String] -> (State, [[Token String]]))
-> [String]
-> [[Token String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((State, [[Token String]]) -> String -> (State, [[Token String]]))
-> (State, [[Token String]])
-> [String]
-> (State, [[Token String]])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (State, [[Token String]]) -> String -> (State, [[Token String]])
next (State
InCode, [])
  where
    next :: (State, [[Token String]]) -> String -> (State, [[Token String]])
next (State
st, [[Token String]]
tokens) String
ln = case Parser Char (State, [Token String])
-> String -> Either String (State, [Token String])
forall t a. Show t => Parser t a -> [t] -> Either String a
runParser (State -> Parser Char (State, [Token String])
aline State
st) String
ln of
        Right (State
st', [Token String]
tokens') -> (State
st', [Token String]
tokens' [Token String] -> [[Token String]] -> [[Token String]]
forall a. a -> [a] -> [a]
: [[Token String]]
tokens)
        Left String
err -> String -> (State, [[Token String]])
forall a. HasCallStack => String -> a
error (String -> (State, [[Token String]]))
-> String -> (State, [[Token String]])
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"Tokens.next failed to parse", String
ln, String
err]

-- | Parse a line of input
aline :: State -> TParser
aline :: State -> Parser Char (State, [Token String])
aline State
InCode = Parser Char (State, [Token String])
forall s. Parser Char (State, [Token s])
optionStart Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char (State, [Token String])
multi Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char (State, [Token String])
singleOpen Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char (State, [Token String])
codeLine
aline State
InSingleComment = Parser Char (State, [Token String])
forall s. Parser Char (State, [Token s])
optionStart Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char (State, [Token String])
multi Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Char (State, [Token String])
commentLine Bool
False Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char (State, [Token String])
codeLine
aline State
InMultiComment = Parser Char (State, [Token String])
multiClose Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Char (State, [Token String])
commentLine Bool
True

multi :: TParser
multi :: Parser Char (State, [Token String])
multi = Parser Char (State, [Token String])
multiOpenClose Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char (State, [Token String])
multiOpen

codeLine :: TParser
codeLine :: Parser Char (State, [Token String])
codeLine = (State
InCode, [Token String
forall s. Token s
CodeLine]) (State, [Token String])
-> Parser Char String -> Parser Char (State, [Token String])
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser Char String
forall t. Parser t [t]
tillEnd

{- | A multi line comment that starts and ends on the same line.

>>> runParser multiOpenClose $ concat ["{","--","}"]
Right (InCode,[CodeLine])

>>> runParser multiOpenClose $ concat [" {","-| >>> IGNORED -","} "]
Right (InCode,[CodeLine])
-}
multiOpenClose :: TParser
multiOpenClose :: Parser Char (State, [Token String])
multiOpenClose = (Parser Char ()
multiStart Parser Char ()
-> Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Char (State, [Token String])
multiClose) Parser Char (State, [Token String])
-> (State, [Token String]) -> Parser Char (State, [Token String])
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (State
InCode, [Token String
forall s. Token s
CodeLine])

{- | Parses the opening of a multi line comment.
>>> runParser multiOpen $ "{"++"- $longSection this is also parsed"
Right (InMultiComment,[BlockOpen {blockName = Just "longSection", blockLanguage = Plain, blockFormat = MultiLine},TextLine "this is also parsed"])

>>> runParser multiOpen $ "{"++"- $longSection >>> 2+3"
Right (InMultiComment,[BlockOpen {blockName = Just "longSection", blockLanguage = Plain, blockFormat = MultiLine},Statement " 2+3"])
-}
multiOpen :: TParser
multiOpen :: Parser Char (State, [Token String])
multiOpen =
    ( \() (Maybe Language
maybeLanguage, Maybe String
maybeName) Token String
tk ->
        (State
InMultiComment, [Maybe String -> Language -> Format -> Token String
forall s. Maybe s -> Language -> Format -> Token s
BlockOpen Maybe String
maybeName (Maybe Language -> Language
defLang Maybe Language
maybeLanguage) Format
MultiLine, Token String
tk])
    )
        (()
 -> (Maybe Language, Maybe String)
 -> Token String
 -> (State, [Token String]))
-> Parser Char ()
-> Parser
     Char
     ((Maybe Language, Maybe String)
      -> Token String -> (State, [Token String]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char ()
multiStart
        Parser
  Char
  ((Maybe Language, Maybe String)
   -> Token String -> (State, [Token String]))
-> Parser Char (Maybe Language, Maybe String)
-> Parser Char (Token String -> (State, [Token String]))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Char (Maybe Language, Maybe String)
languageAndName
        Parser Char (Token String -> (State, [Token String]))
-> Parser Char (Token String)
-> Parser Char (State, [Token String])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Char (Token String)
commentRest

{- | Parse the first line of a sequence of single line comments
>>> runParser singleOpen "-- |$doc >>>11"
Right (InSingleComment,[BlockOpen {blockName = Just "doc", blockLanguage = Haddock, blockFormat = SingleLine},Statement "11"])
-}
singleOpen :: TParser
singleOpen :: Parser Char (State, [Token String])
singleOpen =
    ( \() (Maybe Language
maybeLanguage, Maybe String
maybeName) Token String
tk ->
        (State
InSingleComment, [Maybe String -> Language -> Format -> Token String
forall s. Maybe s -> Language -> Format -> Token s
BlockOpen Maybe String
maybeName (Maybe Language -> Language
defLang Maybe Language
maybeLanguage) Format
SingleLine, Token String
tk])
    )
        (()
 -> (Maybe Language, Maybe String)
 -> Token String
 -> (State, [Token String]))
-> Parser Char ()
-> Parser
     Char
     ((Maybe Language, Maybe String)
      -> Token String -> (State, [Token String]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char ()
singleStart
        Parser
  Char
  ((Maybe Language, Maybe String)
   -> Token String -> (State, [Token String]))
-> Parser Char (Maybe Language, Maybe String)
-> Parser Char (Token String -> (State, [Token String]))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Char (Maybe Language, Maybe String)
languageAndName
        Parser Char (Token String -> (State, [Token String]))
-> Parser Char (Token String)
-> Parser Char (State, [Token String])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Char (Token String)
commentRest

{- | Parse a line in a comment
>>> runParser (commentLine False) "x=11"
Left "No match"

>>> runParser (commentLine False) "-- >>>11"
Right (InSingleComment,[Statement "11"])

>>> runParser (commentLine True) "-- >>>11"
Right (InMultiComment,[TextLine "-- >>>11"])
-}
commentLine :: Bool -> TParser
commentLine :: Bool -> Parser Char (State, [Token String])
commentLine Bool
noPrefix =
    (\Token String
tk -> (Bool -> State
commentState Bool
noPrefix, [Token String
tk])) (Token String -> (State, [Token String]))
-> Parser Char (Token String)
-> Parser Char (State, [Token String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Parser Char ()
optLineStart Bool
noPrefix Parser Char ()
-> Parser Char (Token String) -> Parser Char (Token String)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char (Token String)
commentBody)

commentRest :: Parser Char (Token [Char])
commentRest :: Parser Char (Token String)
commentRest = Parser Char Char -> Parser Char String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Char Char
space Parser Char String
-> Parser Char (Token String) -> Parser Char (Token String)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char (Token String)
commentBody

commentBody :: Parser Char (Token [Char])
commentBody :: Parser Char (Token String)
commentBody = Parser Char (Token String)
stmt Parser Char (Token String)
-> Parser Char (Token String) -> Parser Char (Token String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char (Token String)
prop Parser Char (Token String)
-> Parser Char (Token String) -> Parser Char (Token String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char (Token String)
forall t. Parser t (Token [t])
txt
  where
    txt :: Parser t (Token [t])
txt = [t] -> Token [t]
forall s. s -> Token s
TextLine ([t] -> Token [t]) -> Parser t [t] -> Parser t (Token [t])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser t [t]
forall t. Parser t [t]
tillEnd
    stmt :: Parser Char (Token String)
stmt = String -> Token String
forall s. s -> Token s
Statement (String -> Token String)
-> Parser Char String -> Parser Char (Token String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Parser Char String
string String
">>>" Parser Char String -> Parser Char String -> Parser Char String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char String
forall t. Parser t [t]
tillEnd)
    prop :: Parser Char (Token String)
prop = String -> Token String
forall s. s -> Token s
PropLine (String -> Token String)
-> Parser Char String -> Parser Char (Token String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Parser Char String
string String
"prop>" Parser Char String -> Parser Char String -> Parser Char String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char String
forall t. Parser t [t]
tillEnd)

-- | Remove comment line prefix, if needed
optLineStart :: Bool -> Parser Char ()
optLineStart :: Bool -> Parser Char ()
optLineStart Bool
noPrefix
    | Bool
noPrefix = () -> Parser Char ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    | Bool
otherwise = Parser Char ()
singleStart

singleStart :: Parser Char ()
singleStart :: Parser Char ()
singleStart = (String -> Parser Char String
string String
"--" Parser Char String
-> Parser Char (Maybe Char) -> Parser Char (Maybe Char)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char Char -> Parser Char (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Char Char
space) Parser Char (Maybe Char) -> () -> Parser Char ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()

multiStart :: Parser Char ()
multiStart :: Parser Char ()
multiStart = String -> Parser Char String
sstring String
"{-" Parser Char String -> () -> Parser Char ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()

{- Parse the close of a multi-line comment
>>> runParser multiClose $ "-"++"}"
Right (InCode,[BlockClose])

>>> runParser multiClose $ "-"++"}  "
Right (InCode,[BlockClose])

As there is currently no way of handling tests in the final line of a multi line comment, it ignores anything that precedes the closing marker:

>>> runParser multiClose $ "IGNORED -"++"}  "
Right (InCode,[BlockClose])
-}
multiClose :: TParser
multiClose :: Parser Char (State, [Token String])
multiClose = Parser Char Char -> Parser Char String -> Parser Char String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m end
skipManyTill ((Char -> Bool) -> Parser Char Char
forall t. (t -> Bool) -> Parser t t
satisfy (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)) (String -> Parser Char String
string String
"-}" Parser Char String -> Parser Char String -> Parser Char String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char Char -> Parser Char String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Char Char
space) Parser Char String
-> Parser Char (State, [Token String])
-> Parser Char (State, [Token String])
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (State, [Token String]) -> Parser Char (State, [Token String])
forall (m :: * -> *) a. Monad m => a -> m a
return (State
InCode, [Token String
forall s. Token s
BlockClose])

optionStart :: Parser Char (State, [Token s])
optionStart :: Parser Char (State, [Token s])
optionStart = (String -> Parser Char String
string String
"{-#" Parser Char String -> Parser Char String -> Parser Char String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char String
forall t. Parser t [t]
tillEnd) Parser Char String
-> (State, [Token s]) -> Parser Char (State, [Token s])
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (State
InCode, [Token s
forall s. Token s
CodeLine])

name :: Parser Char [Char]
name :: Parser Char String
name = (:) (Char -> ShowS) -> Parser Char Char -> Parser Char ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char Char
letterChar Parser Char ShowS -> Parser Char String -> Parser Char String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Char Char -> Parser Char String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Parser Char Char
alphaNumChar Parser Char Char -> Parser Char Char -> Parser Char Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char Char
char Char
'_')

sstring :: String -> Parser Char [Char]
sstring :: String -> Parser Char String
sstring String
s = Parser Char Char -> Parser Char String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Char Char
space Parser Char String -> Parser Char String -> Parser Char String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> Parser Char String
string String
s Parser Char String -> Parser Char String -> Parser Char String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char Char -> Parser Char String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Char Char
space

{- |
>>>runParser languageAndName "|$"
Right (Just Haddock,Just "")

>>>runParser languageAndName "|$start"
Right (Just Haddock,Just "start")

>>>runParser languageAndName "| $start"
Right (Just Haddock,Just "start")

>>>runParser languageAndName "^"
Right (Just Haddock,Nothing)

>>>runParser languageAndName "$start"
Right (Nothing,Just "start")
-}
languageAndName :: Parser Char (Maybe Language, Maybe String)
languageAndName :: Parser Char (Maybe Language, Maybe String)
languageAndName =
    (,) (Maybe Language -> Maybe String -> (Maybe Language, Maybe String))
-> Parser Char (Maybe Language)
-> Parser Char (Maybe String -> (Maybe Language, Maybe String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char Language -> Parser Char (Maybe Language)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ((Char -> Parser Char Char
char Char
'|' Parser Char Char -> Parser Char Char -> Parser Char Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char Char
char Char
'^') Parser Char Char -> Parser Char Language -> Parser Char Language
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Language -> Parser Char Language
forall (f :: * -> *) a. Applicative f => a -> f a
pure Language
Haddock)
        Parser Char (Maybe String -> (Maybe Language, Maybe String))
-> Parser Char (Maybe String)
-> Parser Char (Maybe Language, Maybe String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Char String -> Parser Char (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional
            (Char -> Parser Char Char
char Char
'$' Parser Char Char -> Parser Char String -> Parser Char String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String)
-> Parser Char (Maybe String) -> Parser Char String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char String -> Parser Char (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Char String
name))

defLang :: Maybe Language -> Language
defLang :: Maybe Language -> Language
defLang = Language -> Maybe Language -> Language
forall a. a -> Maybe a -> a
fromMaybe Language
Plain