{-# LANGUAGE CPP, OverloadedStrings #-}
module Text.Markdown.Unlit (
  run
, unlit
, Selector (..)
, parseSelector
, CodeBlock (..)
, parse
#ifdef TEST
, parseClasses
#endif
) where

import           Prelude ()
import           Prelude.Compat
import           Data.Maybe
import           Data.List.Compat
import           Data.Char
import           Data.String
import           System.IO
import           System.Exit
import           System.Environment

fenceChars :: [Char]
fenceChars :: [Char]
fenceChars = [Char
'`', Char
'~']

fences :: [String]
fences :: [[Char]]
fences = (Char -> [Char]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
3) [Char]
fenceChars

-- | Program entry point.
run :: [String] -> IO ()
run :: [[Char]] -> IO ()
run [[Char]]
args =
  -- GHC calls unlit like so:
  --
  -- > unlit [args] -h label Foo.lhs /tmp/somefile
  --
  -- [args] are custom arguments provided with -optL
  --
  -- The label is meant to be used in line pragmas, like so:
  --
  -- #line 1 "label"
  --
  case ([Char] -> Bool) -> [[Char]] -> ([[Char]], [[Char]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"-h") [[Char]]
args of
    ([[Char]]
xs, [[Char]
"-h", [Char]
fileName, [Char]
infile, [Char]
outfile]) ->
      ([Char] -> [Char]) -> IO [Char] -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char] -> Selector -> [Char] -> [Char]
unlit [Char]
fileName (Selector -> [Char] -> [Char]) -> Selector -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Selector
mkSelector [[Char]]
xs) ([Char] -> IO [Char]
readFileUtf8 [Char]
infile) IO [Char] -> ([Char] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> [Char] -> IO ()
writeFileUtf8 [Char]
outfile
    ([[Char]], [[Char]])
_ -> do
      [Char]
name <- IO [Char]
getProgName
      Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char]
"usage: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" [selector] -h label infile outfile")
      IO ()
forall a. IO a
exitFailure
    where
      mkSelector :: [[Char]] -> Selector
mkSelector = Selector -> Maybe Selector -> Selector
forall a. a -> Maybe a -> a
fromMaybe (Selector
"haskell" Selector -> Selector -> Selector
:&: Selector -> Selector
Not Selector
"ignore") (Maybe Selector -> Selector)
-> ([[Char]] -> Maybe Selector) -> [[Char]] -> Selector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe Selector
parseSelector ([Char] -> Maybe Selector)
-> ([[Char]] -> [Char]) -> [[Char]] -> Maybe Selector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unwords
      readFileUtf8 :: [Char] -> IO [Char]
readFileUtf8 [Char]
name = [Char] -> IOMode -> IO Handle
openFile [Char]
name IOMode
ReadMode IO Handle -> (Handle -> IO [Char]) -> IO [Char]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Handle
h -> Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8 IO () -> IO [Char] -> IO [Char]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO [Char]
hGetContents Handle
h
      writeFileUtf8 :: [Char] -> [Char] -> IO ()
writeFileUtf8 [Char]
name [Char]
str = [Char] -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
name IOMode
WriteMode (\Handle
h -> Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> [Char] -> IO ()
hPutStr Handle
h [Char]
str)

