module Manual.Reader where
import Manual.Structure
import Manual.Emit.Text
import Data.Yaml.Simple
import Text.Parsec
import Text.Parsec.String
import Data.Either
import Data.Maybe
import Data.List
import Error.Report
import Safe
import System.FilePath
import System.Directory
import qualified Data.Set as S
import Control.Monad
import Control.Exception hiding (try)
inline :: Parser Inline
inline =
try text <|> try section_link <|> try extern_link <|> try iliteral
where
iliteral = do
char '{'
spaces
string "literal"
spaces
text <- many1 $ noneOf "\n\t\r}"
spaces
char '}'
return $ ILiteral text
text :: Parser Inline
text = fmap IText $
try (many1 $ noneOf "\\{") <|>
try (string "\\{" >> return "{") <|>
(fmap return $ char '\\')
section_link = link "section" ISectionLink
extern_link = link "external" IExternLink
link name f = do
char '{'
spaces
string name
space
spaces
fst_elem <- many1 $ noneOf " \n\t\r"
spaces
rest <- sepEndBy1 end_id (space >> spaces)
spaces
char '}'
let uniq = last rest
txt = unwords $ fst_elem : init rest
return $ f txt uniq
where
end_id = many1 $ noneOf " \n\t\r}"
eparse_inline :: String -> Either ParseError [Inline]
eparse_inline txt =
if null txt
then Right [IText ""]
else
parse (do
is <- many1 inline
eof
return is) "" txt
parse_inline :: String -> IO [Inline]
parse_inline txt = evaluate $
either (throw . error_line "Error while parsing inline elements from paragraph beginning:" . error_section .
error_line (unwords (take 5 $ words txt) ++ "...") . error_section . (flip error_lines empty_error) . lines . show)
id
(eparse_inline txt)
instance Yamlable Banner where
from_yaml y =
case y of
YStr s -> liftM2 Banner (parse_inline s) (return "")
YMap _ -> let mcls = yookup "class" y in do
clss <- maybe (return "")
(evaluate . fromMaybe (berror "Error parsing class field. Must be a string.") . ystr) mcls
txt <- maybe (return [])
(maybe (evaluate $ berror "Error parsing text field.") parse_inline . ystr) $ yookup "text" y
when (null txt) $ evaluate $ berror "Banner text cannot be empty"
evaluate $ Banner txt clss
_ -> berror "Banner must be a string or a map."
where
berror msg = throw $
error_line "Error while reading Banner: " $
error_section $ error_line msg $ error_section $
error_lines ["Reading yaml:", show y] $ empty_error
instance Yamlable Paragraph where
from_yaml y =
case y of
YStr s ->
liftM3 Paragraph (parse_inline s) (return "") (return True)
YMap m -> let mw = yookup "wrap" y
mcls = yookup "class" y in do
wrap <- maybe (return True)
(evaluate . fromMaybe (perror "Error parsing wrap field. Must be True or False.") .
(\y -> ystr y >>= (readMay :: String -> Maybe Bool))) mw
clss <- maybe (return "")
(evaluate . fromMaybe (perror "Error parsing class field. Must be a string.") . ystr) mcls
liftM3 Paragraph (parse_inline $ ptext "text") (evaluate clss) (evaluate wrap)
_ -> throw $ new_error "Paragraph must be a string or a map"
where
ptext :: String -> String
ptext nm =
yext (yookup nm y) (perror $ "Could not find field '" ++ nm ++ "' in paragraph map. Must have members 'text' and 'class'")
perror msg = throw $
error_line "Error while reading Paragraph: " $
error_section $ error_line msg $ error_section $
error_lines ["Reading yaml:", show y] $ empty_error
yext :: Maybe Yaml -> String -> String
yext y str = fromMaybe str $ y >>= ystr
ystr :: Yaml -> Maybe String
ystr y =
case y of
YStr s -> Just s
_ -> Nothing
ymap :: (Yaml -> a) -> Yaml -> Maybe [a]
ymap f y =
case y of
YSeq ys -> Just $ map f ys
_ -> Nothing
instance Yamlable Section where
from_yaml y = do
mps <- paras $ yookup "text" y
ps <- maybe (serror "text") evaluate mps
liftM5 Section (evaluate [snumber $ yookup "number" y])
(stitle $ yookup "title" y)
(evaluate $ read_key (serror "unique") $ yookup "unique" y)
(return ps)
(return [])
where
snumber a =
fromMaybe (serror "number") $ a >>= ystr >>= readMay
stitle =
read_mbanner (serror "title")
serror msg = throw $
error_line "Error while reading Section:" $ error_section $
error_line ("Section did not have a valid '" ++ msg ++ "' member.") $ error_section $
error_lines ["Reading yaml:", show y] empty_error
read_mbanner :: Banner -> Maybe Yaml -> IO Banner
read_mbanner ba =
maybe (evaluate ba) from_yaml
read_key :: String -> Maybe Yaml -> String
read_key err ma = not_empty err $ yext ma err
not_empty :: String -> String -> String
not_empty nm str =
if null str
then nm
else str
load_section :: FilePath -> IO Section
load_section sfp = load_section_nums sfp []
catch_read_errs :: String -> IO a -> IO a
catch_read_errs msg act =
act `catches` [Handler reporth, Handler anyh]
where
reporth :: Error -> a
reporth e = throw $ ewhere e
ewhere = error_line msg . error_section
anyh :: SomeException -> a
anyh e = throw $ ewhere $ error_lines (lines $ show e) empty_error
load_section_nums :: FilePath
-> [Int]
-> IO Section
load_section_nums fp nums = catch_read_errs ("Error in section file " ++ fp) $ do
root <- parse_yaml_file fp
un_root_section <- from_yaml root
let new_nums = number un_root_section ++ nums
root_section = un_root_section {number = reverse new_nums}
subsection_dir = dropExtensions fp
subsections_exist <- doesDirectoryExist subsection_dir
if subsections_exist
then do
subsect_fs <- getDirectoryFiles subsection_dir
subsects <- mapM (flip load_section_nums new_nums) subsect_fs
return $ root_section {subsections = sort_sections subsects}
else
evaluate root_section
where
dir = dropFileName fp
sort_sections :: [Section] -> [Section]
sort_sections =
sortBy (\s1 s2 -> number s1 `compare` number s2)
paras :: Maybe Yaml -> IO (Maybe [Paragraph])
paras ma =
maybe (return Nothing) next ma
where
next :: Yaml -> IO (Maybe [Paragraph])
next y =
case y of
YStr t -> fmap (Just . return) $ from_yaml y
y -> maybe (return Nothing) (fmap Just . sequence) $ ymap from_yaml y
instance Yamlable Header where
from_yaml y = let mb = yookup "banners" y in do
bs <- maybe (return []) (\ybs ->
case ybs of
YStr _ -> fmap return $ from_yaml ybs
YSeq ys -> mapM from_yaml ys
YMap _ -> fmap return $ from_yaml ybs
_ -> herror "banner") mb
liftM3 Header title
(evaluate bs)
preamble
where
title = read_mbanner (herror "title") $ yookup "title" y
preamble = fmap (fromMaybe []) $ paras $ yookup "preamble" y
herror nm = throw $
error_line "Error while reading Header:" $
error_section $ error_line ("Header did not have valid '" ++ nm ++ "' field.") $ error_section $
error_lines ["Reading yaml:", show y] empty_error
getDirectoryFiles :: FilePath -> IO [FilePath]
getDirectoryFiles dir = do
fs <- fmap (map (combine dir) . filter (\f -> head f /= '.')) $ getDirectoryContents dir
filterM doesFileExist fs
load_manual :: FilePath -> IO Manual
load_manual man_dir = do
fs <- getDirectoryFiles man_dir
let files = S.fromList fs
sfs = S.delete headf $ S.delete css_file $ files
headf = combine man_dir "header.yaml"
catch_read_errs ("Error creating manual from source directory '" ++ man_dir ++ "':") (load_data headf files sfs)
where
load_data headf files sfs = do
css <- if S.member css_file files then readFile css_file else return ""
if S.member headf files
then do
head <- parse_yaml_file headf >>= from_yaml
sections <- fmap sort_sections $ mapM load_section $ S.toList sfs
evaluate $ Manual head css (contents sections) sections
else throw $ new_error "Header not present"
css_file = man_dir `combine` "style" `addExtension` "css"