------------------------------------------------------------------------------
-- |
-- Module      : LiterateX.Parser
-- Description : source parser
-- Copyright   : Copyright (c) 2021-2023 Travis Cardwell
-- License     : MIT
--
-- This module implements the source parser.
------------------------------------------------------------------------------

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

module LiterateX.Parser
  ( -- * API
    parse
  ) where

-- https://hackage.haskell.org/package/base
import Control.Monad (guard)
import Data.Maybe (fromMaybe)

-- https://hackage.haskell.org/package/conduit
import qualified Data.Conduit as C
import Data.Conduit (ConduitT)

-- https://hackage.haskell.org/package/text
import qualified Data.Text as T
import Data.Text (Text)

-- (literatex)
import LiterateX.Types (SourceFormat, SourceLine)
import qualified LiterateX.Types.SourceFormat as SourceFormat
import qualified LiterateX.Types.SourceLine as SourceLine

------------------------------------------------------------------------------
-- $API

-- | Create a "Conduit" transformer that parses the specified source format
--
-- The transformer consumes lines of the input and produces a 'SourceLine' for
-- each line of input.
--
-- @since 0.0.1.0
parse
  :: Monad m
  => SourceFormat
  -> ConduitT Text SourceLine m ()
parse :: forall (m :: * -> *).
Monad m =>
SourceFormat -> ConduitT Text SourceLine m ()
parse = forall (m :: * -> *).
Monad m =>
ParserFunctions -> ConduitT Text SourceLine m ()
parseSourceLines forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceFormat -> ParserFunctions
parserFunctionsFor

------------------------------------------------------------------------------
-- $Internal

-- | Parser functions that determine how input is parsed
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)
    }

------------------------------------------------------------------------------

-- | Get the parser functions for the specified source format
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

------------------------------------------------------------------------------

-- | Get parser functions for source with line-based comments
lineCommentParserFunctions
  :: Char  -- ^ comment character
  -> Int   -- ^ number of comment characters to create line comment
  -> ParserFunctions
lineCommentParserFunctions :: Char -> Int -> ParserFunctions
lineCommentParserFunctions Char
char Int
count = 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 = [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
count Char
char

    prefixLen :: Int
    prefixLen :: Int
prefixLen = Int
count forall a. Num a => a -> a -> a
+ Int
1

    prefix :: Text
    prefix :: Text
prefix = [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
count Char
char forall a. [a] -> [a] -> [a]
++ [Char]
" "

    isCodeBlank :: Text -> Bool
    isCodeBlank :: Text -> Bool
isCodeBlank = Text -> Bool
T.null

    isDocBlank :: Text -> Bool
    isDocBlank :: Text -> Bool
isDocBlank = (forall a. Eq a => a -> a -> Bool
== Text
docBlank)

    isRule :: Text -> Bool
    isRule :: Text -> Bool
isRule Text
line = Text -> Int
T.length Text
line forall a. Ord a => a -> a -> Bool
> Int
count Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all (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
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Text
linePrefix forall a. Eq a => a -> a -> Bool
== Text
prefix
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
lineSuffix

    getCode :: Text -> Text
    getCode :: Text -> Text
getCode = forall a. a -> a
id

------------------------------------------------------------------------------

-- | Get parser functions for source with Lisp-style comments
--
-- Lisp-style comments begin with one or more semicolons.
lispCommentParserFunctions :: ParserFunctions
lispCommentParserFunctions :: ParserFunctions
lispCommentParserFunctions = 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 forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
len forall a. Ord a => a -> a -> Bool
<= Int
4 Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all (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 forall a. Ord a => a -> a -> Bool
> Int
4 Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> (Text, Text)
T.breakOn Text
" " Text
line
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard 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 (forall a. Eq a => a -> a -> Bool
== Char
';') Text
linePrefix
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Text
sep forall a. Eq a => a -> a -> Bool
== Text
" "
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
lineSuffix

    getCode :: Text -> Text
    getCode :: Text -> Text
getCode = forall a. a -> a
id

------------------------------------------------------------------------------

-- | Get parser functions for parsing literate Haskell
literateHaskellParserFunctions :: ParserFunctions
literateHaskellParserFunctions :: ParserFunctions
literateHaskellParserFunctions = 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 = (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 = 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 = forall a. Maybe a
Nothing
      | Bool
otherwise                = forall a. a -> Maybe a
Just Text
line

    getCode :: Text -> Text
    getCode :: Text -> Text
getCode Text
line = forall a. a -> Maybe a -> a
fromMaybe Text
line forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
"> " Text
line

------------------------------------------------------------------------------

-- | Create a "Conduit" transformer for the specified parser functions
--
-- This function produces a 'SourceLine' for each line of input.  A
-- 'SourceLine.Shebang' can only be produced on the first line.  Note that the
-- order that the parser functions are used is significant; the parser
-- functions are written for this order.
parseSourceLines
  :: Monad m
  => ParserFunctions
  -> ConduitT Text SourceLine m ()
parseSourceLines :: forall (m :: * -> *).
Monad m =>
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 <- forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
C.await
    case Maybe Text
mLine of
      Just Text
line -> do
        forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield 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
        forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
C.awaitForever forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SourceLine
parse'
      Maybe Text
Nothing -> 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