packages feed

haskell-tools-cli 0.4.1.0 → 0.4.1.1

raw patch · 45 files changed

+1915/−16 lines, 45 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

Language/Haskell/Tools/Refactor/CLI.hs view
@@ -53,24 +53,29 @@      workingDirsAndHtFlags <- lift $ useFlags args
      let (htFlags, workingDirs) = partition (\f -> head f == '-') workingDirsAndHtFlags
      if null workingDirs then liftIO $ hPutStrLn output usageMessage
-                         else do initializeSession output workingDirs htFlags
-                                 runSession input output htFlags
+                         else do doRun <- initializeSession output workingDirs htFlags
+                                 when doRun $ runSession input output htFlags
      
   where printSrcErrors err = do dfs <- getSessionDynFlags 
                                 liftIO $ printBagOfErrors dfs (srcErrorMessages err)
 
-        initializeSession :: Handle -> [FilePath] -> [String] -> CLIRefactorSession ()
+        initializeSession :: Handle -> [FilePath] -> [String] -> CLIRefactorSession Bool
         initializeSession output workingDirs flags = do
           liftIO $ hSetBuffering output NoBuffering
           liftIO $ hPutStrLn output "Compiling modules. This may take some time. Please wait."
-          (_, ignoredMods) <- loadPackagesFrom (\ms -> liftIO $ hPutStrLn output ("Loaded module: " ++ modSumName ms)) workingDirs
-          when (not $ null ignoredMods) 
-            $ liftIO $ hPutStrLn output 
-            $ "The following modules are ignored: " 
-                ++ concat (intersperse ", " $ ignoredMods)
-                ++ ". Multiple modules with the same qualified name are not supported."
-          liftIO $ hPutStrLn output "All modules loaded. Use 'SelectModule module-name' to select a module"
-          when ("-dry-run" `elem` flags) $ modify (dryMode .= True)
+          res <- loadPackagesFrom (\ms -> liftIO $ hPutStrLn output ("Loaded module: " ++ modSumName ms)) workingDirs
+          case res of 
+            Right (_, ignoredMods) -> do
+              when (not $ null ignoredMods) 
+                $ liftIO $ hPutStrLn output 
+                $ "The following modules are ignored: " 
+                    ++ concat (intersperse ", " $ ignoredMods)
+                    ++ ". Multiple modules with the same qualified name are not supported."
+              liftIO $ hPutStrLn output "All modules loaded. Use 'SelectModule module-name' to select a module"
+              when ("-dry-run" `elem` flags) $ modify (dryMode .= True)
+              return True
+            Left err -> liftIO $ do hPutStrLn output err
+                                    return False
 
         runSession :: Handle -> Handle -> [String] -> CLIRefactorSession ()
         runSession _ output flags | "-one-shot" `elem` flags
@@ -81,7 +86,7 @@                     do performSessionCommand output (LoadModule modName)
                        command <- readSessionCommand output (takeWhile (/='"') $ dropWhile (=='"') $ refactoring)
                        performSessionCommand output command
-                  _ -> liftIO $ hPutStrLn output usageMessage
+                  _ -> liftIO $ hPutStrLn output "-module-name or -refactoring flag not specified correctly. Not doing any refactoring."
         runSession input output _ = runSessionLoop input output
 
         runSessionLoop :: Handle -> Handle -> CLIRefactorSession ()
+ bench-tests/empty.txt view
@@ -0,0 +1,1 @@+Exit
+ bench-tests/full-1.txt view
@@ -0,0 +1,10 @@+SelectModule Language.Preprocessor.Cpphs.CppIfdef
+ExtractBinding 182:8-182:36 parseResult
+RenameDefinition 181:1 gDefined
+GenerateSignature 51:5-51:5
+GenerateSignature 50:5-50:5
+GenerateSignature 49:5-49:5
+ExtractBinding 47:46-47:64 linesFixed
+RenameDefinition 46:1 cppIfDef
+OrganizeImports
+Exit
+ bench-tests/full-2.txt view
@@ -0,0 +1,5 @@+SelectModule Language.Preprocessor.Cpphs.MacroPass
+ExtractBinding 96:29-96:47 tokenizeTT
+ExtractBinding 90:11-90:67 fun
+OrganizeImports
+Exit
+ bench-tests/full-3.txt view
@@ -0,0 +1,16 @@+SelectModule Language.Preprocessor.Cpphs.CppIfdef
+ExtractBinding 182:8-182:36 parseResult
+RenameDefinition 181:1 gDefined
+SelectModule Language.Preprocessor.Cpphs.MacroPass
+ExtractBinding 96:29-96:47 tokenizeTT
+SelectModule Language.Preprocessor.Cpphs.CppIfdef
+GenerateSignature 51:5-51:5
+GenerateSignature 50:5-50:5
+GenerateSignature 49:5-49:5
+SelectModule Language.Preprocessor.Cpphs.MacroPass
+ExtractBinding 90:11-90:67 fun
+SelectModule Language.Preprocessor.Cpphs.CppIfdef
+ExtractBinding 47:46-47:64 linesFixed
+RenameDefinition 46:1 cppIfDef
+OrganizeImports
+Exit
+ bench-tests/selects.txt view
@@ -0,0 +1,10 @@+SelectModule Language.Preprocessor.Cpphs.CppIfdef
+SelectModule Language.Preprocessor.Cpphs.MacroPass
+SelectModule Language.Preprocessor.Cpphs.CppIfdef
+SelectModule Language.Preprocessor.Cpphs.MacroPass
+SelectModule Language.Preprocessor.Cpphs.CppIfdef
+SelectModule Language.Preprocessor.Cpphs.MacroPass
+SelectModule Language.Preprocessor.Cpphs.CppIfdef
+SelectModule Language.Preprocessor.Cpphs.MacroPass
+SelectModule Language.Preprocessor.Cpphs.CppIfdef
+Exit
+ bench-tests/three-gen-sigs.txt view
@@ -0,0 +1,5 @@+SelectModule Language.Preprocessor.Cpphs.CppIfdef
+GenerateSignature 51:5-51:5
+GenerateSignature 50:5-50:5
+GenerateSignature 49:5-49:5
+Exit
benchmark/Main.hs view
@@ -28,7 +28,7 @@ 
 import Language.Haskell.Tools.Refactor.CLI
 
-rootDir = ".." </> ".." </> "examples"
+rootDir = "examples"
 
 main :: IO ()
 main = do
