diff --git a/README.asciidoc b/README.asciidoc --- a/README.asciidoc +++ b/README.asciidoc @@ -85,18 +85,33 @@ * If a identifier names in a sequence of digits, the digits will be typeset in subscript. -* If you have trailing underscores they will be omitted in the typesetting. - This is so you can do something like: - - ----- - data Foo = Foo_ a; - ----- - +* If you have trailing underscores they will be omitted in the typesetting. This + is so you can do something like in <>. And have Foo highlighted as a type constructor, and Foo_ highlighted as `Foo' in a data constructor colour. -* If there are underscores in the middle of your identifier, everything - after the underscores will be typeset in subscript. +* If there are underscores in the middle of your identifier, everything after + the underscores will be typeset in subscript as in + <>. + +.Automatic removal of trailing underscores +[[Automatic_underscore_removal]] +[source,haskell] +----- +data Foo = Foo_ a; +----- + +.Automatic subscript generation +[[Automatic_subscript_generation]] +[source,haskell] +---- +foo_1 = undefined +-- Get's transformed into +foo₁ = undefined +---- + + THEMES ------ 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.3.3 +Version: 0.1.4.0 Cabal-Version: >= 1.6 License: MIT Author: Alessandro Vermeulen diff --git a/src/Base/CLI.hs b/src/Base/CLI.hs --- a/src/Base/CLI.hs +++ b/src/Base/CLI.hs @@ -1,12 +1,19 @@ {-# LANGUAGE DeriveDataTypeable #-} -module Base.CLI (ProgramOptions(..), usage, standard, module System.Console.CmdArgs) where +module Base.CLI (ProgramOptions(..), Action(..), usage, newCommands, standard, module System.Console.CmdArgs) where import System.Console.CmdArgs import Base.Common +data Action = Format | ListCommands + deriving (Show, Typeable, Data) + +instance Default Action where + def = Format + data ProgramOptions = ProgramOptions { agda_mode :: Bool + , action :: Action , input :: [FilePath] , output :: FilePath } deriving (Show, Data, Typeable) @@ -20,16 +27,29 @@ , " https://github.com/spockz/lhs2texhl" , "Copyright 2010, Alessandro Vermeulen " ] - +newCommands :: String +newCommands = unlines [ + "\\newcommand{\\lhsCHfunction}[1]{\\color{infixoperator}{{#1}}}", + "\\newcommand{\\lhsCHinfixoperator}[1]{\\color{infixoperator}{{#1}}}", + "\\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}}}", + "\\newcommand{\\lhsCHconstant}[1]{\\color{prelude}{{#1}}}" + ] -- | Standard command line options. -- standard = cmdArgsMode $ ProgramOptions { - agda_mode = def &= help "Run in agda-mode!" - , output = (def &= help "Output file") &= typFile - , input = (def &= args ) + agda_mode = def &= help "Run in agda-mode!" + , action = (def &= help "What should the program do? Format|ListCommands.") &= typ "Action" + , output = (def &= help "Output file") &= typFile + , input = (def &= args ) } &= summary usage 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.3.2" +programVersion = "0.1.4.0" programName = "lhs2TeX-hl" diff --git a/src/Literate/Haskell.hs b/src/Literate/Haskell.hs --- a/src/Literate/Haskell.hs +++ b/src/Literate/Haskell.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NamedFieldPuns #-} -module Literate.Haskell (runHaskell, mapping, listClasses, fromParse) where +{-# LANGUAGE RankNTypes #-} +module Literate.Haskell (runHaskell, mapping, fromParse) where import Data.List (nub) import Data.Maybe @@ -14,6 +15,13 @@ newtype M = M Module deriving (Typeable, Data) +type ItemQuery a = a -> [Item] + +newtype ConstructorSearch = ConstructorSearch Module deriving (Typeable, Show) +newtype FunctionSearch = FunctionSearch Module deriving (Typeable, Show) +newtype OperatorSearch = OperatorSearch Module deriving (Typeable, Show) +newtype ClassSearch = ClassSearch Module deriving (Typeable, Show) + parseFile fp = parseFileWithMode (defaultParseMode { fixities = Just baseFixities , parseFilename = fp } @@ -28,97 +36,108 @@ "Parsing failed at `" ++ show loc ++ " " ++ err + +collect :: Module -> [Item] +collect = nub . everything (++) ([] `mkQ` searchTypes + `extQ` searchConDecl + `extQ` searchPat + `extQ` searchExp + `extQ` searchMat + `extQ` searchDecl + `extQ` searchDeriving + `extQ` searchAsst) + + {- 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 _ = [] - -- getType :: Decl -> [QName] - -- getType (DataDecl _ _ _ _ decl _ _) = let f (Ident n) = [n] - -- f _ = [] - -- in f decl - -- - -- getType _ = [] +searchTypes :: ItemQuery Type +searchTypes (TyCon n) = [Type (prettyPrint n)] +searchTypes _ = [] -listConstructors :: Module -> [String] -listConstructors = nub . everything (++) ([] `mkQ` listConstructor - `extQ` listConstructorPat - `extQ` listConstructorUse) - where listConstructor :: ConDecl -> [String] - listConstructor (ConDecl (i) _) = [prettyPrint i] - listConstructor (InfixConDecl _ i _) = [prettyPrint i] - listConstructor (RecDecl i _) = [prettyPrint i] - listConstructorPat :: Pat -> [String] - listConstructorPat (PApp i _) = [prettyPrint i] - listConstructorPat _ = [] - listConstructorUse :: Exp -> [String] - listConstructorUse (Con i) = [prettyPrint i] - listConstructorUse _ = [] +searchConDecl :: ItemQuery ConDecl +searchConDecl (ConDecl (i) _) = [Constructor $ prettyPrint i] +searchConDecl (InfixConDecl _ i _) = [Constructor $ prettyPrint i] +searchConDecl (RecDecl i _) = [Constructor $ prettyPrint i] -listFunctions :: Module -> [String] -listFunctions = nub . everything (++) ([] `mkQ` functionBinding - `extQ` functionUse - `extQ` functionTypeSig) - where functionBinding :: Match -> [String] - functionBinding (Match _ (i) _ _ _ _) = [prettyPrint i] - functionUse :: Exp -> [String] - functionUse (App (Var qname) _) = [prettyPrint qname] - functionUse _ = [] - functionTypeSig :: Decl -> [String] - functionTypeSig (TypeSig _ names t) = case t of - TyParen (TyFun _ _) -> map nameToString names - TyFun _ _ -> map nameToString names - _ -> [] - functionTypeSig _ = [] - nameToString :: Name -> String - nameToString (Ident s) = s - nameToString (Symbol s) = s +searchPat :: ItemQuery Pat +searchPat (PApp i _) = [Constructor $ prettyPrint i] +searchPat _ = [] + +searchExp :: ItemQuery Exp +searchExp (Con i) = [Constructor $ prettyPrint i] +searchExp (App (Var qname) _) = [Function $ prettyPrint qname] +searchExp (InfixApp _ qop _) = [Operator $ prettyPrint qop] +searchExp _ = [] + +searchMat :: ItemQuery Match +searchMat (Match _ (i) _ _ _ _) = [Function $ prettyPrint i] + +searchDecl :: ItemQuery Decl +searchDecl (TypeSig _ names t) = case t of + TyParen (TyFun _ _) -> namesToFunction names + TyFun _ _ -> namesToFunction names + TyForall _ _ t -> case t of + TyParen (TyFun _ _) -> namesToFunction names + TyFun _ _ -> namesToFunction names + _ -> namesToConstant names + _ -> namesToConstant names + where nameToString :: (String -> Item) -> Name -> Item + nameToString f (Ident s) = f s + nameToString f (Symbol s) = f s + namesToFunction = map (nameToString Function) + namesToConstant = map (nameToString Constant) + + + + + +searchDecl (ClassDecl _ _ name _ _ _) = [Class $ prettyPrint name] +searchDecl _ = [] + -listOperators :: Module -> [String] -listOperators = nub . everything (++) ([] `mkQ` operatorUse) - where operatorUse :: Exp -> [String] - operatorUse (InfixApp _ qop _) = [prettyPrint qop] - operatorUse _ = [] -listClasses :: Module -> [String] -listClasses = nub . everything (++) ([] `mkQ` listClassDeriving - `extQ` listClassDecl - `extQ` listClassContext) - where listClassDeriving :: Deriving -> [String] - listClassDeriving (name , _) = [prettyPrint name] - listClassDecl :: Decl -> [String] - listClassDecl (ClassDecl _ _ name _ _ _) = [prettyPrint name] - listClassDecl _ = [] - listClassContext :: Asst -> [String] - listClassContext (ClassA name _) = [prettyPrint name] - listClassContext _ = [] +searchDeriving :: ItemQuery Deriving +searchDeriving (name , _) = [Class $ prettyPrint name] -getSimpleInfo m = simpleinfo{ types = listTypes m - , constructors = listConstructors m - , functions = listFunctions m - , operators = listOperators m - , classes = listClasses m +searchAsst :: ItemQuery Asst +searchAsst (ClassA name _) = [Class $ prettyPrint name] +searchAsst _ = [] + + +getSimpleInfo m = simpleinfo{ types = f isT + , constructors = f isCo + , functions = f isF + , operators = f isO + , classes = f isCl + , constants = f isConst } + where f p = map show (filter p collection) + isT (Type _) = True + isT _ = False + isCo (Constructor _) = True + isCo _ = False + isF (Function _) = True + isF _ = False + isO (Operator _) = True + isO _ = False + isCl (Class _) = True + isCl _ = False + isConst (Constant _) = True + isConst _ = False + collection = collect m mapping :: [(String, SimpleInfo -> [(String,String)])] -mapping = [ ("syntax", syntax) - , ("keyword", keywords) - , ("prelude", prelude) - -- , ("applicative", applicative ) - , ("type", mtypes) +mapping = [ + ("type", mtypes) , ("constructor", mconstructors) , ("function", mfunctions) , ("infixoperator", moperators) , ("class", mclasses) + , ("constant", mconstants) ] mtypes :: SimpleInfo -> [(String, String)] @@ -128,55 +147,9 @@ mconstructors SimpleInfo{constructors} = map (dp) constructors mfunctions SimpleInfo{functions } = map (dp) functions mclasses SimpleInfo{classes} = map (dp) classes - -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", "$"] +mconstants SimpleInfo{constants} = map (dp) constants -applicative _ = [] fooz = [4, 13, 42] douz = [4.0, 13.0, 42.0] diff --git a/src/Literate/SimpleInfo.hs b/src/Literate/SimpleInfo.hs --- a/src/Literate/SimpleInfo.hs +++ b/src/Literate/SimpleInfo.hs @@ -7,8 +7,8 @@ constructors :: [String], functions :: [String], operators :: [String], - classes :: [String] - + classes :: [String], + constants :: [String] } deriving Show @@ -19,4 +19,6 @@ , functions = [] , operators = [] , classes = [] + , constants = [] } + diff --git a/src/LiterateHighlighter.hs b/src/LiterateHighlighter.hs --- a/src/LiterateHighlighter.hs +++ b/src/LiterateHighlighter.hs @@ -28,29 +28,28 @@ hSetEncoding stdout utf8 hSetEncoding stderr utf8 - hOutput <- openFile (output args) WriteMode - hSetEncoding hOutput utf8 + case (action args) of + ListCommands -> putStr newCommands + _ -> if (agda_mode args) + then + error "Agda mode is currently not supported." + else + printFormatting args - let writer = writeOutput hOutput - - if (agda_mode args) - then - error "Agda mode is currently not supported." - -- 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 + 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) + hClose hOutput + lhs2TeXSafe :: (String, String) -> Bool lhs2TeXSafe ("()" , _) = False