diff --git a/README.asciidoc b/README.asciidoc --- a/README.asciidoc +++ b/README.asciidoc @@ -158,6 +158,14 @@ CHANGES ------- +0.1.4.5:: + * Added support for recursively traversing includes of .lhs files + * The program now doesn't fail completely when haskell-src-exts fails to parse + a file. An error is reported and the program continues. :) A fmt file is + still generated. + * Removed a faulty command from the list. + * Added a new url. + * Cleaned up some code. (Probably introduced other ugly code) 0.1.4.2:: * Removed trace statement 0.1.4.1:: diff --git a/lhs2TeX-hl.cabal b/lhs2TeX-hl.cabal --- a/lhs2TeX-hl.cabal +++ b/lhs2TeX-hl.cabal @@ -1,5 +1,5 @@ Name: lhs2TeX-hl -Version: 0.1.4.4 +Version: 0.1.4.5 Cabal-Version: >= 1.6 License: MIT Author: Alessandro Vermeulen @@ -29,6 +29,8 @@ , haskell-src-exts == 1.11.1 , syb >= 0.1.0.1 , cmdargs >= 0.1 + , filepath == 1.2.* + , uu-parsinglib >= 2.7 hs-source-dirs: src Other-Modules: Data.Data, Data.List.Utils, Data.String.Utils, Language.LaTeX, Language.Markup, Literate.Agda, diff --git a/src/Base/CLI.hs b/src/Base/CLI.hs --- a/src/Base/CLI.hs +++ b/src/Base/CLI.hs @@ -22,9 +22,11 @@ usage :: String usage = unlines - [ programName ++" "++ programVersion ++" - A lhs2TeX Syntax Coloring pre-processor" + [ programName ++" "++ programVersion ++" - A lhs2TeX Syntax Colouring preprocessor" , "Consult the README file for extra information or visit:\n" - , " https://github.com/spockz/lhs2texhl" + , " https://github.com/spockz/lhs2texhl" + , " and " + , " http://alessandrovermeulen.me/projects/lhs2texhl\n" , "Copyright 2010, Alessandro Vermeulen " ] newCommands :: String @@ -34,7 +36,6 @@ "\\newcommand{\\lhsCHprelude}[1]{\\color{prelude}{{#1}}}", "\\newcommand{\\lhsCHkeyword}[1]{\\color{keyword}{{#1}}}", "\\newcommand{\\lhsCHconstructor}[1]{\\color{constructor}{{#1}}}", - "\\newcommand{\\lhsCHlitNumber}[1]{\\color{numeral}{{#1}}}", "\\newcommand{\\lhsCHtype}[1]{\\color{datatype}{{#1}}}", "\\newcommand{\\lhsCHsyntax}[1]{\\color{syntax}{{#1}}}", "\\newcommand{\\lhsCHclass}[1]{\\color{class}{{#1}}}", diff --git a/src/Base/Common.hs b/src/Base/Common.hs --- a/src/Base/Common.hs +++ b/src/Base/Common.hs @@ -1,4 +1,4 @@ module Base.Common where -programVersion = "0.1.4.3" +programVersion = "0.1.4.5" programName = "lhs2TeX-hl" diff --git a/src/Data/String/Utils.hs b/src/Data/String/Utils.hs --- a/src/Data/String/Utils.hs +++ b/src/Data/String/Utils.hs @@ -4,21 +4,17 @@ rtrim chars inp = rtrim' inp where rtrim' "" = [] - rtrim' [x] = case elem x chars of - True -> [] - False -> [x] + rtrim' [x] = if x `elem` chars then [] else [x] rtrim' (x:xs) = let tail = rtrim' xs in case tail of - [] -> case elem x chars of - True -> [] - False -> [x] + [] -> if x `elem` chars then [] else [x] xs -> x : tail ltrim :: String -> String -> String ltrim chars = ltrim' where ltrim' s = case s of [] -> [] - (x:xs) -> if elem x chars + (x:xs) -> if x `elem` chars then ltrim' xs else s diff --git a/src/Literate/Haskell.hs b/src/Literate/Haskell.hs --- a/src/Literate/Haskell.hs +++ b/src/Literate/Haskell.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} -module Literate.Haskell (runHaskell, mapping, fromParse) where +module Literate.Haskell (runHaskell, mapping) where import Data.List (nub) import Data.Maybe @@ -28,11 +28,11 @@ ) fp -runHaskell :: FilePath -> IO SimpleInfo +runHaskell :: FilePath -> IO (Either String SimpleInfo) runHaskell fp = do mod <- parseFile fp case mod of - (ParseOk m) -> return $ getSimpleInfo m - (ParseFailed loc err) -> error $ + (ParseOk m) -> (return . Right) (getSimpleInfo m) + (ParseFailed loc err) -> (return . Left) $ "Parsing failed at `" ++ show loc ++ " " ++ err @@ -56,7 +56,7 @@ searchTypes _ = [] searchConDecl :: ItemQuery ConDecl -searchConDecl (ConDecl (i) _) = [Constructor $ prettyPrint i] +searchConDecl (ConDecl i _) = [Constructor $ prettyPrint i] searchConDecl (InfixConDecl _ i _) = [Constructor $ prettyPrint i] searchConDecl (RecDecl i _) = [Constructor $ prettyPrint i] @@ -71,7 +71,7 @@ searchExp _ = [] searchMat :: ItemQuery Match -searchMat (Match _ (i) _ _ _ _) = [Function $ prettyPrint i] +searchMat (Match _ i _ _ _ _) = [Function $ prettyPrint i] searchDecl :: ItemQuery Decl searchDecl (TypeSig _ names t) = case t of @@ -144,25 +144,7 @@ mtypes SimpleInfo{types} = map dp types moperators SimpleInfo{operators} = map (\ a -> (a, "\\ \\mathbin{"++ makeLatexSafe a++"}\\ ")) operators -mconstructors SimpleInfo{constructors} = map (dp) constructors -mfunctions SimpleInfo{functions } = map (dp) functions -mclasses SimpleInfo{classes} = map (dp) classes -mconstants SimpleInfo{constants} = map (dp) constants - - - -fooz = [4, 13, 42] -douz = [4.0, 13.0, 42.0] - - - -(<++>) :: a -> b -> a -(<++>) a b = a - -tid :: Typeable a => a -> a -tid = id - - -fromParse (ParseOk m) = m - - +mconstructors SimpleInfo{constructors} = map dp constructors +mfunctions SimpleInfo{functions } = map dp functions +mclasses SimpleInfo{classes} = map dp classes +mconstants SimpleInfo{constants} = map dp constants diff --git a/src/LiterateHighlighter.hs b/src/LiterateHighlighter.hs --- a/src/LiterateHighlighter.hs +++ b/src/LiterateHighlighter.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts, Rank2Types #-} module Main where import Data.List @@ -5,9 +6,17 @@ import System.Environment( getArgs ) import System.IO +import Data.Maybe (fromJust) import Language.Haskell.Exts +import Text.ParserCombinators.UU.Core +import qualified Text.ParserCombinators.UU.Core as PCC ( parse ) +import Text.ParserCombinators.UU.BasicInstances hiding (input) +import Text.ParserCombinators.UU.Derived +import Text.ParserCombinators.UU.Utils + +import System.FilePath ( takeDirectory ) ----------------------------- import Base.CLI @@ -18,39 +27,75 @@ import Language.Markup + + ----------------------------- main = do args <- cmdArgsRun standard - - hSetEncoding stdin utf8 - hSetEncoding stdout utf8 - hSetEncoding stderr utf8 + goUTF8 - case (action args) of + case action args of ListCommands -> putStr newCommands - _ -> if (agda_mode args) + _ -> if agda_mode args then error "Agda mode is currently not supported." else printFormatting args - where printFormat keyword seek rep = "%format " ++ seek ++ " = \" {\\lhsCH" ++ keyword ++ "{" ++ rep ++ "}}\"" - writeOutput output si mapping = - mapM_ (\(keyword, f) -> mapM_ (\ (seek,rep) -> hPutStrLn output $ printFormat keyword seek rep) + where printFormat keyword (seek, rep) = "%format " ++ seek ++ " = \" {\\lhsCH" ++ keyword ++ "{" ++ rep ++ "}}\"" + writeOutput output mapping si = + mapM_ (\(keyword, f) -> mapM_ (hPutStrLn output . printFormat keyword) (filter lhs2TeXSafe (f si)) ) mapping - printFormatting args = do hOutput <- openFile (output args) WriteMode - let writer = writeOutput hOutput - hSetEncoding hOutput utf8 - mapM_ (\file -> runHaskell file - >>= (flip writer) Literate.Haskell.mapping) - (input args) + printFormatting args = do hOutput <- openUTF8File (output args) + let writer m (Right si) = writeOutput hOutput m si + writer _ (Left err) = hPutStrLn stderr $ "There was an error, a file has been skipped:" ++ err + + files <- fmap (nub . concat) + (mapM discoverFiles (input args)) + + mapM_ ((writer Literate.Haskell.mapping =<<) . runHaskell) + files hClose hOutput + goUTF8 = do hSetEncoding stdin utf8 + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + openUTF8File fp = do hOutput <- openFile fp WriteMode + hSetEncoding hOutput utf8 + return hOutput + +discoverFiles :: FilePath -> IO [FilePath] +discoverFiles fp = do contents <- fmap (\xs -> [base ++ x | Just x <- map runPInclude (lines xs)]) + (readFile fp) + files <- mapM discoverFiles contents + return (nub $ fp : concat files) + where files = undefined + base = takeDirectory fp ++ "/" + +runPInclude :: String -> Maybe String +runPInclude xs@('%':_) = runParse pInclude xs +runPInclude _ = Nothing + +runParse :: Show t => Parser t -> String -> Maybe t +runParse p inp = let r@(a, errors) = PCC.parse ( (,) <$> p <*> pEnd) + (createStr (LineColPos 0 0 0) inp) + in if null errors then Just a else Nothing + +pInclude :: Parser FilePath +pInclude = (++ ".lhs") <$> ( pSymbol "%" + *> pSymbol "include" + *> pSome (pLetter <|> pDigit <|> pSym '/') + <* pSymbol ".lhs") +isJust :: Maybe a -> Bool +isJust (Nothing) = False +isJust (Just _) = True lhs2TeXSafe :: (String, String) -> Bool lhs2TeXSafe ("()" , _) = False lhs2TeXSafe _ = True + +