← Back to branch summary

~ubuntu-branches/ubuntu/lucid/highlighting-kate/lucid

« back to all changes in this revision

Viewing changes to ParseSyntaxFiles.hs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2009-07-29 02:56:50 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20090729025650-wfbvr5xduppcpnfx
Tags: 0.2.5-2
Copy a rule from hlibrary.mk to cater for the non-standard documentation
package name

Show diffs side-by-side

added added

removed removed

Lines of Context:
ParseSyntaxFiles.hs
1
 
{-# OPTIONS -farrows #-}
 
1
{-# LANGUAGE Arrows #-}
2
2
 
3
3
{- 
4
4
ParseSyntaxFiles.hs processes a directory containing Kate
22
22
 
23
23
import Text.XML.HXT.Arrow
24
24
import Text.XML.HXT.Arrow.Edit
25
 
import Text.XML.HXT.Arrow.XmlNodeSet
26
25
import Control.Arrow
27
26
import Control.Arrow.ArrowList
28
27
import Data.List
36
35
import System.FilePath
37
36
import Text.PrettyPrint
38
37
import Text.Highlighting.Kate.Definitions
39
 
import Text.Highlighting.Kate.Common (capitalize)
40
38
 
41
39
data SyntaxDefinition =
42
40
  SyntaxDefinition { synLanguage      :: String
83
81
               } deriving (Read, Show)
84
82
 
85
83
 
 
84
-- | Converts a list of files (ending in .xml) and directories containing .xml files
 
85
-- into a list of .xml files.
 
86
argFiles :: [String] -> IO [String]
 
87
argFiles [] = error "Specify paths of xml files and/or directories containing xml syntax files."
 
88
argFiles args = do
 
89
  let isXmlFile x = isSuffixOf ".xml" x
 
90
  let (files, dirs) = partition isXmlFile args
 
91
  dirContents <- mapM (\dir -> getDirectoryContents dir >>= return . map (combine dir) . filter isXmlFile) dirs
 
92
  return $ nub (files ++ concat dirContents)
 
93
 
 
94
 
86
95
libraryPath = joinPath ["Text", "Highlighting", "Kate"]
87
96
destDir = joinPath [libraryPath, "Syntax"]
88
97
 
89
98
main :: IO ()
90
99
main = do
91
 
  argv <- getArgs
92
 
  srcDir <- if null argv 
93
 
               then error "Specify path of directory containing xml syntax files."
94
 
               else return $ argv !! 0
95
 
  let isXmlFile x = isSuffixOf ".xml" x
96
 
  files <- getDirectoryContents srcDir >>= (return . map (combine srcDir) . filter isXmlFile)
 
100
  files <- getArgs >>= argFiles
97
101
  destDirExists <- doesDirectoryExist destDir
98
102
  if destDirExists
99
103
     then return ()
100
104
     else createDirectory destDir 
101
 
  mapM processOneFile files >> return ()
 
105
  mapM_ processOneFile files
102
106
  let syntaxFile = combine libraryPath (addExtension "Syntax" "hs")
103
107
  putStrLn $ "Writing " ++ syntaxFile
104
 
  let names = sort $ map nameFromPath files 
 
108
  -- Get all syntax files, not only the newly generated ones.
 
109
  names <- getDirectoryContents destDir >>= return . sort . map dropExtension . filter (isSuffixOf ".hs")
105
110
  let imports = unlines $ map (\name -> "import qualified Text.Highlighting.Kate.Syntax." ++ name ++ " as " ++ name) names 
106
111
  let cases = unlines $ map (\name -> "        " ++ show (map toLower name) ++ " -> " ++ name ++ ".highlight") names
107
112
  let languageExtensions = concat $ intersperse ", " $ map (\name -> "(" ++ show name ++ ", " ++ name ++ ".syntaxExtensions)") names
134
139
           \            -> String                        -- ^ Source code to highlight\n\
135
140
           \            -> Either String [SourceLine]    -- ^ Either error message or result\n\
136
141
           \highlightAs lang =\n\
137
 
           \  case (map toLower lang) of\n" ++
 
142
           \  let lang'  = map toLower lang\n\
 
143
           \      lang'' = if lang' `elem` map (map toLower) languages\n\
 
144
           \                  then lang'\n\
 
145
           \                  else case languagesByExtension lang' of\n\
 
146
           \                            [l]  -> map toLower l  -- go by extension if unambiguous\n\
 
147
           \                            _    -> lang'\n\
 
148
           \  in  case lang'' of\n" ++
138
149
           cases ++
139
 
           "        _ -> (\\_ -> Left (\"Unknown language ++ \" ++ lang))\n"
 
150
           "        _ -> (\\_ -> Left (\"Unknown language: \" ++ lang))\n"
140
151
 
141
152
processOneFile :: FilePath -> IO ()
142
153
processOneFile src = do
238
249
                                      endLineParser, withAttr, styles, parseExpressionInternal, 
239
250
                                      defaultAttributes {- , lineBeginContexts -}] ++ contexts ++ [contextCatchAll]
240
251
 
241
 
mkIdentifier :: String -> String
242
 
mkIdentifier "" = ""
243
 
mkIdentifier ('-':x:xs) = toUpper x : mkIdentifier xs
244
 
mkIdentifier ('-':xs) = mkIdentifier xs
245
 
mkIdentifier (x:xs) = x : mkIdentifier xs
246
 
 
247
252
mkAlternatives :: [Doc] -> Doc
248
253
mkAlternatives docs = 
249
254
  let contents = vcat $ intersperse (text "<|>") docs
338
343
    "JavaScript" -> "Javascript"
339
344
    x -> x
340
345
 
 
346
capitalize :: String -> String
 
347
capitalize (x:xs) = toUpper x : xs
 
348
capitalize [] = []
 
349
 
341
350
nameFromPath :: FilePath -> String
342
351
nameFromPath = concat . map capitalize . words . 
343
352
               (map (\c -> if c == '-' then ' ' else c)) . takeFileName .