lima-0.1.0.2: src/Converter.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# HLINT ignore "Redundant bracket" #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

-- | Functions to convert @Haskell@ to @Markdown@ and between @Literate Haskell@ (@.lhs@) and @Markdown@.
module Converter (hsToMd, mdToHs, lhsToMd, mdToLhs, Config (..), ConfigHsMd (..)) where

import Data.Default (Default)
import Data.Foldable (Foldable (..))
import Data.Function ((&))
import Data.List (isPrefixOf, isSuffixOf)
import Data.Yaml (FromJSON (..))
import Data.Yaml.Aeson (withObject, (.:), (.:?))
import GHC.Generics (Generic)

-- | App config.
newtype Config = Config {configHsMd :: Maybe ConfigHsMd} deriving (Generic, Default)

instance FromJSON Config where
  parseJSON = withObject "Configs" (\v -> Config <$> v .:? "hs-md")

-- | Config for @Haskell@ to @Markdown@ converter.
newtype ConfigHsMd = ConfigHs2Md {specialComments :: [String]} deriving (Generic, Default)

instance FromJSON ConfigHsMd where
  parseJSON =
    withObject
      "CommentsToIgnore"
      (\v -> ConfigHs2Md <$> v .: "special-comments")

backticks_ :: Int -> String
backticks_ n = indentN n backticks

backticks :: String
backticks = "```"

haskellSnippet :: String
haskellSnippet = backticks ++ "haskell"

consoleSnippet :: String
consoleSnippet = backticks ++ "console"

chooseSnippetType :: String -> String
chooseSnippetType s
  | s `startsWith` birdTrack = haskellSnippet
  | otherwise = consoleSnippet

birdTrack :: String
birdTrack = "> "

reverseBirdTrack :: String
reverseBirdTrack = "< "

birdTracks :: [String]
birdTracks = [birdTrack, reverseBirdTrack]

-- | Convert @Literate Haskell@ to @Markdown@.
--
-- Convert @LHS@ birdtick style to @Markdown@, replacing the code marked by birdticks with @```haskell ... ```@.
lhsToMd :: String -> String
lhsToMd = unlines . convert "" . lines
 where
  convert :: String -> [String] -> [String]
  convert prev []
    | -- close code tags at the end
      prev `startsWithAnyOf` birdTracks =
        [backticks]
    | otherwise = []
  convert prev (h : t)
    | -- check for Haskell code to start
      -- insert newline above code block if needed
      not (prev `startsWithAnyOf` birdTracks)
        && (h `startsWithAnyOf` birdTracks) =
        (["" | prev /= ""]) ++ [chooseSnippetType h, drop 2 h] ++ rest
    | -- check for code
      h `startsWithAnyOf` birdTracks =
        drop 2 h : rest
    | -- check for code end, insert newline after code block if needed
      prev `startsWithAnyOf` birdTracks =
        [backticks] ++ (["" | h /= ""]) ++ [h] ++ rest
    | h `startsWith` (' ' : birdTrack) =
        drop 1 h : rest
    | otherwise = shiftIfHeader h ++ rest
   where
    rest = convert h t

-- | Convert @Markdown@ file to @Literate Haskell@.
--
-- Replace code marked with @```haskell ...```@ with birdticks (@>@)
-- and code marked with @``` ... ```@ with reverse birdticks (@<@).
mdToLhs :: String -> String
mdToLhs = unlines . convert False False "" . lines
 where
  convert :: Bool -> Bool -> String -> [String] -> [String]
  convert inHsCode inSample prev [] = []
  convert inHsCode inSample prev (h : t)
    | -- handle code block starts, add newline if needed
      h == haskellSnippet =
        (["" | prev /= ""]) ++ convert True False prev t
    | -- handle code
      inHsCode && h /= backticks =
        ("> " ++ h) : convert True False h t
    | -- handle code sample
      inSample && h /= backticks =
        ("< " ++ h) : convert False True h t
    | -- move headings one space to right
      isHeading h =
        (' ' : h) : rest
    | -- handle code and sample block ends
      (inHsCode || inSample)
        && h == backticks =
        (["" | null t || head t /= ""])
          ++ convert False False prev t
    | -- handle sample block starts, add newline if needed
      take 3 h == backticks =
        (["" | prev /= ""]) ++ convert False True prev t
    | -- handle quotes
      h `startsWith` birdTrack =
        (" >" ++ drop 1 h) : rest
    | otherwise = h : rest
   where
    -- count headings
    isHeading h = not (null (takeWhile (== '#') h))
    rest = convert False False h t

startsWith :: String -> String -> Bool
startsWith = flip isPrefixOf

startsWithAnyOf :: String -> [String] -> Bool
startsWithAnyOf l = any (startsWith l)

