diff --git a/LiterateHighlighter.hs b/LiterateHighlighter.hs deleted file mode 100644 --- a/LiterateHighlighter.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Main where - -import Data.List - -import System( getArgs ) -import System.IO - - -import Language.Haskell.Exts - ------------------------------ - -import Base.CLI -import System.Console.CmdArgs - -import Literate.Agda -import Literate.Haskell -import Literate.SimpleInfo - ------------------------------ - - -main = do args <- cmdArgsRun standard - - hSetEncoding stdin utf8 - hSetEncoding stdout utf8 - hSetEncoding stderr utf8 - - hOutput <- openFile (output args) WriteMode - hSetEncoding hOutput utf8 - - let writer = writeOutput hOutput - - if (agda_mode args) - then - mapM_ (\file -> runAgda file - >>= (flip writer) Literate.Agda.mapping) - (input args) - else - mapM_ (\file -> runHaskell file - >>= (flip writer) Literate.Haskell.mapping) - (input args) - - hClose hOutput - 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) - (f si)) - mapping - 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.0.9 +Version: 0.1.1.0 Cabal-Version: >= 1.6 License: MIT Author: Alessandro Vermeulen @@ -13,6 +13,7 @@ category: Development, Language Data-files: README examples/theme1.tex License-file: LICENSE +bug-reports: http://github.com/spockz/lhs2texhl/issues Executable lhs2TeX-hl Main-Is: LiterateHighlighter.hs @@ -21,5 +22,8 @@ , haskell-src-exts >= 1.9.3 , MissingH >= 1.1.0.3 , syb >= 0.1.0.1 - , Agda >= 2.2.6 , cmdargs >= 0.1 + , Agda >= 2.2.6 + hs-source-dirs: src + Other-Modules: Language.LaTeX, Literate.Agda, Literate.Haskell, + Literate.SimpleInfo, Base.Cli, Base.Common diff --git a/src/Base/Cli.hs b/src/Base/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Base/Cli.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Base.CLI (ProgramOptions(..), usage, standard, module System.Console.CmdArgs) where + +import System.Console.CmdArgs + +import Base.Common + +data ProgramOptions = ProgramOptions + { agda_mode :: Bool + , input :: [FilePath] + , output :: FilePath + } deriving (Show, Data, Typeable) + + + +usage :: String +usage = unlines + [ programName ++" "++ programVersion ++" - A lhs2TeX Syntax Coloring pre-processor" + , "Copyright 2010, Alessandro Vermeulen " ] + + + +-- | Standard command line options. +-- + +standard = cmdArgsMode $ ProgramOptions + { + agda_mode = def &= help "Run in agda-mode!" + , output = (def &= help "Output file") &= typFile + , input = (def &= args ) + } &= summary usage + + diff --git a/src/Base/Common.hs b/src/Base/Common.hs new file mode 100644 --- /dev/null +++ b/src/Base/Common.hs @@ -0,0 +1,4 @@ +module Base.Common where + +programVersion = "0.1.1.0" +programName = "lhs2TeX-hl" diff --git a/src/Language/LaTeX.hs b/src/Language/LaTeX.hs new file mode 100644 --- /dev/null +++ b/src/Language/LaTeX.hs @@ -0,0 +1,51 @@ +module Language.LaTeX where + +import Data.String.Utils + +makeLatexSafe :: String -> String +makeLatexSafe = replace ">" "\\textgreater" + . replace "<" "\\textless" + . replace "_" "\\_" + . replace "\"" "\\\"" + + . replace "&" "\\&" + . replace "#" "\\#" + +{- This part is to conserve some lhs2TeX behaviour. Really shouldn't be here... -} + . replace "=" "\\ = \\ " + . replace "_" "\\ \\anonymous\\ " + . replace "$" "\\ \\mathbin{\\$}\\ " + . replace "&&" "\\ \\mathrel{\\wedge}\\ " + . replace "||" "\\ \\mathrel{\\vee}\\ " + . replace "<-" "\\ \\leftarrow\\ " + . replace "->" "\\ \\to\\ " + . replace "=>" "\\ \\Rightarrow\\ " + . replace "==" "\\ \\equiv\\ " + . replace "++" "\\ \\plus\\ " + . replace "/=" "\\ \\not\\equiv\\ " + . replace "<=" "\\ \\leq\\ " + . replace ">=" "\\ \\geq\\ " + . replace ">>" "\\ \\sequ\\ " + . replace ">>=" "\\ \\bind\\ " + . replace "=<<" "\\ \\rbind\\ " + . replace "undefined" "\\bot\\ " + . replace "not" "\\ \\neg " + + + -- %format _ = "\anonymous " + -- %format -> = "\to " + -- %format <- = "\leftarrow " + -- %format => = "\Rightarrow " + -- %format \ = "\lambda " + -- %format | = "\mid " + + . replace "{" "\\{" + . replace "}" "\\}" + + . replace "\\" "\\lambda " -- argh + +char :: Integer -> String +char n = "\\ \\char''" ++ show n ++"\\ " + +dp :: String -> (String, String) +dp a = (a, makeLatexSafe a) diff --git a/src/Literate/Agda.hs b/src/Literate/Agda.hs new file mode 100644 --- /dev/null +++ b/src/Literate/Agda.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Literate.Agda (runAgda, mapping) where + +import Data.List (nub) +import Data.Data +import Data.Generics + +--- + + +import Agda.Syntax.Concrete +import Agda.Syntax.Literal + +import Agda.Syntax.Parser +import Agda.Utils.FileName + +---- + +import Language.LaTeX + +import Literate.SimpleInfo + +---- + +runAgda :: FilePath -> IO SimpleInfo +runAgda path = do abpath <- absolute path + mod <- parseFile' moduleParser abpath + return simpleinfo{ functions = [] + , operators = listOperators mod + , literalNumbers = listLiteralNumbers mod + } + +mapping :: [(String, SimpleInfo -> [(String,String)])] +mapping = [ + ("litNumber", mnumbers) + , ("infixoperator", moperators) + ] + +listOperators :: Module -> [String] +listOperators = nub . everything (++) ([] `mkQ` listOperator) + where listOperator :: Expr -> [String] + listOperator (OpApp _ n _) = [show n] + listOperator (_) = [] + +listLiteralNumbers :: Module -> [String] +listLiteralNumbers = nub . everything (++) ([] `mkQ` listLiteralNumber) + where listLiteralNumber :: Literal -> [String] + listLiteralNumber (LitInt _ v) = [show v] + listLiteralNumber (LitFloat _ v) = [show v] + listLiteralNumber (_) = [] + +mnumbers SimpleInfo{literalNumbers} = map dp literalNumbers +moperators SimpleInfo{operators} = map (\ a -> (a, "\\ "++ makeLatexSafe a++"\\ ")) + operators diff --git a/src/Literate/Haskell.hs b/src/Literate/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/Literate/Haskell.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NamedFieldPuns #-} +module Literate.Haskell (runHaskell, mapping) where + +import Data.List (nub) +import Data.Data +import Data.Generics +import Language.Haskell.Exts + +import Language.LaTeX +import Literate.SimpleInfo + + +newtype M = M Module deriving (Typeable, Data) + + +runHaskell :: FilePath -> IO SimpleInfo +runHaskell fp = do mod <- parseFile fp + case mod of + (ParseOk m) -> return $ getSimpleInfo m + (ParseFailed loc err) -> error $ + "Parsing failed at `" + ++ show loc + ++ " " ++ err + + +{- SYB Queries -} +listTypes :: Module -> [String] +listTypes m = (map prettyPrint (collectTypes m)) + where + collectTypes :: Module -> [QName] + collectTypes = nub . everything (++) ([] `mkQ` getData) where + getData :: Type -> [QName] + getData (TyCon n) = [n] + getData _ = [] + + +listLitNumbers :: Module -> [String] +listLitNumbers = nub . everything (++) ([] `mkQ` listLitNumber) + where listLitNumber :: Literal -> [String] + listLitNumber (Char _) = [] + listLitNumber (String _) = [] + listLitNumber (Int v) = [show v] + listLitNumber (Frac v) = [show v] + listLitNumber (PrimInt v) = [show v] + listLitNumber (PrimFloat v) = [show v] + listLitNumber (PrimDouble v) = [show v] + listLitNumber (_) = [] + +listConstructors :: Module -> [String] +listConstructors = nub . everything (++) ([] `mkQ` listConstructor) + where listConstructor :: ConDecl -> [String] + listConstructor (ConDecl (i) _) = [prettyPrint i] + listConstructor (InfixConDecl _ i _) = [prettyPrint i] + listConstructor (RecDecl i _) = [prettyPrint i] + +listFunctions :: Module -> [String] +listFunctions = nub . everything (++) ([] `mkQ` functionBinding `extQ` functionUse) + where functionBinding :: Match -> [String] + functionBinding (Match _ (i) _ _ _ _) = [prettyPrint i] + functionUse :: Exp -> [String] + functionUse (App (Var qname) _) = [prettyPrint qname] + functionUse _ = [] + +listOperators :: Module -> [String] +listOperators = nub . everything (++) ([] `mkQ` operatorUse) + where operatorUse :: Exp -> [String] + operatorUse (InfixApp _ qop _) = [prettyPrint qop] + operatorUse _ = [] + + +getSimpleInfo m = simpleinfo{ types = listTypes m + , literalNumbers = listLitNumbers m + , constructors = listConstructors m + , functions = listFunctions m + , operators = listOperators m + } + + + +mapping :: [(String, SimpleInfo -> [(String,String)])] +mapping = [ ("syntax", syntax) + , ("keyword", keywords) + , ("prelude", prelude) + , ("applicative", applicative ) + , ("type", mtypes) + , ("litNumber", mnumbers) + , ("constructor", mconstructors) + , ("function", mfunctions) + , ("infixoperator", moperators) + ] + +mtypes :: SimpleInfo -> [(String, String)] +mtypes SimpleInfo{types} = map dp types +moperators SimpleInfo{operators} = map (\ a -> (a, "\\ "++ makeLatexSafe a++"\\ ")) + operators +mnumbers SimpleInfo{literalNumbers} = map dp literalNumbers +mconstructors SimpleInfo{constructors} = map (dp) constructors +mfunctions SimpleInfo{functions } = map (dp) functions + +syntax _ = map dp [ "=", "{", "}", "(", ")", "<-", "->", "=>", "," + ] + +keywords _ = map dp [ "data", "deriving", "type", "instance", "family", "where" + , "newtype", "if", "then", "else", "case", "of", "module" + , "as", "hiding", "import", "let", "in", "do", "class"] + +prelude SimpleInfo{functions } = map dp $ + filter ((flip elem) functions) + ["abs" , "acos" , "acosh" , "all" , "and" , "any" , + "appendFile" , "applyM" , "asTypeOf" , "asin" , "asinh" , + "atan" , "atan2" , "atanh" , "break" , "catch" , "ceiling", + "compare" , "concat" , "concatMap" , "const" , "cos" , + "cosh" , "curry" , "cycle" , "decodeFloat" , "div" , + "divMod" , "drop" , "dropWhile" , "elem" , "encodeFloat" , + "enumFrom" , "enumFromThen" , "enumFromThenTo" , + "enumFromTo" , "error" , "even" , "exp" , "exponent" , + "fail" , "filter" , "flip" , "floatDigits" , "floatRadix" , + "floatRange" , "floor" , "fmap" , "foldl" , "foldl1" , + "foldr" , "foldr1" , "fromEnum" , "fromInteger" , + "fromIntegral" , "fromRational" , "fst" , "gcd" , + "getChar" , "getContents" , "getLine" , "head" , "id" , + "init" , "interact" , "ioError" , "isDenormalized" , + "isIEEE" , "isInfinite" , "isNaN" , "isNegativeZero" , + "iterate" , "last" , "lcm" , "length" , "lex" , "lines" , + "log" , "logBase" , "lookup" , "map" , "mapM" , "mapM_" , + "max" , "maxBound" , "maximum" , "maybe" , "min" , + "minBound" , "minimum" , "mod" , "negate" , "not" , + "notElem" , "null" , "odd" , "or" , "otherwise" , "pi" , + "pred" , "print" , "product" , "properFraction" , + "putChar" , "putStr" , "putStrLn" , "quot" , "quotRem" , + "read" , "readFile" , "readIO" , "readList" , "readLn" , + "readParen" , "reads" , "readsPrec" , "realToFrac" , + "recip" , "rem" , "repeat" , "replicate" , "return" , + "reverse" , "round" , "scaleFloat" , "scanl" , "scanl1" , + "scanr" , "scanr1" , "seq" , "sequence" , "sequence_" , + "show" , "showChar" , "showList" , "showParen" , + "showString" , "shows" , "showsPrec" , "significand" , + "signum" , "sin" , "sinh" , "snd" , "span" , "splitAt" , + "sqrt" , "subtract" , "succ" , "sum" , "tail" , "take" , + "takeWhile" , "tan" , "tanh" , "toEnum" , "toInteger" , + "toRational" , "truncate" , "uncurry" , + "unlines" , "until" , "unwords" , "unzip" , "unzip3" , + "userError" , "words" , "writeFile" , "zip" , "zip3" , + "zipWith" , "zipWith3", "$"] + + +applicative _ = [] + +fooz = [4, 13, 42] +douz = [4.0, 13.0, 42.0] + + + +(<++>) :: a -> b -> a +(<++>) a b = a + + +fromParse (ParseOk m) = m + + diff --git a/src/Literate/SimpleInfo.hs b/src/Literate/SimpleInfo.hs new file mode 100644 --- /dev/null +++ b/src/Literate/SimpleInfo.hs @@ -0,0 +1,24 @@ +module Literate.SimpleInfo where + +data SimpleInfo = SimpleInfo { + fileName :: String, + moduleName :: String, + types :: [String], + constructors :: [String], + functions :: [String], + operators :: [String], + literalNumbers :: [String], + literalChars :: [Char], + literalStrings :: [String] +} deriving Show + +simpleinfo = SimpleInfo{ fileName = "" + , moduleName = "" + , types = [] + , constructors = [] + , functions = [] + , operators = [] + , literalNumbers = [] + , literalChars = [] + , literalStrings = [] + } diff --git a/src/LiterateHighlighter.hs b/src/LiterateHighlighter.hs new file mode 100644 --- /dev/null +++ b/src/LiterateHighlighter.hs @@ -0,0 +1,55 @@ +module Main where + +import Data.List + +import System( getArgs ) +import System.IO + + +import Language.Haskell.Exts + +----------------------------- + +import Base.CLI +import System.Console.CmdArgs + +import Literate.Agda +import Literate.Haskell +import Literate.SimpleInfo + +----------------------------- + + +main = do args <- cmdArgsRun standard + + hSetEncoding stdin utf8 + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + + hOutput <- openFile (output args) WriteMode + hSetEncoding hOutput utf8 + + let writer = writeOutput hOutput + + if (agda_mode args) + then + mapM_ (\file -> runAgda file + >>= (flip writer) Literate.Agda.mapping) + (input args) + else + mapM_ (\file -> runHaskell file + >>= (flip writer) Literate.Haskell.mapping) + (input args) + + hClose hOutput + 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) + (filter lhs2TeXSafe (f si)) + ) + mapping + +lhs2TeXSafe :: (String, String) -> Bool +lhs2TeXSafe ("()" , _) = False +lhs2TeXSafe _ = True +