+ examples/CppHs/Language/Preprocessor/Cpphs.hs view
@@ -0,0 +1,34 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Language.Preprocessor.Cpphs
+-- Copyright   :  2000-2006 Malcolm Wallace
+-- Licence     :  LGPL
+--
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  experimental
+-- Portability :  All
+--
+-- Include the interface that is exported
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs
+  ( runCpphs, runCpphsPass1, runCpphsPass2, runCpphsReturningSymTab
+  , cppIfdef, tokenise, WordStyle(..)
+  , macroPass, macroPassReturningSymTab
+  , CpphsOptions(..), BoolOptions(..)
+  , parseOptions, defaultCpphsOptions, defaultBoolOptions
+  , module Language.Preprocessor.Cpphs.Position
+  ) where
+
+import Language.Preprocessor.Cpphs.CppIfdef(cppIfdef)
+import Language.Preprocessor.Cpphs.MacroPass(macroPass
+                                            ,macroPassReturningSymTab)
+import Language.Preprocessor.Cpphs.RunCpphs(runCpphs
+                                           ,runCpphsPass1
+                                           ,runCpphsPass2
+                                           ,runCpphsReturningSymTab)
+import Language.Preprocessor.Cpphs.Options
+       (CpphsOptions(..), BoolOptions(..), parseOptions
+       ,defaultCpphsOptions,defaultBoolOptions)
+import Language.Preprocessor.Cpphs.Position
+import Language.Preprocessor.Cpphs.Tokenise
+ examples/CppHs/Language/Preprocessor/Cpphs/CppIfdef.hs view
@@ -0,0 +1,416 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  CppIfdef
+-- Copyright   :  1999-2004 Malcolm Wallace
+-- Licence     :  LGPL
+-- 
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  experimental
+-- Portability :  All
+
+-- Perform a cpp.first-pass, gathering \#define's and evaluating \#ifdef's.
+-- and \#include's.
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.CppIfdef
+  ( cppIfdef    -- :: FilePath -> [(String,String)] -> [String] -> Options
+                --      -> String -> IO [(Posn,String)]
+  ) where
+
+
+import Text.Parse
+import Language.Preprocessor.Cpphs.SymTab
+import Language.Preprocessor.Cpphs.Position  (Posn,newfile,newline,newlines
+                                             ,cppline,cpp2hask,newpos)
+import Language.Preprocessor.Cpphs.ReadFirst (readFirst)
+import Language.Preprocessor.Cpphs.Tokenise  (linesCpp,reslash)
+import Language.Preprocessor.Cpphs.Options   (BoolOptions(..))
+import Language.Preprocessor.Cpphs.HashDefine(HashDefine(..),parseHashDefine
+                                             ,expandMacro)
+import Language.Preprocessor.Cpphs.MacroPass (preDefine,defineMacro)
+import Data.Char        (isDigit,isSpace,isAlphaNum)
+import Data.List        (intercalate,isPrefixOf)
+import Numeric          (readHex,readOct,readDec)
+import System.IO.Unsafe (unsafeInterleaveIO)
+import System.IO        (hPutStrLn,stderr)
+import Control.Monad    (when)
+
+-- | Run a first pass of cpp, evaluating \#ifdef's and processing \#include's,
+--   whilst taking account of \#define's and \#undef's as we encounter them.
+cppIfdef :: FilePath            -- ^ File for error reports
+        -> [(String,String)]    -- ^ Pre-defined symbols and their values
+        -> [String]             -- ^ Search path for \#includes
+        -> BoolOptions          -- ^ Options controlling output style
+        -> String               -- ^ The input file content
+        -> IO [(Posn,String)]   -- ^ The file after processing (in lines)
+cppIfdef fp syms search options =
+    cpp posn defs search options (Keep []) . initial . linesCpp
+  where
+    posn = newfile fp
+    defs = preDefine options syms
+    initial = if literate options then id else (cppline posn:)
+-- Previous versions had a very simple symbol table  mapping strings
+-- to strings.  Now the #ifdef pass uses a more elaborate table, in
+-- particular to deal with parameterised macros in conditionals.
+
+
+-- | Internal state for whether lines are being kept or dropped.
+--   In @Drop n b ps@, @n@ is the depth of nesting, @b@ is whether
+--   we have already succeeded in keeping some lines in a chain of
+--   @elif@'s, and @ps@ is the stack of positions of open @#if@ contexts,
+--   used for error messages in case EOF is reached too soon.
+data KeepState = Keep [Posn] | Drop Int Bool [Posn]
+
+-- | Return just the list of lines that the real cpp would decide to keep.
+cpp :: Posn -> SymTab HashDefine -> [String] -> BoolOptions -> KeepState
+       -> [String] -> IO [(Posn,String)]
+
+cpp _ _ _ _ (Keep ps) [] | not (null ps) = do
+    hPutStrLn stderr $ "Unmatched #if: positions of open context are:\n"++
+                       unlines (map show ps)
+    return []
+cpp _ _ _ _ _ [] = return []
+
+cpp p syms path options (Keep ps) (l@('#':x):xs) =
+    let ws = words x
+        cmd = if null ws then "" else head ws
+        line = tail ws
+        sym  = head (tail ws)
+        rest = tail (tail ws)
+        def = defineMacro options (sym++" "++ maybe "1" id (un rest))
+        un v = if null v then Nothing else Just (unwords v)
+        keepIf b = if b then Keep (p:ps) else Drop 1 False (p:ps)
+        skipn syms' retain ud xs' =
+            let n = 1 + length (filter (=='\n') l) in
+            (if macros options && retain then emitOne  (p,reslash l)
+                                         else emitMany (replicate n (p,""))) $
+            cpp (newlines n p) syms' path options ud xs'
+    in case cmd of
+        "define" -> skipn (insertST def syms) True (Keep ps) xs
+        "undef"  -> skipn (deleteST sym syms) True (Keep ps) xs
+        "ifndef" -> skipn syms False (keepIf (not (definedST sym syms))) xs
+        "ifdef"  -> skipn syms False (keepIf      (definedST sym syms)) xs
+        "if"     -> do b <- gatherDefined p syms (unwords line)
+                       skipn syms False (keepIf b) xs
+        "else"   -> skipn syms False (Drop 1 False ps) xs
+        "elif"   -> skipn syms False (Drop 1 True ps) xs
+        "endif"  | null ps ->
+                    do hPutStrLn stderr $ "Unmatched #endif at "++show p
+                       return []
+        "endif"  -> skipn syms False (Keep (tail ps)) xs
+        "pragma" -> skipn syms True  (Keep ps) xs
+        ('!':_)  -> skipn syms False (Keep ps) xs       -- \#!runhs scripts
+        "include"-> do (inc,content) <- readFirst (file syms (unwords line))
+                                                  p path
+                                                  (warnings options)
+                       cpp p syms path options (Keep ps)
+                             (("#line 1 "++show inc): linesCpp content
+                                                    ++ cppline (newline p): xs)
+        "warning"-> if warnings options then
+                      do hPutStrLn stderr (l++"\nin "++show p)
+                         skipn syms False (Keep ps) xs
+                    else skipn syms False (Keep ps) xs
+        "error"  -> error (l++"\nin "++show p)
+        "line"   | all isDigit sym
+                 -> (if locations options && hashline options then emitOne (p,l)
+                     else if locations options then emitOne (p,cpp2hask l)
+                     else id) $
+                    cpp (newpos (read sym) (un rest) p)
+                        syms path options (Keep ps) xs
+        n | all isDigit n && not (null n)
+                 -> (if locations options && hashline options then emitOne (p,l)
+                     else if locations options then emitOne (p,cpp2hask l)
+                     else id) $
+                    cpp (newpos (read n) (un (tail ws)) p)
+                        syms path options (Keep ps) xs
+          | otherwise
+                 -> do when (warnings options) $
+                           hPutStrLn stderr ("Warning: unknown directive #"++n
+                                             ++"\nin "++show p)
+                       emitOne (p,l) $
+                               cpp (newline p) syms path options (Keep ps) xs
+
+cpp p syms path options (Drop n b ps) (('#':x):xs) =
+    let ws = words x
+        cmd = if null ws then "" else head ws
+        delse    | n==1 && b = Drop 1 b ps
+                 | n==1      = Keep ps
+                 | otherwise = Drop n b ps
+        dend     | n==1      = Keep (tail ps)
+                 | otherwise = Drop (n-1) b (tail ps)
+        delif v  | n==1 && not b && v
+                             = Keep ps
+                 | otherwise = Drop n b ps
+        skipn ud xs' =
+                 let n' = 1 + length (filter (=='\n') x) in
+                 emitMany (replicate n' (p,"")) $
+                    cpp (newlines n' p) syms path options ud xs'
+    in
+    if      cmd == "ifndef" ||
+            cmd == "if"     ||
+            cmd == "ifdef" then    skipn (Drop (n+1) b (p:ps)) xs
+    else if cmd == "elif"  then do v <- gatherDefined p syms (unwords (tail ws))
+                                   skipn (delif v) xs
+    else if cmd == "else"  then    skipn  delse xs
+    else if cmd == "endif" then
+            if null ps then do hPutStrLn stderr $ "Unmatched #endif at "++show p
+                               return []
+                       else skipn  dend  xs
+    else skipn (Drop n b ps) xs
+        -- define, undef, include, error, warning, pragma, line
+
+cpp p syms path options (Keep ps) (x:xs) =
+    let p' = newline p in seq p' $
+    emitOne (p,x)  $  cpp p' syms path options (Keep ps) xs
+cpp p syms path options d@(Drop _ _ _) (_:xs) =
+    let p' = newline p in seq p' $
+    emitOne (p,"") $  cpp p' syms path options d xs
+
+
+-- | Auxiliary IO functions
+emitOne  ::  a  -> IO [a] -> IO [a]
+emitMany :: [a] -> IO [a] -> IO [a]
+emitOne  x  io = do ys <- unsafeInterleaveIO io
+                    return (x:ys)
+emitMany xs io = do ys <- unsafeInterleaveIO io
+                    return (xs++ys)
+
+
+----
+gatherDefined :: Posn -> SymTab HashDefine -> String -> IO Bool
+gatherDefined p st inp =
+  case runParser (preExpand st) inp of
+    (Left msg, _) -> error ("Cannot expand #if directive in file "++show p
+                           ++":\n    "++msg)
+    (Right s, xs) -> do
+--      hPutStrLn stderr $ "Expanded #if at "++show p++" is:\n  "++s
+        when (any (not . isSpace) xs) $
+             hPutStrLn stderr ("Warning: trailing characters after #if"
+                              ++" macro expansion in file "++show p++": "++xs)
+
+        case runParser parseBoolExp s of
+          (Left msg, _) -> error ("Cannot parse #if directive in file "++show p
+                                 ++":\n    "++msg)
+          (Right b, xs) -> do when (any (not . isSpace) xs && notComment xs) $
+                                   hPutStrLn stderr
+                                     ("Warning: trailing characters after #if"
+                                      ++" directive in file "++show p++": "++xs)
+                              return b
+
+notComment = not . ("//"`isPrefixOf`) . dropWhile isSpace
+
+
+-- | The preprocessor must expand all macros (recursively) before evaluating
+--   the conditional.
+preExpand :: SymTab HashDefine -> TextParser String
+preExpand st =
+  do  eof
+      return ""
+  <|>
+  do  a <- many1 (satisfy notIdent)
+      commit $ pure (a++) `apply` preExpand st
+  <|>
+  do  b <- expandSymOrCall st
+      commit $ pure (b++) `apply` preExpand st
+
+-- | Expansion of symbols.
+expandSymOrCall :: SymTab HashDefine -> TextParser String
+expandSymOrCall st =
+  do sym <- parseSym
+     if sym=="defined" then do arg <- skip parseSym; convert sym [arg]
+                            <|>
+                            do arg <- skip $ parenthesis (do x <- skip parseSym;
+                                                             skip (return x))
+                               convert sym [arg]
+                            <|> convert sym []
+      else
+      ( do  args <- parenthesis (commit $ fragment `sepBy` skip (isWord ","))
+            args' <- flip mapM args $ \arg->
+                         case runParser (preExpand st) arg of
+                             (Left msg, _) -> fail msg
+                             (Right s, _)  -> return s
+            convert sym args'
+        <|> convert sym []
+      )
+  where
+    fragment = many1 (satisfy (`notElem`",)"))
+    convert "defined" [arg] =
+      case lookupST arg st of
+        Nothing | all isDigit arg    -> return arg 
+        Nothing                      -> return "0"
+        Just (a@AntiDefined{})       -> return "0"
+        Just (a@SymbolReplacement{}) -> return "1"
+        Just (a@MacroExpansion{})    -> return "1"
+    convert sym args =
+      case lookupST sym st of
+        Nothing  -> if null args then return sym
+                    else return "0"
+                 -- else fail (disp sym args++" is not a defined macro")
+        Just (a@SymbolReplacement{}) -> do reparse (replacement a)
+                                           return ""
+        Just (a@MacroExpansion{})    -> do reparse (expandMacro a args False)
+                                           return ""
+        Just (a@AntiDefined{})       ->
+                    if null args then return sym
+                    else return "0"
+                 -- else fail (disp sym args++" explicitly undefined with -U")
+    disp sym args = let len = length args
+                        chars = map (:[]) ['a'..'z']
+                    in sym ++ if null args then ""
+                              else "("++intercalate "," (take len chars)++")"
+
+parseBoolExp :: TextParser Bool
+parseBoolExp =
+  do  a <- parseExp1
+      bs <- many (do skip (isWord "||")
+                     commit $ skip parseBoolExp)
+      return $ foldr (||) a bs
+
+parseExp1 :: TextParser Bool
+parseExp1 =
+  do  a <- parseExp0
+      bs <- many (do skip (isWord "&&")
+                     commit $ skip parseExp1)
+      return $ foldr (&&) a bs
+
+parseExp0 :: TextParser Bool
+parseExp0 =
+  do  skip (isWord "!")
+      a <- commit $ parseExp0
+      return (not a)
+  <|>
+  do  val1 <- parseArithExp1
+      op   <- parseCmpOp
+      val2 <- parseArithExp1
+      return (val1 `op` val2)
+  <|>
+  do  sym <- parseArithExp1
+      case sym of
+        0 -> return False
+        _ -> return True
+  <|>
+  do  parenthesis (commit parseBoolExp)
+
+parseArithExp1 :: TextParser Integer
+parseArithExp1 =
+  do  val1 <- parseArithExp0
+      ( do op   <- parseArithOp1
+           val2 <- parseArithExp1
+           return (val1 `op` val2)
+        <|> return val1 )
+  <|>
+  do  parenthesis parseArithExp1
+
+parseArithExp0 :: TextParser Integer
+parseArithExp0 =
+  do  val1 <- parseNumber
+      ( do op   <- parseArithOp0
+           val2 <- parseArithExp0
+           return (val1 `op` val2)
+        <|> return val1 )
+  <|>
+  do  parenthesis parseArithExp0
+
+parseNumber :: TextParser Integer
+parseNumber = fmap safeRead $ skip parseSym
+  where
+    safeRead s =
+      case s of
+        '0':'x':s' -> number readHex s'
+        '0':'o':s' -> number readOct s'
+        _          -> number readDec s
+    number rd s =
+      case rd s of
+        []        -> 0 :: Integer
+        ((n,_):_) -> n :: Integer
+
+parseCmpOp :: TextParser (Integer -> Integer -> Bool)
+parseCmpOp =
+  do  skip (isWord ">=")
+      return (>=)
+  <|>
+  do  skip (isWord ">")
+      return (>)
+  <|>
+  do  skip (isWord "<=")
+      return (<=)
+  <|>
+  do  skip (isWord "<")
+      return (<)
+  <|>
+  do  skip (isWord "==")
+      return (==)
+  <|>
+  do  skip (isWord "!=")
+      return (/=)
+
+parseArithOp1 :: TextParser (Integer -> Integer -> Integer)
+parseArithOp1 =
+  do  skip (isWord "+")
+      return (+)
+  <|>
+  do  skip (isWord "-")
+      return (-)
+
+parseArithOp0 :: TextParser (Integer -> Integer -> Integer)
+parseArithOp0 =
+  do  skip (isWord "*")
+      return (*)
+  <|>
+  do  skip (isWord "/")
+      return (div)
+  <|>
+  do  skip (isWord "%")
+      return (rem)
+
+-- | Return the expansion of the symbol (if there is one).
+parseSymOrCall :: SymTab HashDefine -> TextParser String
+parseSymOrCall st =
+  do  sym <- skip parseSym
+      args <- parenthesis (commit $ parseSymOrCall st `sepBy` skip (isWord ","))
+      return $ convert sym args
+  <|>
+  do  sym <- skip parseSym
+      return $ convert sym []
+  where
+    convert sym args =
+      case lookupST sym st of
+        Nothing  -> sym
+        Just (a@SymbolReplacement{}) -> recursivelyExpand st (replacement a)
+        Just (a@MacroExpansion{})    -> recursivelyExpand st (expandMacro a args False)
+        Just (a@AntiDefined{})       -> name a
+
+recursivelyExpand :: SymTab HashDefine -> String -> String
+recursivelyExpand st inp =
+  case runParser (parseSymOrCall st) inp of
+    (Left msg, _) -> inp
+    (Right s,  _) -> s
+
+parseSym :: TextParser String
+parseSym = many1 (satisfy (\c-> isAlphaNum c || c`elem`"'`_"))
+           `onFail`
+           do xs <- allAsString
+              fail $ "Expected an identifier, got \""++xs++"\""
+
+notIdent :: Char -> Bool
+notIdent c = not (isAlphaNum c || c`elem`"'`_")
+
+skip :: TextParser a -> TextParser a
+skip p = many (satisfy isSpace) >> p
+
+-- | The standard "parens" parser does not work for us here.  Define our own.
+parenthesis :: TextParser a -> TextParser a
+parenthesis p = do isWord "("
+                   x <- p
+                   isWord ")"
+                   return x
+
+-- | Determine filename in \#include
+file :: SymTab HashDefine -> String -> String
+file st name =
+    case name of
+      ('"':ns) -> init ns
+      ('<':ns) -> init ns
+      _ -> let ex = recursivelyExpand st name in
+           if ex == name then name else file st ex
+
+ examples/CppHs/Language/Preprocessor/Cpphs/HashDefine.hs view
@@ -0,0 +1,129 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  HashDefine
+-- Copyright   :  2004 Malcolm Wallace
+-- Licence     :  LGPL
+--
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  experimental
+-- Portability :  All
+--
+-- What structures are declared in a \#define.
+-----------------------------------------------------------------------------
+ 
+module Language.Preprocessor.Cpphs.HashDefine
+  ( HashDefine(..)
+  , ArgOrText(..)
+  , expandMacro
+  , parseHashDefine
+  , simplifyHashDefines
+  ) where
+
+import Data.Char (isSpace)
+import Data.List (intercalate)
+
+data HashDefine
+        = LineDrop
+                { name :: String }
+        | Pragma
+                { name :: String }
+        | AntiDefined
+                { name          :: String
+                , linebreaks    :: Int
+                }
+        | SymbolReplacement
+                { name          :: String
+                , replacement   :: String
+                , linebreaks    :: Int
+                }
+        | MacroExpansion
+                { name          :: String
+                , arguments     :: [String]
+                , expansion     :: [(ArgOrText,String)]
+                , linebreaks    :: Int
+                }
+    deriving (Eq,Show)
+
+-- | 'smart' constructor to avoid warnings from ghc (undefined fields)
+symbolReplacement :: HashDefine
+symbolReplacement =
+    SymbolReplacement
+         { name=undefined, replacement=undefined, linebreaks=undefined }
+
+-- | Macro expansion text is divided into sections, each of which is classified
+--   as one of three kinds: a formal argument (Arg), plain text (Text),
+--   or a stringised formal argument (Str).
+data ArgOrText = Arg | Text | Str deriving (Eq,Show)
+
+-- | Expand an instance of a macro.
+--   Precondition: got a match on the macro name.
+expandMacro :: HashDefine -> [String] -> Bool -> String
+expandMacro macro parameters layout =
+    let env = zip (arguments macro) parameters
+        replace (Arg,s)  = maybe ("")      id (lookup s env)
+        replace (Str,s)  = maybe (str "") str (lookup s env)
+        replace (Text,s) = if layout then s else filter (/='\n') s
+        str s = '"':s++"\""
+        checkArity | length (arguments macro) == 1 && length parameters <= 1
+                   || length (arguments macro) == length parameters = id
+                   | otherwise = error ("macro "++name macro++" expected "++
+                                        show (length (arguments macro))++
+                                        " arguments, but was given "++
+                                        show (length parameters))
+    in
+    checkArity $ concatMap replace (expansion macro)
+
+-- | Parse a \#define, or \#undef, ignoring other \# directives
+parseHashDefine :: Bool -> [String] -> Maybe HashDefine
+parseHashDefine ansi def = (command . skip) def
+  where
+    skip xss@(x:xs) | all isSpace x = skip xs
+                    | otherwise     = xss
+    skip    []      = []
+    command ("line":xs)   = Just (LineDrop ("#line"++concat xs))
+    command ("pragma":xs) = Just (Pragma ("#pragma"++concat xs))
+    command ("define":xs) = Just (((define . skip) xs) { linebreaks=count def })
+    command ("undef":xs)  = Just (((undef  . skip) xs))
+    command _             = Nothing
+    undef  (sym:_)   = AntiDefined { name=sym, linebreaks=0 }
+    define (sym:xs)  = case {-skip-} xs of
+                           ("(":ys) -> (macroHead sym [] . skip) ys
+                           ys   -> symbolReplacement
+                                     { name=sym
+                                     , replacement = concatMap snd
+                                             (classifyRhs [] (chop (skip ys))) }
+    macroHead sym args (",":xs) = (macroHead sym args . skip) xs
+    macroHead sym args (")":xs) = MacroExpansion
+                                    { name =sym , arguments = reverse args
+                                    , expansion = classifyRhs args (skip xs)
+                                    , linebreaks = undefined }
+    macroHead sym args (var:xs) = (macroHead sym (var:args) . skip) xs
+    macroHead sym args []       = error ("incomplete macro definition:\n"
+                                        ++"  #define "++sym++"("
+                                        ++intercalate "," args)
+    classifyRhs args ("#":x:xs)
+                          | ansi &&
+                            x `elem` args    = (Str,x): classifyRhs args xs
+    classifyRhs args ("##":xs)
+                          | ansi             = classifyRhs args xs
+    classifyRhs args (s:"##":s':xs)
+                          | ansi && all isSpace s && all isSpace s'
+                                             = classifyRhs args xs
+    classifyRhs args (word:xs)
+                          | word `elem` args = (Arg,word): classifyRhs args xs
+                          | otherwise        = (Text,word): classifyRhs args xs
+    classifyRhs _    []                      = []
+    count = length . filter (=='\n') . concat
+    chop  = reverse . dropWhile (all isSpace) . reverse
+
+-- | Pretty-print hash defines to a simpler format, as key-value pairs.
+simplifyHashDefines :: [HashDefine] -> [(String,String)]
+simplifyHashDefines = concatMap simp
+  where
+    simp hd@LineDrop{}    = []
+    simp hd@Pragma{}      = []
+    simp hd@AntiDefined{} = []
+    simp hd@SymbolReplacement{} = [(name hd, replacement hd)]
+    simp hd@MacroExpansion{}    = [(name hd++"("++intercalate "," (arguments hd)
+                                           ++")"
+                                   ,concatMap snd (expansion hd))]
+ examples/CppHs/Language/Preprocessor/Cpphs/MacroPass.hs view
@@ -0,0 +1,184 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  MacroPass
+-- Copyright   :  2004 Malcolm Wallace
+-- Licence     :  LGPL
+--
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  experimental
+-- Portability :  All
+--
+-- Perform a cpp.second-pass, accumulating \#define's and \#undef's,
+-- whilst doing symbol replacement and macro expansion.
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.MacroPass
+  ( macroPass
+  , preDefine
+  , defineMacro
+  , macroPassReturningSymTab
+  ) where
+
+import Language.Preprocessor.Cpphs.HashDefine (HashDefine(..), expandMacro
+                                              , simplifyHashDefines)
+import Language.Preprocessor.Cpphs.Tokenise   (tokenise, WordStyle(..)
+                                              , parseMacroCall)
+import Language.Preprocessor.Cpphs.SymTab     (SymTab, lookupST, insertST
+                                              , emptyST, flattenST)
+import Language.Preprocessor.Cpphs.Position   (Posn, newfile, filename, lineno)
+import Language.Preprocessor.Cpphs.Options    (BoolOptions(..))
+import System.IO.Unsafe (unsafeInterleaveIO)
+import Control.Monad    ((=<<))
+import System.Time       (getClockTime, toCalendarTime, formatCalendarTime)
+import System.Locale     (defaultTimeLocale)
+
+noPos :: Posn
+noPos = newfile "preDefined"
+
+-- | Walk through the document, replacing calls of macros with the expanded RHS.
+macroPass :: [(String,String)]  -- ^ Pre-defined symbols and their values
+          -> BoolOptions        -- ^ Options that alter processing style
+          -> [(Posn,String)]    -- ^ The input file content
+          -> IO String          -- ^ The file after processing
+macroPass syms options =
+    fmap (safetail              -- to remove extra "\n" inserted below
+         . concat
+         . onlyRights)
+    . macroProcess (pragma options) (layout options) (lang options)
+                   (preDefine options syms)
+    . tokenise (stripEol options) (stripC89 options)
+               (ansi options) (lang options)
+    . ((noPos,""):)     -- ensure recognition of "\n#" at start of file
+  where
+    safetail [] = []
+    safetail (_:xs) = xs
+
+-- | auxiliary
+onlyRights :: [Either a b] -> [b]
+onlyRights = concatMap (\x->case x of Right t-> [t]; Left _-> [];)
+
+-- | Walk through the document, replacing calls of macros with the expanded RHS.
+--   Additionally returns the active symbol table after processing.
+macroPassReturningSymTab
+          :: [(String,String)]  -- ^ Pre-defined symbols and their values
+          -> BoolOptions        -- ^ Options that alter processing style
+          -> [(Posn,String)]    -- ^ The input file content
+          -> IO (String,[(String,String)])
+                                -- ^ The file and symbol table after processing
+macroPassReturningSymTab syms options =
+    fmap (mapFst (safetail              -- to remove extra "\n" inserted below
+                 . concat)
+         . walk)
+    . macroProcess (pragma options) (layout options) (lang options)
+                   (preDefine options syms)
+    . tokenise (stripEol options) (stripC89 options)
+               (ansi options) (lang options)
+    . ((noPos,""):)     -- ensure recognition of "\n#" at start of file
+  where
+    safetail [] = []
+    safetail (_:xs) = xs
+    walk (Right x: rest) = let (xs,   foo) = walk rest
+                           in  (x:xs, foo)
+    walk (Left  x: [])   =     ( [] , simplifyHashDefines (flattenST x) )
+    walk (Left  x: rest) = walk rest
+    mapFst f (a,b) = (f a, b)
+
+
+-- | Turn command-line definitions (from @-D@) into 'HashDefine's.
+preDefine :: BoolOptions -> [(String,String)] -> SymTab HashDefine
+preDefine options defines =
+    foldr (insertST . defineMacro options . (\ (s,d)-> s++" "++d))
+          emptyST defines
+
+-- | Turn a string representing a macro definition into a 'HashDefine'.
+defineMacro :: BoolOptions -> String -> (String,HashDefine)
+defineMacro opts s =
+    let (Cmd (Just hd):_) = tokenise True True (ansi opts) (lang opts)
+                                     [(noPos,"\n#define "++s++"\n")]
+    in (name hd, hd)
+
+
+-- | Trundle through the document, one word at a time, using the WordStyle
+--   classification introduced by 'tokenise' to decide whether to expand a
+--   word or macro.  Encountering a \#define or \#undef causes that symbol to
+--   be overwritten in the symbol table.  Any other remaining cpp directives
+--   are discarded and replaced with blanks, except for \#line markers.
+--   All valid identifiers are checked for the presence of a definition
+--   of that name in the symbol table, and if so, expanded appropriately.
+--   (Bool arguments are: keep pragmas?  retain layout?  haskell language?)
+--   The result lazily intersperses output text with symbol tables.  Lines
+--   are emitted as they are encountered.  A symbol table is emitted after
+--   each change to the defined symbols, and always at the end of processing.
+macroProcess :: Bool -> Bool -> Bool -> SymTab HashDefine -> [WordStyle]
+             -> IO [Either (SymTab HashDefine) String]
+macroProcess _ _ _ st        []          = return [Left st]
+macroProcess p y l st (Other x: ws)      = emit x    $ macroProcess p y l st ws
+macroProcess p y l st (Cmd Nothing: ws)  = emit "\n" $ macroProcess p y l st ws
+macroProcess p y l st (Cmd (Just (LineDrop x)): ws)
+                                         = emit "\n" $
+                                           emit x    $ macroProcess p y l st ws
+macroProcess pragma y l st (Cmd (Just (Pragma x)): ws)
+               | pragma    = emit "\n" $ emit x $ macroProcess pragma y l st ws
+               | otherwise = emit "\n" $          macroProcess pragma y l st ws
+macroProcess p layout lang st (Cmd (Just hd): ws) =
+    let n = 1 + linebreaks hd
+        newST = insertST (name hd, hd) st
+    in
+    emit (replicate n '\n') $
+    emitSymTab newST $
+    macroProcess p layout lang newST ws
+macroProcess pr layout lang st (Ident p x: ws) =
+    case x of
+      "__FILE__" -> emit (show (filename p))$ macroProcess pr layout lang st ws
+      "__LINE__" -> emit (show (lineno p))  $ macroProcess pr layout lang st ws
+      "__DATE__" -> do w <- return .
+                            formatCalendarTime defaultTimeLocale "\"%d %b %Y\""
+                            =<< toCalendarTime =<< getClockTime
+                       emit w $ macroProcess pr layout lang st ws
+      "__TIME__" -> do w <- return .
+                            formatCalendarTime defaultTimeLocale "\"%H:%M:%S\""
+                            =<< toCalendarTime =<< getClockTime
+                       emit w $ macroProcess pr layout lang st ws
+      _ ->
+        case lookupST x st of
+            Nothing -> emit x $ macroProcess pr layout lang st ws
+            Just hd ->
+                case hd of
+                    AntiDefined {name=n} -> emit n $
+                                            macroProcess pr layout lang st ws
+                    SymbolReplacement {replacement=r} ->
+                        let r' = if layout then r else filter (/='\n') r in
+                        -- one-level expansion only:
+                        -- emit r' $ macroProcess layout st ws
+                        -- multi-level expansion:
+                        macroProcess pr layout lang st
+                                     (tokenise True True False lang [(p,r')]
+                                      ++ ws)
+                    MacroExpansion {} ->
+                        case parseMacroCall p ws of
+                            Nothing -> emit x $
+                                       macroProcess pr layout lang st ws
+                            Just (args,ws') ->
+                                if length args /= length (arguments hd) then
+                                     emit x $ macroProcess pr layout lang st ws
+                                else do args' <- mapM (fmap (concat.onlyRights)
+                                                       . macroProcess pr layout
+                                                                        lang st)
+                                                      args
+                                        -- one-level expansion only:
+                                        -- emit (expandMacro hd args' layout) $
+                                        --         macroProcess layout st ws'
+                                        -- multi-level expansion:
+                                        macroProcess pr layout lang st
+                                            (tokenise True True False lang
+                                               [(p,expandMacro hd args' layout)]
+                                            ++ ws')
+
+-- | Useful helper function.
+emit :: a -> IO [Either b a] -> IO [Either b a]
+emit x io = do xs <- unsafeInterleaveIO io
+               return (Right x:xs)
+-- | Useful helper function.
+emitSymTab :: b -> IO [Either b a] -> IO [Either b a]
+emitSymTab x io = do xs <- unsafeInterleaveIO io
+                     return (Left x:xs)
+ examples/CppHs/Language/Preprocessor/Cpphs/Options.hs view
@@ -0,0 +1,156 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Options
+-- Copyright   :  2006 Malcolm Wallace
+-- Licence     :  LGPL
+--
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  experimental
+-- Portability :  All
+--
+-- This module deals with Cpphs options and parsing them
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.Options
+  ( CpphsOptions(..)
+  , BoolOptions(..)
+  , parseOptions
+  , defaultCpphsOptions
+  , defaultBoolOptions
+  , trailing
+  ) where
+
+import Data.Maybe
+import Data.List (isPrefixOf)
+
+-- | Cpphs options structure.
+data CpphsOptions = CpphsOptions 
+    { infiles   :: [FilePath]
+    , outfiles  :: [FilePath]
+    , defines   :: [(String,String)]
+    , includes  :: [String]
+    , preInclude:: [FilePath]   -- ^ Files to \#include before anything else
+    , boolopts  :: BoolOptions
+    } deriving (Show)
+
+-- | Default options.
+defaultCpphsOptions :: CpphsOptions
+defaultCpphsOptions = CpphsOptions { infiles = [], outfiles = []
+                                   , defines = [], includes = []
+                                   , preInclude = []
+                                   , boolopts = defaultBoolOptions }
+
+-- | Options representable as Booleans.
+data BoolOptions = BoolOptions
+    { macros    :: Bool  -- ^ Leave \#define and \#undef in output of ifdef?
+    , locations :: Bool  -- ^ Place \#line droppings in output?
+    , hashline  :: Bool  -- ^ Write \#line or {-\# LINE \#-} ?
+    , pragma    :: Bool  -- ^ Keep \#pragma in final output?
+    , stripEol  :: Bool  -- ^ Remove C eol (\/\/) comments everywhere?
+    , stripC89  :: Bool  -- ^ Remove C inline (\/**\/) comments everywhere?
+    , lang      :: Bool  -- ^ Lex input as Haskell code?
+    , ansi      :: Bool  -- ^ Permit stringise \# and catenate \#\# operators?
+    , layout    :: Bool  -- ^ Retain newlines in macro expansions?
+    , literate  :: Bool  -- ^ Remove literate markup?
+    , warnings  :: Bool  -- ^ Issue warnings?
+    } deriving (Show)
+
+-- | Default settings of boolean options.
+defaultBoolOptions :: BoolOptions
+defaultBoolOptions = BoolOptions { macros   = True,   locations = True
+                                 , hashline = True,   pragma    = False
+                                 , stripEol = False,  stripC89  = False
+                                 , lang     = True,   ansi      = False
+                                 , layout   = False,  literate  = False
+                                 , warnings = True }
+
+-- | Raw command-line options.  This is an internal intermediate data
+--   structure, used during option parsing only.
+data RawOption
+    = NoMacro
+    | NoLine
+    | LinePragma
+    | Pragma
+    | Text
+    | Strip
+    | StripEol
+    | Ansi
+    | Layout
+    | Unlit
+    | SuppressWarnings
+    | Macro (String,String)
+    | Path String
+    | PreInclude FilePath
+    | IgnoredForCompatibility
+      deriving (Eq, Show)
+
+flags :: [(String, RawOption)]
+flags = [ ("--nomacro", NoMacro)
+        , ("--noline",  NoLine)
+        , ("--linepragma", LinePragma)
+        , ("--pragma",  Pragma)
+        , ("--text",    Text)
+        , ("--strip",   Strip)
+        , ("--strip-eol",  StripEol)
+        , ("--hashes",  Ansi)
+        , ("--layout",  Layout)
+        , ("--unlit",   Unlit)
+        , ("--nowarn",  SuppressWarnings)
+        ]
+
+-- | Parse a single raw command-line option.  Parse failure is indicated by
+--   result Nothing.
+rawOption :: String -> Maybe RawOption
+rawOption x | isJust a = a
+    where a = lookup x flags
+rawOption ('-':'D':xs) = Just $ Macro (s, if null d then "1" else tail d)
+    where (s,d) = break (=='=') xs
+rawOption ('-':'U':xs) = Just $ IgnoredForCompatibility
+rawOption ('-':'I':xs) = Just $ Path $ trailing "/\\" xs
+rawOption xs | "--include="`isPrefixOf`xs
+            = Just $ PreInclude (drop 10 xs)
+rawOption _ = Nothing
+
+-- | Trim trailing elements of the second list that match any from
+--   the first list.  Typically used to remove trailing forward\/back
+--   slashes from a directory path.
+trailing :: (Eq a) => [a] -> [a] -> [a]
+trailing xs = reverse . dropWhile (`elem`xs) . reverse
+
+-- | Convert a list of RawOption to a BoolOptions structure.
+boolOpts :: [RawOption] -> BoolOptions
+boolOpts opts =
+  BoolOptions
+    { macros    = not (NoMacro `elem` opts)
+    , locations = not (NoLine  `elem` opts)
+    , hashline  = not (LinePragma `elem` opts)
+    , pragma    =      Pragma  `elem` opts
+    , stripEol  =      StripEol`elem` opts
+    , stripC89  =      StripEol`elem` opts || Strip `elem` opts
+    , lang      = not (Text    `elem` opts)
+    , ansi      =      Ansi    `elem` opts
+    , layout    =      Layout  `elem` opts
+    , literate  =      Unlit   `elem` opts
+    , warnings  = not (SuppressWarnings `elem` opts)
+    }
+
+-- | Parse all command-line options.
+parseOptions :: [String] -> Either String CpphsOptions
+parseOptions xs = f ([], [], []) xs
+  where
+    f (opts, ins, outs) (('-':'O':x):xs) = f (opts, ins, x:outs) xs
+    f (opts, ins, outs) (x@('-':_):xs) = case rawOption x of
+                                           Nothing -> Left x
+                                           Just a  -> f (a:opts, ins, outs) xs
+    f (opts, ins, outs) (x:xs) = f (opts, normalise x:ins, outs) xs
+    f (opts, ins, outs) []     =
+        Right CpphsOptions { infiles  = reverse ins
+                           , outfiles = reverse outs
+                           , defines  = [ x | Macro x <- reverse opts ]
+                           , includes = [ x | Path x  <- reverse opts ]
+                           , preInclude=[ x | PreInclude x <- reverse opts ]
+                           , boolopts = boolOpts opts
+                           }
+    normalise ('/':'/':filepath) = normalise ('/':filepath)
+    normalise (x:filepath)       = x:normalise filepath
+    normalise []                 = []
+ examples/CppHs/Language/Preprocessor/Cpphs/Position.hs view
@@ -0,0 +1,106 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Position
+-- Copyright   :  2000-2004 Malcolm Wallace
+-- Licence     :  LGPL
+--
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  experimental
+-- Portability :  All
+--
+-- Simple file position information, with recursive inclusion points.
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.Position
+  ( Posn(..)
+  , newfile
+  , addcol, newline, tab, newlines, newpos
+  , cppline, haskline, cpp2hask
+  , filename, lineno, directory
+  , cleanPath
+  ) where
+
+import Data.List (isPrefixOf)
+
+-- | Source positions contain a filename, line, column, and an
+--   inclusion point, which is itself another source position,
+--   recursively.
+data Posn = Pn String !Int !Int (Maybe Posn)
+        deriving (Eq)
+
+instance Show Posn where
+      showsPrec _ (Pn f l c i) = showString f .
+                                 showString "  at line " . shows l .
+                                 showString " col " . shows c .
+                                 ( case i of
+                                    Nothing -> id
+                                    Just p  -> showString "\n    used by  " .
+                                               shows p )
+
+-- | Constructor.  Argument is filename.
+newfile :: String -> Posn
+newfile name = Pn (cleanPath name) 1 1 Nothing
+
+-- | Increment column number by given quantity.
+addcol :: Int -> Posn -> Posn
+addcol n (Pn f r c i) = Pn f r (c+n) i
+
+-- | Increment row number, reset column to 1.
+newline :: Posn -> Posn
+--newline (Pn f r _ i) = Pn f (r+1) 1 i
+newline (Pn f r _ i) = let r' = r+1 in r' `seq` Pn f r' 1 i
+
+-- | Increment column number, tab stops are every 8 chars.
+tab     :: Posn -> Posn
+tab     (Pn f r c i) = Pn f r (((c`div`8)+1)*8) i
+
+-- | Increment row number by given quantity.
+newlines :: Int -> Posn -> Posn
+newlines n (Pn f r _ i) = Pn f (r+n) 1 i
+
+-- | Update position with a new row, and possible filename.
+newpos :: Int -> Maybe String -> Posn -> Posn
+newpos r Nothing  (Pn f _ c i) = Pn f r c i
+newpos r (Just ('"':f)) (Pn _ _ c i) = Pn (init f) r c i
+newpos r (Just f)       (Pn _ _ c i) = Pn f r c i
+
+-- | Project the line number.
+lineno    :: Posn -> Int
+-- | Project the filename.
+filename  :: Posn -> String
+-- | Project the directory of the filename.
+directory :: Posn -> FilePath
+
+lineno    (Pn _ r _ _) = r
+filename  (Pn f _ _ _) = f
+directory (Pn f _ _ _) = dirname f
+
+
+-- | cpp-style printing of file position
+cppline :: Posn -> String
+cppline (Pn f r _ _) = "#line "++show r++" "++show f
+
+-- | haskell-style printing of file position
+haskline :: Posn -> String
+haskline (Pn f r _ _) = "{-# LINE "++show r++" "++show f++" #-}"
+
+-- | Conversion from a cpp-style "#line" to haskell-style pragma.
+cpp2hask :: String -> String
+cpp2hask line | "#line" `isPrefixOf` line = "{-# LINE "
+                                            ++unwords (tail (words line))
+                                            ++" #-}"
+              | otherwise = line
+
+-- | Strip non-directory suffix from file name (analogous to the shell
+--   command of the same name).
+dirname :: String -> String
+dirname  = reverse . safetail . dropWhile (not.(`elem`"\\/")) . reverse
+  where safetail [] = []
+        safetail (_:x) = x
+
+-- | Sigh.  Mixing Windows filepaths with unix is bad.  Make sure there is a
+--   canonical path separator.
+cleanPath :: FilePath -> FilePath
+cleanPath [] = []
+cleanPath ('\\':cs) = '/': cleanPath cs
+cleanPath (c:cs)    = c:   cleanPath cs
+ examples/CppHs/Language/Preprocessor/Cpphs/ReadFirst.hs view
@@ -0,0 +1,55 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  ReadFirst
+-- Copyright   :  2004 Malcolm Wallace
+-- Licence     :  LGPL
+-- 
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  experimental
+-- Portability :  All
+--
+-- Read the first file that matches in a list of search paths.
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.ReadFirst
+  ( readFirst
+  ) where
+
+import System.IO        (hPutStrLn, stderr)
+import System.Directory (doesFileExist)
+import Data.List      (intersperse)
+import Control.Monad     (when)
+import Language.Preprocessor.Cpphs.Position  (Posn,directory,cleanPath)
+
+-- | Attempt to read the given file from any location within the search path.
+--   The first location found is returned, together with the file content.
+--   (The directory of the calling file is always searched first, then
+--    the current directory, finally any specified search path.)
+readFirst :: String             -- ^ filename
+        -> Posn                 -- ^ inclusion point
+        -> [String]             -- ^ search path
+        -> Bool                 -- ^ report warnings?
+        -> IO ( FilePath
+              , String
+              )                 -- ^ discovered filepath, and file contents
+
+readFirst name demand path warn =
+    case name of
+       '/':nm -> try nm   [""]
+       _      -> try name (cons dd (".":path))
+  where
+    dd = directory demand
+    cons x xs = if null x then xs else x:xs
+    try name [] = do
+        when warn $
+          hPutStrLn stderr ("Warning: Can't find file \""++name
+                           ++"\" in directories\n\t"
+                           ++concat (intersperse "\n\t" (cons dd (".":path)))
+                           ++"\n  Asked for by: "++show demand)
+        return ("missing file: "++name,"")
+    try name (p:ps) = do
+        let file = cleanPath p++'/':cleanPath name
+        ok <- doesFileExist file
+        if not ok then try name ps
+          else do content <- readFile file
+                  return (file,content)
+ examples/CppHs/Language/Preprocessor/Cpphs/RunCpphs.hs view
@@ -0,0 +1,82 @@+{-
+-- The main program for cpphs, a simple C pre-processor written in Haskell.
+
+-- Copyright (c) 2004 Malcolm Wallace
+-- This file is LGPL (relicensed from the GPL by Malcolm Wallace, October 2011).
+-}
+module Language.Preprocessor.Cpphs.RunCpphs ( runCpphs
+                                            , runCpphsPass1
+                                            , runCpphsPass2
+                                            , runCpphsReturningSymTab
+                                            ) where
+
+import Language.Preprocessor.Cpphs.CppIfdef (cppIfdef)
+import Language.Preprocessor.Cpphs.MacroPass(macroPass,macroPassReturningSymTab)
+import Language.Preprocessor.Cpphs.Options  (CpphsOptions(..), BoolOptions(..)
+                                            ,trailing)
+import Language.Preprocessor.Cpphs.Tokenise (deWordStyle, tokenise)
+import Language.Preprocessor.Cpphs.Position (cleanPath, Posn)
+import Language.Preprocessor.Unlit as Unlit (unlit)
+
+
+runCpphs :: CpphsOptions -> FilePath -> String -> IO String
+runCpphs options filename input = do
+  pass1 <- runCpphsPass1 options filename input
+  runCpphsPass2 (boolopts options) (defines options) filename pass1
+
+runCpphsPass1 :: CpphsOptions -> FilePath -> String -> IO [(Posn,String)]
+runCpphsPass1 options' filename input = do
+  let options= options'{ includes= map (trailing "\\/") (includes options') }
+  let bools  = boolopts options
+      preInc = case preInclude options of
+                 [] -> ""
+                 is -> concatMap (\f->"#include \""++f++"\"\n") is 
+                       ++ "#line 1 \""++cleanPath filename++"\"\n"
+
+  pass1 <- cppIfdef filename (defines options) (includes options) bools
+                    (preInc++input)
+  return pass1
+
+runCpphsPass2 :: BoolOptions -> [(String,String)] -> FilePath -> [(Posn,String)] -> IO String
+runCpphsPass2 bools defines filename pass1 = do
+  pass2 <- macroPass defines bools pass1
+  let result= if not (macros bools)
+              then if   stripC89 bools || stripEol bools
+                   then concatMap deWordStyle $
+                        tokenise (stripEol bools) (stripC89 bools)
+                                 (ansi bools) (lang bools) pass1
+                   else unlines (map snd pass1)
+              else pass2
+      pass3 = if literate bools then Unlit.unlit filename else id
+  return (pass3 result)
+
+runCpphsReturningSymTab :: CpphsOptions -> FilePath -> String
+             -> IO (String,[(String,String)])
+runCpphsReturningSymTab options' filename input = do
+  let options= options'{ includes= map (trailing "\\/") (includes options') }
+  let bools  = boolopts options
+      preInc = case preInclude options of
+                 [] -> ""
+                 is -> concatMap (\f->"#include \""++f++"\"\n") is 
+                       ++ "#line 1 \""++cleanPath filename++"\"\n"
+  (pass2,syms) <-
+      if macros bools then do
+          pass1 <- cppIfdef filename (defines options) (includes options)
+                            bools (preInc++input)
+          macroPassReturningSymTab (defines options) bools pass1
+      else do
+          pass1 <- cppIfdef filename (defines options) (includes options)
+                            bools{macros=True} (preInc++input)
+          (_,syms) <- macroPassReturningSymTab (defines options) bools pass1
+          pass1 <- cppIfdef filename (defines options) (includes options)
+                            bools (preInc++input)
+          let result = if   stripC89 bools || stripEol bools
+                       then concatMap deWordStyle $
+                            tokenise (stripEol bools) (stripC89 bools)
+                                     (ansi bools) (lang bools) pass1
+                       else init $ unlines (map snd pass1)
+          return (result,syms)
+
+  let pass3 = if literate bools then Unlit.unlit filename else id
+  return (pass3 pass2, syms)
+
+ examples/CppHs/Language/Preprocessor/Cpphs/SymTab.hs view
@@ -0,0 +1,92 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  SymTab
+-- Copyright   :  2000-2004 Malcolm Wallace
+-- Licence     :  LGPL
+-- 
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  Stable
+-- Portability :  All
+--
+-- Symbol Table, based on index trees using a hash on the key.
+--   Keys are always Strings.  Stored values can be any type.
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.SymTab
+  ( SymTab
+  , emptyST
+  , insertST
+  , deleteST
+  , lookupST
+  , definedST
+  , flattenST
+  , IndTree
+  ) where
+
+-- | Symbol Table.  Stored values are polymorphic, but the keys are
+--   always strings.
+type SymTab v = IndTree [(String,v)]
+
+emptyST   :: SymTab v
+insertST  :: (String,v) -> SymTab v -> SymTab v
+deleteST  :: String -> SymTab v -> SymTab v
+lookupST  :: String -> SymTab v -> Maybe v
+definedST :: String -> SymTab v -> Bool
+flattenST :: SymTab v -> [v]
+
+emptyST           = itgen maxHash []
+insertST (s,v) ss = itiap (hash s) ((s,v):)    ss id
+deleteST  s    ss = itiap (hash s) (filter ((/=s).fst)) ss id
+lookupST  s    ss = let vs = filter ((==s).fst) ((itind (hash s)) ss)
+                    in if null vs then Nothing
+                       else (Just . snd . head) vs
+definedST s    ss = let vs = filter ((==s).fst) ((itind (hash s)) ss)
+                    in (not . null) vs
+flattenST      ss = itfold (map snd) (++) ss
+
+
+----
+-- | Index Trees (storing indexes at nodes).
+
+data IndTree t = Leaf t | Fork Int (IndTree t) (IndTree t)
+     deriving Show
+
+itgen :: Int -> a -> IndTree a
+itgen 1 x = Leaf x
+itgen n x =
+  let n' = n `div` 2
+  in Fork n' (itgen n' x) (itgen (n-n') x)
+
+itiap :: --Eval a =>
+         Int -> (a->a) -> IndTree a -> (IndTree a -> b) -> b
+itiap _ f (Leaf x)       k = let fx = f x in {-seq fx-} (k (Leaf fx))
+itiap i f (Fork n lt rt) k =
+  if i<n then
+       itiap i f lt $ \lt' -> k (Fork n lt' rt)
+  else itiap (i-n) f rt $ \rt' -> k (Fork n lt rt')
+
+itind :: Int -> IndTree a -> a
+itind _ (Leaf x) = x
+itind i (Fork n lt rt) = if i<n then itind i lt else itind (i-n) rt
+
+itfold :: (a->b) -> (b->b->b) -> IndTree a -> b
+itfold leaf _fork (Leaf x) = leaf x
+itfold leaf  fork (Fork _ l r) = fork (itfold leaf fork l) (itfold leaf fork r)
+
+----
+-- Hash values
+
+maxHash :: Int -- should be prime
+maxHash = 101
+
+class Hashable a where
+    hashWithMax :: Int -> a -> Int
+    hash        :: a -> Int
+    hash = hashWithMax maxHash
+
+instance Enum a => Hashable [a] where
+    hashWithMax m = h 0
+        where h a []     = a
+              h a (c:cs) = h ((17*(fromEnum c)+19*a)`rem`m) cs
+
+----
+ examples/CppHs/Language/Preprocessor/Cpphs/Tokenise.hs view
@@ -0,0 +1,281 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Tokenise
+-- Copyright   :  2004 Malcolm Wallace
+-- Licence     :  LGPL
+--
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  experimental
+-- Portability :  All
+--
+-- The purpose of this module is to lex a source file (language
+-- unspecified) into tokens such that cpp can recognise a replaceable
+-- symbol or macro-use, and do the right thing.
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.Tokenise
+  ( linesCpp
+  , reslash
+  , tokenise
+  , WordStyle(..)
+  , deWordStyle
+  , parseMacroCall
+  ) where
+
+import Data.Char
+import Language.Preprocessor.Cpphs.HashDefine
+import Language.Preprocessor.Cpphs.Position
+
+-- | A Mode value describes whether to tokenise a la Haskell, or a la Cpp.
+--   The main difference is that in Cpp mode we should recognise line
+--   continuation characters.
+data Mode = Haskell | Cpp
+
+-- | linesCpp is, broadly speaking, Prelude.lines, except that
+--   on a line beginning with a \#, line continuation characters are
+--   recognised.  In a line continuation, the newline character is
+--   preserved, but the backslash is not.
+linesCpp :: String -> [String]
+linesCpp  []                 = []
+linesCpp (x:xs) | x=='#'     = tok Cpp     ['#'] xs
+                | otherwise  = tok Haskell [] (x:xs)
+  where
+    tok Cpp   acc ('\\':'\n':ys)   = tok Cpp ('\n':acc) ys
+    tok _     acc ('\n':'#':ys)    = reverse acc: tok Cpp ['#'] ys
+    tok _     acc ('\n':ys)        = reverse acc: tok Haskell [] ys
+    tok _     acc []               = reverse acc: []
+    tok mode  acc (y:ys)           = tok mode (y:acc) ys
+
+-- | Put back the line-continuation characters.
+reslash :: String -> String
+reslash ('\n':xs) = '\\':'\n':reslash xs
+reslash (x:xs)    = x: reslash xs
+reslash   []      = []
+
+----
+-- | Submodes are required to deal correctly with nesting of lexical
+--   structures.
+data SubMode = Any | Pred (Char->Bool) (Posn->String->WordStyle)
+             | String Char | LineComment | NestComment Int
+             | CComment | CLineComment
+
+-- | Each token is classified as one of Ident, Other, or Cmd:
+--   * Ident is a word that could potentially match a macro name.
+--   * Cmd is a complete cpp directive (\#define etc).
+--   * Other is anything else.
+data WordStyle = Ident Posn String | Other String | Cmd (Maybe HashDefine)
+  deriving (Eq,Show)
+other :: Posn -> String -> WordStyle
+other _ s = Other s
+
+deWordStyle :: WordStyle -> String
+deWordStyle (Ident _ i) = i
+deWordStyle (Other i)   = i
+deWordStyle (Cmd _)     = "\n"
+
+-- | tokenise is, broadly-speaking, Prelude.words, except that:
+--    * the input is already divided into lines
+--    * each word-like "token" is categorised as one of {Ident,Other,Cmd}
+--    * \#define's are parsed and returned out-of-band using the Cmd variant
+--    * All whitespace is preserved intact as tokens.
+--    * C-comments are converted to white-space (depending on first param)
+--    * Parens and commas are tokens in their own right.
+--    * Any cpp line continuations are respected.
+--   No errors can be raised.
+--   The inverse of tokenise is (concatMap deWordStyle).
+tokenise :: Bool -> Bool -> Bool -> Bool -> [(Posn,String)] -> [WordStyle]
+tokenise _        _             _    _     [] = []
+tokenise stripEol stripComments ansi lang ((pos,str):pos_strs) =
+    (if lang then haskell else plaintext) Any [] pos pos_strs str
+ where
+    -- rules to lex Haskell
+  haskell :: SubMode -> String -> Posn -> [(Posn,String)]
+             -> String -> [WordStyle]
+  haskell Any acc p ls ('\n':'#':xs)      = emit acc $  -- emit "\n" $
+                                            cpp Any haskell [] [] p ls xs
+    -- warning: non-maximal munch on comment
+  haskell Any acc p ls ('-':'-':xs)       = emit acc $
+                                            haskell LineComment "--" p ls xs
+  haskell Any acc p ls ('{':'-':xs)       = emit acc $
+                                            haskell (NestComment 0) "-{" p ls xs
+  haskell Any acc p ls ('/':'*':xs)
+                          | stripComments = emit acc $
+                                            haskell CComment "  " p ls xs
+  haskell Any acc p ls ('/':'/':xs)
+                          | stripEol      = emit acc $
+                                            haskell CLineComment "  " p ls xs
+  haskell Any acc p ls ('"':xs)           = emit acc $
+                                            haskell (String '"') ['"'] p ls xs
+  haskell Any acc p ls ('\'':'\'':xs)     = emit acc $ -- TH type quote
+                                            haskell Any "''" p ls xs
+  haskell Any acc p ls ('\'':xs@('\\':_)) = emit acc $ -- escaped char literal
+                                            haskell (String '\'') "'" p ls xs
+  haskell Any acc p ls ('\'':x:'\'':xs)   = emit acc $ -- character literal
+                                            emit ['\'', x, '\''] $
+                                            haskell Any [] p ls xs
+  haskell Any acc p ls ('\'':xs)          = emit acc $ -- TH name quote
+                                            haskell Any "'" p ls xs
+  haskell Any acc p ls (x:xs) | single x  = emit acc $ emit [x] $
+                                            haskell Any [] p ls xs
+  haskell Any acc p ls (x:xs) | space x   = emit acc $
+                                            haskell (Pred space other) [x]
+                                                                        p ls xs
+  haskell Any acc p ls (x:xs) | symbol x  = emit acc $
+                                            haskell (Pred symbol other) [x]
+                                                                        p ls xs
+ -- haskell Any [] p ls (x:xs) | ident0 x  = id $
+  haskell Any acc p ls (x:xs) | ident0 x  = emit acc $
+                                            haskell (Pred ident1 Ident) [x]
+                                                                        p ls xs
+  haskell Any acc p ls (x:xs)             = haskell Any (x:acc) p ls xs
+
+  haskell pre@(Pred pred ws) acc p ls (x:xs)
+                        | pred x    = haskell pre (x:acc) p ls xs
+  haskell (Pred _ ws) acc p ls xs   = ws p (reverse acc):
+                                      haskell Any [] p ls xs
+  haskell (String c) acc p ls ('\\':x:xs)
+                        | x=='\\'   = haskell (String c) ('\\':'\\':acc) p ls xs
+                        | x==c      = haskell (String c) (c:'\\':acc) p ls xs
+  haskell (String c) acc p ls (x:xs)
+                        | x==c      = emit (c:acc) $ haskell Any [] p ls xs
+                        | otherwise = haskell (String c) (x:acc) p ls xs
+  haskell LineComment acc p ls xs@('\n':_) = emit acc $ haskell Any [] p ls xs
+  haskell LineComment acc p ls (x:xs)      = haskell LineComment (x:acc) p ls xs
+  haskell (NestComment n) acc p ls ('{':'-':xs)
+                                    = haskell (NestComment (n+1))
+                                                            ("-{"++acc) p ls xs
+  haskell (NestComment 0) acc p ls ('-':'}':xs)
+                                    = emit ("}-"++acc) $ haskell Any [] p ls xs
+  haskell (NestComment n) acc p ls ('-':'}':xs)
+                                    = haskell (NestComment (n-1))
+                                                            ("}-"++acc) p ls xs
+  haskell (NestComment n) acc p ls (x:xs) = haskell (NestComment n) (x:acc)
+                                                                        p ls xs
+  haskell CComment acc p ls ('*':'/':xs)  = emit ("  "++acc) $
+                                            haskell Any [] p ls xs
+  haskell CComment acc p ls (x:xs)        = haskell CComment (white x:acc) p ls xs
+  haskell CLineComment acc p ls xs@('\n':_)= emit acc $ haskell Any [] p ls xs
+  haskell CLineComment acc p ls (_:xs)    = haskell CLineComment (' ':acc)
+                                                                       p ls xs
+  haskell mode acc _ ((p,l):ls) []        = haskell mode acc p ls ('\n':l)
+  haskell _    acc _ [] []                = emit acc $ []
+
+  -- rules to lex Cpp
+  cpp :: SubMode -> (SubMode -> String -> Posn -> [(Posn,String)]
+                     -> String -> [WordStyle])
+         -> String -> [String] -> Posn -> [(Posn,String)]
+         -> String -> [WordStyle]
+  cpp mode next word line pos remaining input =
+    lexcpp mode word line remaining input
+   where
+    lexcpp Any w l ls ('/':'*':xs)   = lexcpp (NestComment 0) "" (w*/*l) ls xs
+    lexcpp Any w l ls ('/':'/':xs)   = lexcpp LineComment "  " (w*/*l) ls xs
+    lexcpp Any w l ((p,l'):ls) ('\\':[])  = cpp Any next [] ("\n":w*/*l) p ls l'
+    lexcpp Any w l ls ('\\':'\n':xs) = lexcpp Any [] ("\n":w*/*l) ls xs
+    lexcpp Any w l ls xs@('\n':_)    = Cmd (parseHashDefine ansi
+                                                           (reverse (w*/*l))):
+                                       next Any [] pos ls xs
+ -- lexcpp Any w l ls ('"':xs)     = lexcpp (String '"') ['"'] (w*/*l) ls xs
+ -- lexcpp Any w l ls ('\'':xs)    = lexcpp (String '\'') "'"  (w*/*l) ls xs
+    lexcpp Any w l ls ('"':xs)       = lexcpp Any [] ("\"":(w*/*l)) ls xs
+    lexcpp Any w l ls ('\'':xs)      = lexcpp Any [] ("'": (w*/*l)) ls xs
+    lexcpp Any [] l ls (x:xs)
+                    | ident0 x  = lexcpp (Pred ident1 Ident) [x] l ls xs
+ -- lexcpp Any w l ls (x:xs) | ident0 x  = lexcpp (Pred ident1 Ident) [x] (w*/*l) ls xs
+    lexcpp Any w l ls (x:xs)
+                    | single x  = lexcpp Any [] ([x]:w*/*l) ls xs
+                    | space x   = lexcpp (Pred space other) [x] (w*/*l) ls xs
+                    | symbol x  = lexcpp (Pred symbol other) [x] (w*/*l) ls xs
+                    | otherwise = lexcpp Any (x:w) l ls xs
+    lexcpp pre@(Pred pred _) w l ls (x:xs)
+                    | pred x    = lexcpp pre (x:w) l ls xs
+    lexcpp (Pred _ _) w l ls xs = lexcpp Any [] (w*/*l) ls xs
+    lexcpp (String c) w l ls ('\\':x:xs)
+                    | x=='\\'   = lexcpp (String c) ('\\':'\\':w) l ls xs
+                    | x==c      = lexcpp (String c) (c:'\\':w) l ls xs
+    lexcpp (String c) w l ls (x:xs)
+                    | x==c      = lexcpp Any [] ((c:w)*/*l) ls xs
+                    | otherwise = lexcpp (String c) (x:w) l ls xs
+    lexcpp LineComment w l ((p,l'):ls) ('\\':[])
+                             = cpp LineComment next [] (('\n':w)*/*l) pos ls l'
+    lexcpp LineComment w l ls ('\\':'\n':xs)
+                                = lexcpp LineComment [] (('\n':w)*/*l) ls xs
+    lexcpp LineComment w l ls xs@('\n':_) = lexcpp Any w l ls xs
+    lexcpp LineComment w l ls (_:xs)      = lexcpp LineComment (' ':w) l ls xs
+    lexcpp (NestComment _) w l ls ('*':'/':xs)
+                                          = lexcpp Any [] (w*/*l) ls xs
+    lexcpp (NestComment n) w l ls (x:xs)  = lexcpp (NestComment n) (white x:w) l
+                                                                        ls xs
+    lexcpp mode w l ((p,l'):ls) []        = cpp mode next w l p ls ('\n':l')
+    lexcpp _    _ _ []          []        = []
+
+    -- rules to lex non-Haskell, non-cpp text
+  plaintext :: SubMode -> String -> Posn -> [(Posn,String)]
+            -> String -> [WordStyle]
+  plaintext Any acc p ls ('\n':'#':xs)  = emit acc $  -- emit "\n" $
+                                          cpp Any plaintext [] [] p ls xs
+  plaintext Any acc p ls ('/':'*':xs)
+                           | stripComments = emit acc $
+                                             plaintext CComment "  " p ls xs
+  plaintext Any acc p ls ('/':'/':xs)
+                                | stripEol = emit acc $
+                                             plaintext CLineComment "  " p ls xs
+  plaintext Any acc p ls (x:xs) | single x = emit acc $ emit [x] $
+                                             plaintext Any [] p ls xs
+  plaintext Any acc p ls (x:xs) | space x  = emit acc $
+                                             plaintext (Pred space other) [x]
+                                                                        p ls xs
+  plaintext Any acc p ls (x:xs) | ident0 x = emit acc $
+                                             plaintext (Pred ident1 Ident) [x]
+                                                                        p ls xs
+  plaintext Any acc p ls (x:xs)            = plaintext Any (x:acc) p ls xs
+  plaintext pre@(Pred pred ws) acc p ls (x:xs)
+                                | pred x   = plaintext pre (x:acc) p ls xs
+  plaintext (Pred _ ws) acc p ls xs        = ws p (reverse acc):
+                                             plaintext Any [] p ls xs
+  plaintext CComment acc p ls ('*':'/':xs) = emit ("  "++acc) $
+                                             plaintext Any [] p ls xs
+  plaintext CComment acc p ls (x:xs)       = plaintext CComment (white x:acc) p ls xs
+  plaintext CLineComment acc p ls xs@('\n':_)
+                                        = emit acc $ plaintext Any [] p ls xs
+  plaintext CLineComment acc p ls (_:xs)= plaintext CLineComment (' ':acc)
+                                                                       p ls xs
+  plaintext mode acc _ ((p,l):ls) []    = plaintext mode acc p ls ('\n':l)
+  plaintext _    acc _ [] []            = emit acc $ []
+
+  -- predicates for lexing Haskell.
+  ident0 x = isAlpha x    || x `elem` "_`"
+  ident1 x = isAlphaNum x || x `elem` "'_`"
+  symbol x = x `elem` ":!#$%&*+./<=>?@\\^|-~"
+  single x = x `elem` "(),[];{}"
+  space  x = x `elem` " \t"
+  -- conversion of comment text to whitespace
+  white '\n' = '\n'
+  white '\r' = '\r'
+  white _    = ' '
+  -- emit a token (if there is one) from the accumulator
+  emit ""  = id
+  emit xs  = (Other (reverse xs):)
+  -- add a reversed word to the accumulator
+  "" */* l = l
+  w */* l  = reverse w : l
+  -- help out broken Haskell compilers which need balanced numbers of C
+  -- comments in order to do import chasing :-)  ----->   */*
+
+
+-- | Parse a possible macro call, returning argument list and remaining input
+parseMacroCall :: Posn -> [WordStyle] -> Maybe ([[WordStyle]],[WordStyle])
+parseMacroCall p = call . skip
+  where
+    skip (Other x:xs) | all isSpace x = skip xs
+    skip xss                          = xss
+    call (Other "(":xs)   = (args (0::Int) [] [] . skip) xs
+    call _                = Nothing
+    args 0 w acc (   Other ")" :xs)  = Just (reverse (addone w acc), xs)
+    args 0 w acc (   Other "," :xs)  = args 0     []   (addone w acc) (skip xs)
+    args n w acc (x@(Other "("):xs)  = args (n+1) (x:w)         acc    xs
+    args n w acc (x@(Other ")"):xs)  = args (n-1) (x:w)         acc    xs
+    args n w acc (   Ident _ v :xs)  = args n     (Ident p v:w) acc    xs
+    args n w acc (x@(Other _)  :xs)  = args n     (x:w)         acc    xs
+    args _ _ _   _                   = Nothing
+    addone w acc = reverse (skip w): acc
+ examples/CppHs/Language/Preprocessor/Unlit.hs view
@@ -0,0 +1,72 @@+-- | Part of this code is from "Report on the Programming Language Haskell",
+--   version 1.2, appendix C.
+module Language.Preprocessor.Unlit (unlit) where
+
+import Data.Char
+import Data.List (isPrefixOf)
+
+data Classified = Program String | Blank | Comment
+                | Include Int String | Pre String
+
+classify :: [String] -> [Classified]
+classify []                = []
+classify (('\\':x):xs) | x == "begin{code}" = Blank : allProg xs
+   where allProg [] = []  -- Should give an error message,
+                          -- but I have no good position information.
+         allProg (('\\':x):xs) |  "end{code}"`isPrefixOf`x = Blank : classify xs
+         allProg (x:xs) = Program x:allProg xs
+classify (('>':x):xs)      = Program (' ':x) : classify xs
+classify (('#':x):xs)      = (case words x of
+                                (line:rest) | all isDigit line
+                                   -> Include (read line) (unwords rest)
+                                _  -> Pre x
+                             ) : classify xs
+--classify (x:xs) | "{-# LINE" `isPrefixOf` x = Program x: classify xs
+classify (x:xs) | all isSpace x = Blank:classify xs
+classify (x:xs)                 = Comment:classify xs
+
+unclassify :: Classified -> String
+unclassify (Program s) = s
+unclassify (Pre s)     = '#':s
+unclassify (Include i f) = '#':' ':show i ++ ' ':f
+unclassify Blank       = ""
+unclassify Comment     = ""
+
+-- | 'unlit' takes a filename (for error reports), and transforms the
+--   given string, to eliminate the literate comments from the program text.
+unlit :: FilePath -> String -> String
+unlit file lhs = (unlines
+                 . map unclassify
+                 . adjacent file (0::Int) Blank
+                 . classify) (inlines lhs)
+
+adjacent :: FilePath -> Int -> Classified -> [Classified] -> [Classified]
+adjacent file 0 _             (x              :xs) = x : adjacent file 1 x xs -- force evaluation of line number
+adjacent file n y@(Program _) (x@Comment      :xs) = error (message file n "program" "comment")
+adjacent file n y@(Program _) (x@(Include i f):xs) = x: adjacent f    i     y xs
+adjacent file n y@(Program _) (x@(Pre _)      :xs) = x: adjacent file (n+1) y xs
+adjacent file n y@Comment     (x@(Program _)  :xs) = error (message file n "comment" "program")
+adjacent file n y@Comment     (x@(Include i f):xs) = x: adjacent f    i     y xs
+adjacent file n y@Comment     (x@(Pre _)      :xs) = x: adjacent file (n+1) y xs
+adjacent file n y@Blank       (x@(Include i f):xs) = x: adjacent f    i     y xs
+adjacent file n y@Blank       (x@(Pre _)      :xs) = x: adjacent file (n+1) y xs
+adjacent file n _             (x@next         :xs) = x: adjacent file (n+1) x xs
+adjacent file n _             []                   = []
+
+message :: String -> Int -> String -> String -> String
+message "\"\"" n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"
+message []     n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"
+message file   n p c = "In file " ++ file ++ " at line "++show n++": "++p++ " line before "++c++" line.\n"
+
+
+-- Re-implementation of 'lines', for better efficiency (but decreased laziness).
+-- Also, importantly, accepts non-standard DOS and Mac line ending characters.
+inlines :: String -> [String]
+inlines s = lines' s id
+  where
+  lines' []             acc = [acc []]
+  lines' ('\^M':'\n':s) acc = acc [] : lines' s id      -- DOS
+  lines' ('\^M':s)      acc = acc [] : lines' s id      -- MacOS
+  lines' ('\n':s)       acc = acc [] : lines' s id      -- Unix
+  lines' (c:s)          acc = lines' s (acc . (c:))
+
+ examples/Project/has-cabal/A.hs view
@@ -0,0 +1,3 @@+module A where
+
+x = ()
+ examples/Project/has-cabal/some-test-package.cabal view
@@ -0,0 +1,18 @@+name:                some-test-package
+version:             1.2.3.4
+synopsis:            A package just for testing Haskell-tools support. Don't install it.
+description:         
+
+homepage:            https://github.com/nboldi/haskell-tools
+license:             BSD3
+license-file:        LICENSE
+author:              Boldizsar Nemeth
+maintainer:          nboldi@elte.hu
+category:            Language
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     A
+  build-depends:       base
+  default-language:    Haskell2010
+ examples/Project/multi-packages-flags/package1/A.hs view
@@ -0,0 +1,3 @@+module A where
+
+x = \case () -> ()
+ examples/Project/multi-packages-flags/package1/package1.cabal view
@@ -0,0 +1,19 @@+name:                package1
+version:             1.2.3.4
+synopsis:            A package just for testing Haskell-tools support. Don't install it.
+description:         
+
+homepage:            https://github.com/nboldi/haskell-tools
+license:             BSD3
+license-file:        LICENSE
+author:              Boldizsar Nemeth
+maintainer:          nboldi@elte.hu
+category:            Language
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     A
+  build-depends:       base
+  default-language:    Haskell2010
+  default-extensions:  LambdaCase
+ examples/Project/multi-packages-flags/package2/B.hs view
@@ -0,0 +1,3 @@+module B where
+
+x = (,())
+ examples/Project/multi-packages-flags/package2/package2.cabal view
@@ -0,0 +1,19 @@+name:                package2
+version:             1.2.3.4
+synopsis:            A package just for testing Haskell-tools support. Don't install it.
+description:         
+
+homepage:            https://github.com/nboldi/haskell-tools
+license:             BSD3
+license-file:        LICENSE
+author:              Boldizsar Nemeth
+maintainer:          nboldi@elte.hu
+category:            Language
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     B
+  build-depends:       base
+  default-language:    Haskell2010
+  default-extensions:  TupleSections
+ examples/Project/multi-packages-same-module/package1/A.hs view
@@ -0,0 +1,3 @@+module A where
+
+x = ()
+ examples/Project/multi-packages-same-module/package1/package1.cabal view
@@ -0,0 +1,18 @@+name:                package1
+version:             1.2.3.4
+synopsis:            A package just for testing Haskell-tools support. Don't install it.
+description:         
+
+homepage:            https://github.com/nboldi/haskell-tools
+license:             BSD3
+license-file:        LICENSE
+author:              Boldizsar Nemeth
+maintainer:          nboldi@elte.hu
+category:            Language
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     A
+  build-depends:       base
+  default-language:    Haskell2010
+ examples/Project/multi-packages-same-module/package2/A.hs view
@@ -0,0 +1,1 @@+module A where
+ examples/Project/multi-packages-same-module/package2/package2.cabal view
@@ -0,0 +1,18 @@+name:                package2
+version:             1.2.3.4
+synopsis:            A package just for testing Haskell-tools support. Don't install it.
+description:         
+
+homepage:            https://github.com/nboldi/haskell-tools
+license:             BSD3
+license-file:        LICENSE
+author:              Boldizsar Nemeth
+maintainer:          nboldi@elte.hu
+category:            Language
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     A
+  build-depends:       base
+  default-language:    Haskell2010
+ examples/Project/multi-packages/package1/A.hs view
@@ -0,0 +1,3 @@+module A where
+
+x = ()
+ examples/Project/multi-packages/package1/package1.cabal view
@@ -0,0 +1,18 @@+name:                package1
+version:             1.2.3.4
+synopsis:            A package just for testing Haskell-tools support. Don't install it.
+description:         
+
+homepage:            https://github.com/nboldi/haskell-tools
+license:             BSD3
+license-file:        LICENSE
+author:              Boldizsar Nemeth
+maintainer:          nboldi@elte.hu
+category:            Language
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     A
+  build-depends:       base
+  default-language:    Haskell2010
+ examples/Project/multi-packages/package2/B.hs view
@@ -0,0 +1,3 @@+module B where
+
+x = ()
+ examples/Project/multi-packages/package2/package2.cabal view
@@ -0,0 +1,18 @@+name:                package2
+version:             1.2.3.4
+synopsis:            A package just for testing Haskell-tools support. Don't install it.
+description:         
+
+homepage:            https://github.com/nboldi/haskell-tools
+license:             BSD3
+license-file:        LICENSE
+author:              Boldizsar Nemeth
+maintainer:          nboldi@elte.hu
+category:            Language
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     B
+  build-depends:       base
+  default-language:    Haskell2010
+ examples/Project/no-cabal/A.hs view
@@ -0,0 +1,3 @@+module A where
+
+x = ()
+ examples/Project/reloading/A.hs view
@@ -0,0 +1,5 @@+module A where
+
+import B
+
+a = b
+ examples/Project/reloading/B.hs view
@@ -0,0 +1,5 @@+module B where
+
+import C
+
+b = c
+ examples/Project/reloading/C.hs view
@@ -0,0 +1,3 @@+module C where
+
+c = ()
+ examples/Project/selection/B.hs view
@@ -0,0 +1,5 @@+module B where
+
+import C
+
+b = c
+ examples/Project/selection/C.hs view
@@ -0,0 +1,3 @@+module C where
+
+c = ()
+ examples/Project/source-dir-outside/some-test-package.cabal view
@@ -0,0 +1,19 @@+name:                some-test-package
+version:             1.2.3.4
+synopsis:            A package just for testing Haskell-tools support. Don't install it.
+description:         
+
+homepage:            https://github.com/nboldi/haskell-tools
+license:             BSD3
+license-file:        LICENSE
+author:              Boldizsar Nemeth
+maintainer:          nboldi@elte.hu
+category:            Language
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     A
+  hs-source-dirs:      ../src            
+  build-depends:       base
+  default-language:    Haskell2010
+ examples/Project/source-dir/some-test-package.cabal view
@@ -0,0 +1,19 @@+name:                some-test-package
+version:             1.2.3.4
+synopsis:            A package just for testing Haskell-tools support. Don't install it.
+description:         
+
+homepage:            https://github.com/nboldi/haskell-tools
+license:             BSD3
+license-file:        LICENSE
+author:              Boldizsar Nemeth
+maintainer:          nboldi@elte.hu
+category:            Language
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     A
+  hs-source-dirs:      src            
+  build-depends:       base
+  default-language:    Haskell2010
+ examples/Project/source-dir/src/A.hs view
@@ -0,0 +1,3 @@+module A where
+
+x = ()
+ examples/Project/src/A.hs view
@@ -0,0 +1,3 @@+module A where
+
+x = ()
haskell-tools-cli.cabal view
@@ -1,5 +1,5 @@ name:                haskell-tools-cli
-version:             0.4.1.0
+version:             0.4.1.1
 synopsis:            Command-line frontend for Haskell-tools Refact
 description:         Command-line frontend for Haskell-tools Refact. Not meant as a final product, only for demonstration purposes.
 homepage:            https://github.com/haskell-tools/haskell-tools
@@ -10,6 +10,31 @@ category:            Language
 build-type:          Simple
 cabal-version:       >=1.10
+
+extra-source-files: examples/CppHs/Language/Preprocessor/*.hs
+                  , examples/CppHs/Language/Preprocessor/Cpphs/*.hs
+                  , bench-tests/*.txt
+                  , examples/Project/has-cabal/*.hs
+                  , examples/Project/has-cabal/*.cabal
+                  , examples/Project/multi-packages/package1/*.hs
+                  , examples/Project/multi-packages/package1/*.cabal
+                  , examples/Project/multi-packages/package2/*.hs
+                  , examples/Project/multi-packages/package2/*.cabal
+                  , examples/Project/multi-packages-flags/package1/*.hs
+                  , examples/Project/multi-packages-flags/package1/*.cabal
+                  , examples/Project/multi-packages-flags/package2/*.hs
+                  , examples/Project/multi-packages-flags/package2/*.cabal
+                  , examples/Project/multi-packages-same-module/package1/*.hs
+                  , examples/Project/multi-packages-same-module/package1/*.cabal
+                  , examples/Project/multi-packages-same-module/package2/*.hs
+                  , examples/Project/multi-packages-same-module/package2/*.cabal
+                  , examples/Project/no-cabal/*.hs
+                  , examples/Project/reloading/*.hs
+                  , examples/Project/selection/*.hs
+                  , examples/Project/source-dir/*.cabal
+                  , examples/Project/source-dir/src/*.hs
+                  , examples/Project/source-dir-outside/*.cabal
+                  , examples/Project/src/*.hs
 
 library
   ghc-options:         -O2
test/Main.hs view
@@ -84,7 +84,7 @@ benchTests 
   = forM ["full-1", "full-2", "full-3"] $ \id -> do
       commands <- readFile ("bench-tests" </> id <.> "txt")
-      return $ makeCliTest ([".." </> ".." </> "examples" </> "CppHs"], [], filter (/='\r') commands, expectedOut id)
+      return $ makeCliTest (["examples" </> "CppHs"], [], filter (/='\r') commands, expectedOut id)
 
 expectedOut "full-1" 
   = prefixText cppHsMods ++ "no-module-selected> Language.Preprocessor.Cpphs.CppIfdef> "
@@ -121,7 +121,7 @@             , "Language.Preprocessor.Cpphs.RunCpphs"
             , "Language.Preprocessor.Cpphs" ]
 
-testRoot = ".." </> ".." </> "examples"
+testRoot = "examples"
 
 prefixText :: [String] -> String
 prefixText mods