shiftIfHeader :: String -> [String]
shiftIfHeader "" = [""]
shiftIfHeader (' ' : '#' : x) = ['#' : x]
shiftIfHeader x = [x]

_LIMA_DISABLE :: String
_LIMA_DISABLE = "LIMA_DISABLE"

_LIMA_ENABLE :: String
_LIMA_ENABLE = "LIMA_ENABLE"

_LIMA_INDENT :: String
_LIMA_INDENT = "LIMA_INDENT"

_LIMA_DEDENT :: String
_LIMA_DEDENT = "LIMA_DEDENT"

-- | Comments that should be ignored for some reason
--
-- FOURMOLU_DISABLE is ignored because it's a special comment and shouldn't be visible in a `.md`
specialCommentsDefault :: [String]
specialCommentsDefault = ["FOURMOLU_DISABLE", "FOURMOLU_ENABLE", _LIMA_INDENT, _LIMA_DEDENT]

endsWith :: String -> String -> Bool
endsWith = flip isSuffixOf

-- multi-line comments
mcOpen :: String
mcOpen = "{-"

mcOpenSpace :: String
mcOpenSpace = mcOpen ++ " "

-- | multiline comment closing symbols
mcClose :: String
mcClose = "-}"

mcCloseSpace :: String
mcCloseSpace = " -}"

dropEnd :: Int -> String -> String
dropEnd n s = reverse (drop n (reverse s))

backticksHs :: String
backticksHs = backticks ++ "haskell"

backticksHs_ :: Int -> String
backticksHs_ n = indentN n backticksHs

dropEmpties :: [String] -> [String]
dropEmpties = dropWhile (\x -> dropSpaces x == "")

-- Markdown comments

-- | Open a @Markdown@ comment
mdcOpen :: String
mdcOpen = "<!--"

-- | Close a @Markdown@ comment
mdcClose :: String
mdcClose = "-->"

mdcOpenSpace :: String
mdcOpenSpace = mdcOpen ++ " "

mdcCloseSpace :: String
mdcCloseSpace = " " ++ mdcClose

-- | Remove multiline comment marks from the beginning and end of a string
stripMC :: String -> String
stripMC x = dropEnd (length mcCloseSpace) (drop (length mcOpenSpace) x)

indentN :: Int -> String -> String
indentN x s = concat (replicate x " ") ++ s