unlit :: FilePath -> Selector -> String -> String
unlit :: [Char] -> Selector -> [Char] -> [Char]
unlit [Char]
fileName Selector
selector = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CodeBlock -> [[Char]]) -> [CodeBlock] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CodeBlock -> [[Char]]
formatCB ([CodeBlock] -> [[Char]])
-> ([Char] -> [CodeBlock]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CodeBlock -> Bool) -> [CodeBlock] -> [CodeBlock]
forall a. (a -> Bool) -> [a] -> [a]
filter (Selector -> [[Char]] -> Bool
toP Selector
selector ([[Char]] -> Bool) -> (CodeBlock -> [[Char]]) -> CodeBlock -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeBlock -> [[Char]]
codeBlockClasses) ([CodeBlock] -> [CodeBlock])
-> ([Char] -> [CodeBlock]) -> [Char] -> [CodeBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [CodeBlock]
parse
  where
    formatCB :: CodeBlock -> [String]
    formatCB :: CodeBlock -> [[Char]]
formatCB CodeBlock
cb = ([Char]
"#line " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (CodeBlock -> Int
codeBlockStartLine CodeBlock
cb) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
fileName) [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: CodeBlock -> [[Char]]
codeBlockContent CodeBlock
cb

    toP :: Selector -> [String] -> Bool
    toP :: Selector -> [[Char]] -> Bool
toP = Selector -> [[Char]] -> Bool
forall (t :: * -> *). Foldable t => Selector -> t [Char] -> Bool
go
      where
        go :: Selector -> t [Char] -> Bool
go Selector
s = case Selector
s of
          Class [Char]
c -> [Char] -> t [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char]
c
          Not Selector
p   -> Bool -> Bool
not (Bool -> Bool) -> (t [Char] -> Bool) -> t [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Selector -> t [Char] -> Bool
go Selector
p
          Selector
a :&: Selector
b -> Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> (t [Char] -> Bool) -> t [Char] -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Selector -> t [Char] -> Bool
go Selector
a (t [Char] -> Bool -> Bool)
-> (t [Char] -> Bool) -> t [Char] -> Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Selector -> t [Char] -> Bool
go Selector
b
          Selector
a :|: Selector
b -> Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool)
-> (t [Char] -> Bool) -> t [Char] -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Selector -> t [Char] -> Bool
go Selector
a (t [Char] -> Bool -> Bool)
-> (t [Char] -> Bool) -> t [Char] -> Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Selector -> t [Char] -> Bool
go Selector
b

infixr 3 :&:
infixr 2 :|:

data Selector
  = Class String
  | Not Selector
  | Selector :&: Selector
  | Selector :|: Selector
  deriving (Selector -> Selector -> Bool
(Selector -> Selector -> Bool)
-> (Selector -> Selector -> Bool) -> Eq Selector
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Selector -> Selector -> Bool
$c/= :: Selector -> Selector -> Bool
== :: Selector -> Selector -> Bool
$c== :: Selector -> Selector -> Bool
Eq, Int -> Selector -> [Char] -> [Char]
[Selector] -> [Char] -> [Char]
Selector -> [Char]
(Int -> Selector -> [Char] -> [Char])
-> (Selector -> [Char])
-> ([Selector] -> [Char] -> [Char])
-> Show Selector
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Selector] -> [Char] -> [Char]
$cshowList :: [Selector] -> [Char] -> [Char]
show :: Selector -> [Char]
$cshow :: Selector -> [Char]
showsPrec :: Int -> Selector -> [Char] -> [Char]
$cshowsPrec :: Int -> Selector -> [Char] -> [Char]
Show)

parseSelector :: String -> Maybe Selector
parseSelector :: [Char] -> Maybe Selector
parseSelector [Char]
input = case [Char] -> [[Char]]
words [Char]
input of
  [] -> Maybe Selector
forall a. Maybe a
Nothing
  [[Char]]
xs -> (Selector -> Maybe Selector
forall a. a -> Maybe a
Just (Selector -> Maybe Selector)
-> ([[Char]] -> Selector) -> [[Char]] -> Maybe Selector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Selector -> Selector -> Selector) -> [Selector] -> Selector
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Selector -> Selector -> Selector
(:|:) ([Selector] -> Selector)
-> ([[Char]] -> [Selector]) -> [[Char]] -> Selector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Selector) -> [[Char]] -> [Selector]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Selector
parseAnds) [[Char]]
xs
  where
    parseAnds :: [Char] -> Selector
parseAnds = (Selector -> Selector -> Selector) -> [Selector] -> Selector
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Selector -> Selector -> Selector
(:&:) ([Selector] -> Selector)
-> ([Char] -> [Selector]) -> [Char] -> Selector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Selector) -> [[Char]] -> [Selector]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Selector
parseClass ([[Char]] -> [Selector])
-> ([Char] -> [[Char]]) -> [Char] -> [Selector]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [[Char]]
split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+')

    parseClass :: [Char] -> Selector
parseClass [Char]
c = case [Char]
c of
      Char
'!':[Char]
xs -> Selector -> Selector
Not ([Char] -> Selector
Class [Char]
xs)
      [Char]
_      -> [Char] -> Selector
Class [Char]
c

    -- a copy from https://github.com/sol/string
    split :: (Char -> Bool) -> String -> [String]
    split :: (Char -> Bool) -> [Char] -> [[Char]]
split Char -> Bool
p = [Char] -> [[Char]]
go
      where
        go :: [Char] -> [[Char]]
go [Char]
xs = case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
p [Char]
xs of
          ([Char]
ys, [])   -> [[Char]
ys]
          ([Char]
ys, Char
_:[Char]
zs) -> [Char]
ys [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char] -> [[Char]]
go [Char]
zs

instance IsString Selector where
  fromString :: [Char] -> Selector
fromString = [Char] -> Selector
Class

