{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module LiterateX.Parser
(
parse
) where
import Control.Monad (guard)
import Data.Maybe (fromMaybe)
import qualified Data.Conduit as C
import Data.Conduit (ConduitT)
import qualified Data.Text as T
import Data.Text (Text)
import LiterateX.Types (SourceFormat, SourceLine)
import qualified LiterateX.Types.SourceFormat as SourceFormat
import qualified LiterateX.Types.SourceLine as SourceLine
parse
:: Monad m
=> SourceFormat
-> ConduitT Text SourceLine m ()
parse :: SourceFormat -> ConduitT Text SourceLine m ()
parse = ParserFunctions -> ConduitT Text SourceLine m ()
forall (m :: * -> *).
Monad m =>
ParserFunctions -> ConduitT Text SourceLine m ()
parseSourceLines (ParserFunctions -> ConduitT Text SourceLine m ())
-> (SourceFormat -> ParserFunctions)
-> SourceFormat
-> ConduitT Text SourceLine m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceFormat -> ParserFunctions
parserFunctionsFor
data ParserFunctions
= ParserFunctions
{ ParserFunctions -> Text -> Bool
isCodeBlank :: !(Text -> Bool)
, ParserFunctions -> Text -> Bool
isDocBlank :: !(Text -> Bool)
, ParserFunctions -> Text -> Bool
isRule :: !(Text -> Bool)
, ParserFunctions -> Text -> Maybe Text
getDoc :: !(Text -> Maybe Text)
, ParserFunctions -> Text -> Text
getCode :: !(Text -> Text)
}
parserFunctionsFor :: SourceFormat -> ParserFunctions
parserFunctionsFor :: SourceFormat -> ParserFunctions
parserFunctionsFor = \case
SourceFormat
SourceFormat.DoubleDash -> Char -> Int -> ParserFunctions
lineCommentParserFunctions Char
'-' Int
2
SourceFormat
SourceFormat.DoubleSlash -> Char -> Int -> ParserFunctions
lineCommentParserFunctions Char
'/' Int
2
SourceFormat
SourceFormat.Hash -> Char -> Int -> ParserFunctions
lineCommentParserFunctions Char
'#' Int
1
SourceFormat
SourceFormat.LiterateHaskell -> ParserFunctions
literateHaskellParserFunctions
SourceFormat
SourceFormat.Percent -> Char -> Int -> ParserFunctions
lineCommentParserFunctions Char
'%' Int
1
SourceFormat
SourceFormat.LispSemicolons -> ParserFunctions
lispCommentParserFunctions
lineCommentParserFunctions
:: Char
-> Int
-> ParserFunctions
Char
char Int
count = ParserFunctions :: (Text -> Bool)
-> (Text -> Bool)
-> (Text -> Bool)
-> (Text -> Maybe Text)
-> (Text -> Text)
-> ParserFunctions
ParserFunctions{Text -> Bool
Text -> Maybe Text
Text -> Text
getCode :: Text -> Text
getDoc :: Text -> Maybe Text
isRule :: Text -> Bool
isDocBlank :: Text -> Bool
isCodeBlank :: Text -> Bool
getCode :: Text -> Text
getDoc :: Text -> Maybe Text
isRule :: Text -> Bool
isDocBlank :: Text -> Bool
isCodeBlank :: Text -> Bool
..}
where
docBlank :: Text
docBlank :: Text
docBlank = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
count Char
char
prefixLen :: Int
prefixLen :: Int
prefixLen = Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
prefix :: Text
prefix :: Text
prefix = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
count Char
char String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
isCodeBlank :: Text -> Bool
isCodeBlank :: Text -> Bool
isCodeBlank = Text -> Bool
T.null
isDocBlank :: Text -> Bool
isDocBlank :: Text -> Bool
isDocBlank = (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
docBlank)
isRule :: Text -> Bool
isRule :: Text -> Bool
isRule Text
line = Text -> Int
T.length Text
line Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
count Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
char) Text
line
getDoc :: Text -> Maybe Text
getDoc :: Text -> Maybe Text
getDoc Text
line = do
let (Text
linePrefix, Text
lineSuffix) = Int -> Text -> (Text, Text)
T.splitAt Int
prefixLen Text
line
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Text
linePrefix Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
prefix
Text -> Maybe Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
lineSuffix
getCode :: Text -> Text
getCode :: Text -> Text
getCode = Text -> Text
forall a. a -> a
id
lispCommentParserFunctions :: ParserFunctions
= ParserFunctions :: (Text -> Bool)
-> (Text -> Bool)
-> (Text -> Bool)
-> (Text -> Maybe Text)
-> (Text -> Text)
-> ParserFunctions
ParserFunctions{Text -> Bool
Text -> Maybe Text
Text -> Text
getCode :: Text -> Text
getDoc :: Text -> Maybe Text
isRule :: Text -> Bool
isDocBlank :: Text -> Bool
isCodeBlank :: Text -> Bool
getCode :: Text -> Text
getDoc :: Text -> Maybe Text
isRule :: Text -> Bool
isDocBlank :: Text -> Bool
isCodeBlank :: Text -> Bool
..}
where
isCodeBlank :: Text -> Bool
isCodeBlank :: Text -> Bool
isCodeBlank = Text -> Bool
T.null
isDocBlank :: Text -> Bool
isDocBlank :: Text -> Bool
isDocBlank Text
line =
let len :: Int
len = Text -> Int
T.length Text
line
in Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
4 Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
';') Text
line
isRule :: Text -> Bool
isRule :: Text -> Bool
isRule Text
line = Text -> Int
T.length Text
line Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
4 Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
';') Text
line
getDoc :: Text -> Maybe Text
getDoc :: Text -> Maybe Text
getDoc Text
line = do
let (Text
linePrefix, (Text
sep, Text
lineSuffix)) = Int -> Text -> (Text, Text)
T.splitAt Int
1 (Text -> (Text, Text)) -> (Text, Text) -> (Text, (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> (Text, Text)
T.breakOn Text
" " Text
line
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Text -> Bool
T.null Text
linePrefix) Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
';') Text
linePrefix
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Text
sep Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
" "
Text -> Maybe Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
lineSuffix
getCode :: Text -> Text
getCode :: Text -> Text
getCode = Text -> Text
forall a. a -> a
id
literateHaskellParserFunctions :: ParserFunctions
literateHaskellParserFunctions :: ParserFunctions
literateHaskellParserFunctions = ParserFunctions :: (Text -> Bool)
-> (Text -> Bool)
-> (Text -> Bool)
-> (Text -> Maybe Text)
-> (Text -> Text)
-> ParserFunctions
ParserFunctions{Text -> Bool
Text -> Maybe Text
Text -> Text
getCode :: Text -> Text
getDoc :: Text -> Maybe Text
isRule :: Text -> Bool
isDocBlank :: Text -> Bool
isCodeBlank :: Text -> Bool
getCode :: Text -> Text
getDoc :: Text -> Maybe Text
isRule :: Text -> Bool
isDocBlank :: Text -> Bool
isCodeBlank :: Text -> Bool
..}
where
isCodeBlank :: Text -> Bool
isCodeBlank :: Text -> Bool
isCodeBlank = (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
">")
isDocBlank :: Text -> Bool
isDocBlank :: Text -> Bool
isDocBlank = Text -> Bool
T.null
isRule :: Text -> Bool
isRule :: Text -> Bool
isRule = Bool -> Text -> Bool
forall a b. a -> b -> a
const Bool
False
getDoc :: Text -> Maybe Text
getDoc :: Text -> Maybe Text
getDoc Text
line
| Text
"> " Text -> Text -> Bool
`T.isPrefixOf` Text
line = Maybe Text
forall a. Maybe a
Nothing
| Bool
otherwise = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
line
getCode :: Text -> Text
getCode :: Text -> Text
getCode Text
line = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
line (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
"> " Text
line
parseSourceLines
:: Monad m
=> ParserFunctions
-> ConduitT Text SourceLine m ()
parseSourceLines :: ParserFunctions -> ConduitT Text SourceLine m ()
parseSourceLines ParserFunctions{Text -> Bool
Text -> Maybe Text
Text -> Text
getCode :: Text -> Text
getDoc :: Text -> Maybe Text
isRule :: Text -> Bool
isDocBlank :: Text -> Bool
isCodeBlank :: Text -> Bool
getCode :: ParserFunctions -> Text -> Text
getDoc :: ParserFunctions -> Text -> Maybe Text
isRule :: ParserFunctions -> Text -> Bool
isDocBlank :: ParserFunctions -> Text -> Bool
isCodeBlank :: ParserFunctions -> Text -> Bool
..} = do
Maybe Text
mLine <- ConduitT Text SourceLine m (Maybe Text)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
C.await
case Maybe Text
mLine of
Just Text
line -> do
SourceLine -> ConduitT Text SourceLine m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield (SourceLine -> ConduitT Text SourceLine m ())
-> SourceLine -> ConduitT Text SourceLine m ()
forall a b. (a -> b) -> a -> b
$ if Text
"#!" Text -> Text -> Bool
`T.isPrefixOf` Text
line
then Text -> SourceLine
SourceLine.Shebang Text
line
else Text -> SourceLine
parse' Text
line
(Text -> ConduitT Text SourceLine m ())
-> ConduitT Text SourceLine m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
C.awaitForever ((Text -> ConduitT Text SourceLine m ())
-> ConduitT Text SourceLine m ())
-> (Text -> ConduitT Text SourceLine m ())
-> ConduitT Text SourceLine m ()
forall a b. (a -> b) -> a -> b
$ SourceLine -> ConduitT Text SourceLine m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield (SourceLine -> ConduitT Text SourceLine m ())
-> (Text -> SourceLine) -> Text -> ConduitT Text SourceLine m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SourceLine
parse'
Maybe Text
Nothing -> () -> ConduitT Text SourceLine m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
parse' :: Text -> SourceLine
parse' :: Text -> SourceLine
parse' Text
line
| Text -> Bool
isCodeBlank Text
line = SourceLine
SourceLine.CodeBlank
| Text -> Bool
isDocBlank Text
line = SourceLine
SourceLine.DocBlank
| Text -> Bool
isRule Text
line = SourceLine
SourceLine.Rule
| Bool
otherwise = case (Text -> Maybe Text
getDoc Text
line, Text -> Text
getCode Text
line) of
(Just Text
doc, Text
_code) -> Text -> SourceLine
SourceLine.Doc Text
doc
(Maybe Text
Nothing, Text
code) -> Text -> SourceLine
SourceLine.Code Text
code