-- | Convert @Haskell@ to @Markdown@.
--
-- Multi-line comments are copied as text blocks and @Haskell@ code is copied as @Haskell@ snippets.
hsToMd :: ConfigHsMd -> String -> String
hsToMd ConfigHs2Md{..} = unlines . dropWhile (== "") . reverse . (\x -> convert True False False 0 x []) . lines
 where
  specialComments_ = specialCommentsDefault ++ specialComments
  convert :: Bool -> Bool -> Bool -> Int -> [String] -> [String] -> [String]
  convert inLimaEnable inComments inSnippet indent_ (h : hs) res
    | not inComments =
        if
            | -- disable
              -- split a snippet
              h == mcOpenSpace ++ _LIMA_DISABLE ++ mcCloseSpace ->
                (convert False False False indent_ hs)
                  ([mdcOpenSpace ++ _LIMA_DISABLE] ++ [backticks_ indent_ | inSnippet] ++ dropEmpties res)
            | -- enable
              h == mcOpenSpace ++ _LIMA_ENABLE ++ mcCloseSpace ->
                convert True False inSnippet indent_ hs ((_LIMA_ENABLE ++ mdcCloseSpace) : res)
            | -- disabled
              not inLimaEnable ->
                convert inLimaEnable False False indent_ hs (h : res)
            | -- indentation comment
              -- splits a snippet
              h `startsWithAnyOf` ((mcOpenSpace ++) <$> [_LIMA_INDENT, _LIMA_DEDENT]) ->
                let h_ = stripMC h
                    isIndent = h_ `startsWith` _LIMA_INDENT
                    newIndent_ = if isIndent then indent_ + (read @Int $ drop (length _LIMA_INDENT) h_) else 0
                 in (convert inLimaEnable False False newIndent_ hs)
                      ( [mdcOpenSpace ++ stripMC h ++ mdcCloseSpace]
                          ++ ["" | inSnippet]
                          ++ [backticks_ indent_ | inSnippet]
                          ++ (if isIndent then squashEmpties else dropEmpties) res
                      )
            | -- a special comment
              -- a comment should be in multi-line style like '{- FOURMOLU_DISABLE -}'
              -- it should occupy a single line
              -- it may be followed by arbitrary text in that line
              -- splits a snippet
              h `startsWithAnyOf` ((mcOpenSpace ++) <$> specialComments_) ->
                (convert inLimaEnable False False indent_ hs)
                  ([mdcOpenSpace ++ stripMC h ++ mdcCloseSpace] ++ ["" | inSnippet] ++ [backticks_ indent_ | inSnippet] ++ dropEmpties res)
            | -- start of a multi-line comment
              -- it should be either like '{- ...' or '{-\n'
              (h `startsWith` mcOpenSpace || h == mcOpen) ->
                let x' = drop 3 h
                    pref = "" : [backticks_ indent_ | inSnippet]
                    res' = if inSnippet then dropEmpties res else res
                 in -- if a multiline comment ends on the same line
                    -- it should end with '-}'
                    if h `endsWith` mcClose
                      then convert inLimaEnable False False indent_ hs ([dropEnd (length mcCloseSpace) x'] ++ pref ++ res')
                      else convert inLimaEnable True False indent_ hs ([x' | not (null x')] ++ pref ++ res')
            | -- non-empty line means the start of a Haskell snippet
              not inSnippet ->
                if not (null h)
                  then -- non-empty line means the start of a Haskell snippet
                    convert inLimaEnable False True indent_ hs ([indentN indent_ h, backticksHs_ indent_] ++ squashEmpties res)
                  else -- if not in snippet, collapse consequent empty lines
                    convert inLimaEnable False False indent_ hs res
            | inSnippet ->
                convert inLimaEnable False True indent_ hs ((indentN indent_ h) : res)
    | inComments =
        if h `startsWith` mcClose
          then -- end of a multiline comment
            convert inLimaEnable False False indent_ hs (res)
          else -- copy everything from comments
            convert inLimaEnable True False indent_ hs (h : res)
  convert _ _ inSnippet indent_ [] res =
    [backticks_ indent_ | inSnippet] ++ dropEmpties res

stripMdc :: String -> String
stripMdc x = dropEnd (length mdcCloseSpace) (drop (length mdcOpenSpace) x)

squashEmpties :: [String] -> [String]
squashEmpties = ([""] ++) . dropEmpties

dropSpaces :: String -> String
dropSpaces = dropWhile (== ' ')

countSpaces :: String -> Int
countSpaces x = length $ takeWhile (== ' ') x

-- | Convert @Markdown@ to @Haskell@.
--
-- Multi-line comments are copied as text blocks and @Haskell@ code is copied as @Haskell@ snippets.
mdToHs :: ConfigHsMd -> String -> String
mdToHs ConfigHs2Md{..} = unlines . dropWhile (== "") . reverse . (\x -> convert False False False 0 x []) . lines
 where
  specialComments_ = specialCommentsDefault ++ specialComments
  closeTextIf x = [mcClose | x]
  convert :: Bool -> Bool -> Bool -> Int -> [String] -> [String] -> [String]
  convert inText inSnippet inComments dedent_ (h : hs) res
    | inComments =
        -- enable
        if h `startsWith` (_LIMA_ENABLE ++ mdcCloseSpace)
          then -- split text

            (convert inText inSnippet False dedent_ hs)
              ([mcOpenSpace ++ _LIMA_ENABLE ++ mcCloseSpace] ++ ["" | inText] ++ closeTextIf inText ++ res)
          else -- copy lines
            convert False False True dedent_ hs (h : res)
    | not inSnippet =
        if
            | -- found comments
              h `startsWith` (mdcOpenSpace ++ _LIMA_DISABLE) ->
                (convert False False True dedent_ hs)
                  ([mcOpenSpace ++ _LIMA_DISABLE ++ mcCloseSpace, ""] ++ closeTextIf inText ++ res)
            | -- found a special comment
              h `startsWithAnyOf` ((mdcOpenSpace ++) <$> specialComments_) ->
                (convert False False False dedent_ hs)
                  ([mcOpenSpace ++ stripMdc h ++ mcCloseSpace] ++ [""] ++ closeTextIf inText ++ dropEmpties res)
            | -- start of a haskell snippet
              (dropSpaces h) `startsWith` backticksHs ->
                convert False True False (countSpaces h) hs ([""] ++ closeTextIf inText ++ dropEmpties res)
            | not inText ->
                if null h
                  then -- just a blank line
                    convert inText False False dedent_ hs res
                  else -- start of text
                    convert True False False dedent_ hs ([h, mcOpen, ""] ++ res)
            | -- copy text line by line
              otherwise ->
                convert True False False dedent_ hs (h : res)
    | otherwise =
        if (dropSpaces h) == backticks
          then -- end of a snippet
            convert False False False 0 hs res
          else -- in a snippet
            convert False True False dedent_ hs ((drop dedent_ h) : res)
  convert inText _ _ dedent_ [] res = [mcClose | inText] ++ res