data CodeBlock = CodeBlock {
  CodeBlock -> [[Char]]
codeBlockClasses   :: [String]
, CodeBlock -> [[Char]]
codeBlockContent   :: [String]
, CodeBlock -> Int
codeBlockStartLine :: Int
} deriving (CodeBlock -> CodeBlock -> Bool
(CodeBlock -> CodeBlock -> Bool)
-> (CodeBlock -> CodeBlock -> Bool) -> Eq CodeBlock
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CodeBlock -> CodeBlock -> Bool
$c/= :: CodeBlock -> CodeBlock -> Bool
== :: CodeBlock -> CodeBlock -> Bool
$c== :: CodeBlock -> CodeBlock -> Bool
Eq, Int -> CodeBlock -> [Char] -> [Char]
[CodeBlock] -> [Char] -> [Char]
CodeBlock -> [Char]
(Int -> CodeBlock -> [Char] -> [Char])
-> (CodeBlock -> [Char])
-> ([CodeBlock] -> [Char] -> [Char])
-> Show CodeBlock
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [CodeBlock] -> [Char] -> [Char]
$cshowList :: [CodeBlock] -> [Char] -> [Char]
show :: CodeBlock -> [Char]
$cshow :: CodeBlock -> [Char]
showsPrec :: Int -> CodeBlock -> [Char] -> [Char]
$cshowsPrec :: Int -> CodeBlock -> [Char] -> [Char]
Show)

type Line = (Int, String)

parse :: String -> [CodeBlock]
parse :: [Char] -> [CodeBlock]
parse = [Line] -> [CodeBlock]
go ([Line] -> [CodeBlock])
-> ([Char] -> [Line]) -> [Char] -> [CodeBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [[Char]] -> [Line]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
2..] ([[Char]] -> [Line]) -> ([Char] -> [[Char]]) -> [Char] -> [Line]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines
  where
    go :: [Line] -> [CodeBlock]
    go :: [Line] -> [CodeBlock]
go [Line]
xs = case (Line -> Bool) -> [Line] -> ([Line], [Line])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Line -> Bool
isFence [Line]
xs of
      ([Line]
_, [])   -> []
      ([Line]
_, Line
y:[Line]
ys) -> case Line -> [Line] -> (CodeBlock, [Line])
takeCB Line
y [Line]
ys of
        (CodeBlock
cb, [Line]
rest) -> CodeBlock
cb CodeBlock -> [CodeBlock] -> [CodeBlock]
forall a. a -> [a] -> [a]
: [Line] -> [CodeBlock]
go [Line]
rest

    takeCB :: Line -> [Line] -> (CodeBlock, [Line])
    takeCB :: Line -> [Line] -> (CodeBlock, [Line])
takeCB (Int
n, [Char]
fence) [Line]
xs =
      let indent :: Int
indent = [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int) -> ([Char] -> [Char]) -> [Char] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isSpace ([Char] -> Int) -> [Char] -> Int
forall a b. (a -> b) -> a -> b
$ [Char]
fence
      in case (Line -> Bool) -> [Line] -> ([Line], [Line])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Line -> Bool
isFence [Line]
xs of
        ([Line]
cb, [Line]
rest) -> ([[Char]] -> [[Char]] -> Int -> CodeBlock
CodeBlock ([Char] -> [[Char]]
parseClasses [Char]
fence) ((Line -> [Char]) -> [Line] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
indent ([Char] -> [Char]) -> (Line -> [Char]) -> Line -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> [Char]
forall a b. (a, b) -> b
snd) [Line]
cb) Int
n, Int -> [Line] -> [Line]
forall a. Int -> [a] -> [a]
drop Int
1 [Line]
rest)

    isFence :: Line -> Bool
    isFence :: Line -> Bool
isFence = [Char] -> Bool
p ([Char] -> Bool) -> (Line -> [Char]) -> Line -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ([Char] -> [Char]) -> (Line -> [Char]) -> Line -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> [Char]
forall a b. (a, b) -> b
snd
      where
        p :: String -> Bool
        p :: [Char] -> Bool
p [Char]
line = ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
line) [[Char]]
fences

parseClasses :: String -> [String]
parseClasses :: [Char] -> [[Char]]
parseClasses [Char]
xs = [Char] -> [[Char]]
words ([Char] -> [[Char]]) -> ([Char] -> [Char]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char -> [Char] -> [Char]
replace Char
'.' Char
' ' ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ case (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
fenceChars) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
xs of
  Char
'{':[Char]
ys -> (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}') [Char]
ys
  [Char]
ys -> [Char]
ys

replace :: Char -> Char -> String -> String
replace :: Char -> Char -> [Char] -> [Char]
replace Char
x Char
sub = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
f
  where
    f :: Char -> Char
f Char
y | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
y    = Char
sub
        | Bool
otherwise = Char
y