module Text.Pandoc.Filter.IncludeCode
( includeCode
) where
#if MIN_VERSION_base(4,8,0)
#else
import Control.Applicative
import Data.Monoid
#endif
import Control.Exception
import Control.Monad.Except
import Control.Monad.Reader
import Data.Char (isSpace)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.List (isInfixOf)
import Data.Maybe (fromMaybe)
import Text.Pandoc.JSON
import Text.Read (readMaybe)
data Range = Range
{ startLine :: Int
, endLine :: Int
}
mkRange :: Int -> Int -> Maybe Range
mkRange s e
| s > 0 && e > 0 && s <= e = Just (Range s e)
| otherwise = Nothing
data InclusionSpec = InclusionSpec
{ include :: FilePath
, snippet :: Maybe String
, range :: Maybe Range
, dedent :: Maybe Int
}
data MissingRangePart
= Start
| End
deriving (Show, Eq)
data InclusionError
= InvalidRange Int
Int
| IncompleteRange MissingRangePart
deriving (Show, Eq)
newtype Inclusion a = Inclusion
{ runInclusion :: ReaderT InclusionSpec (ExceptT InclusionError IO) a
} deriving ( Functor
, Applicative
, Monad
, MonadIO
, MonadReader InclusionSpec
, MonadError InclusionError
)
runInclusion' :: InclusionSpec -> Inclusion a -> IO (Either InclusionError a)
runInclusion' spec action = runExceptT (runReaderT (runInclusion action) spec)
parseInclusion ::
HashMap String String -> Either InclusionError (Maybe InclusionSpec)
parseInclusion attrs =
case HM.lookup "include" attrs of
Just include -> do
range <- getRange
return (Just InclusionSpec {..})
Nothing -> return Nothing
where
lookupInt name = HM.lookup name attrs >>= readMaybe
snippet = HM.lookup "snippet" attrs
dedent = lookupInt "dedent"
getRange =
case (lookupInt "startLine", lookupInt "endLine") of
(Just start, Just end) ->
maybe
(throwError (InvalidRange start end))
(return . Just)
(mkRange start end)
(Nothing, Just _) -> throwError (IncompleteRange Start)
(Just _, Nothing) -> throwError (IncompleteRange End)
(Nothing, Nothing) -> return Nothing
type Lines = [String]
readIncluded :: Inclusion String
readIncluded = liftIO . readFile =<< asks include
filterLineRange :: Lines -> Inclusion Lines
filterLineRange ls =
asks range >>= \case
Just (Range start end) ->
return (take (end startIndex) (drop startIndex ls))
where startIndex = pred start
Nothing -> return ls
onlySnippet :: Lines -> Inclusion Lines
onlySnippet ls = do
s <- asks snippet
case s of
Just name ->
return $
drop 1 $
takeWhile (not . isSnippetEnd) $ dropWhile (not . isSnippetStart) ls
where isSnippetTag tag line =
(tag ++ " snippet " ++ name) `isInfixOf` line
isSnippetStart = isSnippetTag "start"
isSnippetEnd = isSnippetTag "end"
Nothing -> return ls
dedentLines :: Lines -> Inclusion Lines
dedentLines ls = do
d <- asks dedent
case d of
Just n -> return (map (dedentLine n) ls)
Nothing -> return ls
where
dedentLine 0 line = line
dedentLine _ "" = ""
dedentLine n (c:cs)
| isSpace c = dedentLine (pred n) cs
| otherwise = c : cs
filterAttributes :: [(String, String)] -> [(String, String)]
filterAttributes = filter nonFilterAttribute
where
nonFilterAttribute (key, _) = key `notElem` attributeNames
attributeNames = ["include", "startLine", "endLine", "snippet", "dedent"]
printAndFail :: InclusionError -> IO Block
printAndFail = fail . formatError
where
formatError =
\case
InvalidRange start end ->
"Invalid range: " ++ show start ++ " to " ++ show end
IncompleteRange Start -> "Incomplete range: \"startLine\" is missing"
IncompleteRange End -> "Incomplete range: \"endLine\" is missing"
splitLines :: String -> Inclusion Lines
splitLines = return . lines
joinLines :: Lines -> Inclusion String
joinLines = return . unlines
includeCode :: Maybe Format -> Block -> IO Block
includeCode _ cb@(CodeBlock (id', classes, attrs) _) =
case parseInclusion (HM.fromList attrs) of
Right (Just spec) ->
runInclusion'
spec
(readIncluded >>= splitLines >>= filterLineRange >>= onlySnippet >>=
dedentLines >>=
joinLines) >>= \case
Left err -> printAndFail err
Right contents ->
return (CodeBlock (id', classes, filterAttributes attrs) contents)
Right Nothing -> return cb
Left err -> printAndFail err
includeCode _ x = return x