haskell-tools-cli 0.9.0.0 → 1.0.0.0
raw patch · 17 files changed
+1716/−110 lines, 17 filesdep ~Globdep ~basedep ~ghc
Dependency ranges changed: Glob, base, ghc, haskell-tools-builtin-refactorings, haskell-tools-daemon, haskell-tools-refactor, optparse-applicative, process, time
Files
- Language/Haskell/Tools/Refactor/CLI.hs +48/−35
- benchmark/Main.hs +6/−6
- examples/CppHs/Language/Preprocessor/Cpphs.hs +34/−0
- examples/CppHs/Language/Preprocessor/Cpphs/CppIfdef.hs +416/−0
- examples/CppHs/Language/Preprocessor/Cpphs/HashDefine.hs +129/−0
- examples/CppHs/Language/Preprocessor/Cpphs/MacroPass.hs +184/−0
- examples/CppHs/Language/Preprocessor/Cpphs/Options.hs +156/−0
- examples/CppHs/Language/Preprocessor/Cpphs/Position.hs +106/−0
- examples/CppHs/Language/Preprocessor/Cpphs/ReadFirst.hs +55/−0
- examples/CppHs/Language/Preprocessor/Cpphs/RunCpphs.hs +82/−0
- examples/CppHs/Language/Preprocessor/Cpphs/SymTab.hs +92/−0
- examples/CppHs/Language/Preprocessor/Cpphs/Tokenise.hs +281/−0
- examples/CppHs/Language/Preprocessor/Unlit.hs +72/−0
- exe/Main.hs +6/−31
- haskell-tools-cli.cabal +22/−18
- test-stackage/Main.hs +22/−16
- test/Main.hs +5/−4
Language/Haskell/Tools/Refactor/CLI.hs view
@@ -1,29 +1,30 @@-{-# LANGUAGE LambdaCase - , TupleSections - , FlexibleContexts +{-# LANGUAGE FlexibleContexts , TypeFamilies - , StandaloneDeriving , RecordWildCards + , ScopedTypeVariables #-} -- | The command line interface for Haskell-tools. It uses the Haskell-tools daemon package starting -- the daemon in the same process and communicating with it through a channel. -- It can be used in a one-shot mode, listing all actions in a command-line parameter or using its -- standard input to perform a series of refactorings. module Language.Haskell.Tools.Refactor.CLI - (refactorSession, normalRefactorSession, CLIOptions(..)) where + (refactorSession, normalRefactorSession, CLIOptions(..), SharedDaemonOptions(..)) where import Control.Concurrent +import Control.Exception (BlockedIndefinitelyOnMVar(..), catch) import Control.Monad.State.Strict import Data.List -import Data.List.Split +import Data.List.Split (splitOn) import Data.Maybe import Data.Version (showVersion) -import System.Directory +import System.Directory (getCurrentDirectory) import System.IO +import System.IO.Error (isEOFError) -import Language.Haskell.Tools.Daemon +import Language.Haskell.Tools.Daemon (runDaemon) import Language.Haskell.Tools.Daemon.Mode (channelMode) -import Language.Haskell.Tools.Daemon.Protocol +import Language.Haskell.Tools.Daemon.Options (SharedDaemonOptions(..), DaemonOptions(..)) +import Language.Haskell.Tools.Daemon.Protocol (ResponseMsg(..), ClientMessage(..)) import Language.Haskell.Tools.Refactor import Paths_haskell_tools_cli (version) -- | Normal entry point of the cli. @@ -32,19 +33,17 @@ = do hSetBuffering stdout LineBuffering -- to synch our output with GHC's hSetBuffering stderr LineBuffering -- to synch our output with GHC's refactorSession refactorings - (\st -> void $ forkIO $ runDaemon refactorings channelMode st - (DaemonOptions False 0 (not cliVerbose) cliNoWatch cliWatchExe)) + (\st -> void $ forkIO $ do runDaemon refactorings channelMode st + (DaemonOptions False 0 (not cliVerbose) sharedOptions)) input output options -- | Command-line options for the Haskell-tools CLI data CLIOptions = CLIOptions { displayVersion :: Bool , cliVerbose :: Bool , executeCommands :: Maybe String - , cliNoWatch :: Bool - , cliWatchExe :: Maybe FilePath - , ghcFlags :: Maybe [String] + , sharedOptions :: SharedDaemonOptions , packageRoots :: [FilePath] - } + } deriving Show -- | Entry point with configurable initialization. Mainly for testing, call 'normalRefactorSession' -- to use the command-line. @@ -58,13 +57,11 @@ (recv,send) <- takeMVar connStore -- wait for the server to establish connection wd <- getCurrentDirectory writeChan send (SetWorkingDir wd) - case ghcFlags of Just flags -> writeChan send (SetGHCFlags flags) - Nothing -> return () writeChan send (AddPackages packageRoots) case executeCommands of Just cmds -> performCmdOptions refactorings output send (splitOn ";" cmds) Nothing -> return () - when (isNothing executeCommands) (void $ forkIO $ processUserInput refactorings input output send) + when (isNothing executeCommands) (void $ forkIO $ do processUserInput refactorings input output send) readFromSocket (isJust executeCommands) output recv -- | An initialization action for the daemon. @@ -73,17 +70,28 @@ -- | Reads commands from standard input and executes them. processUserInput :: [RefactoringChoice IdDom] -> Handle -> Handle -> Chan ClientMessage -> IO () processUserInput refactorings input output chan = do - cmd <- hGetLine input - continue <- processCommand False refactorings output chan cmd - when continue $ processUserInput refactorings input output chan + cmd <- hGetLine input + continue <- processCommand False refactorings output chan cmd + when continue $ processUserInput refactorings input output chan + `catch` \e -> if isEOFError e then return () + else putStrLn (show e) >> return () -- | Perform a command received from the user. The resulting boolean states if the user may continue -- (True), or the session is over (False). processCommand :: Bool -> [RefactoringChoice IdDom] -> Handle -> Chan ClientMessage -> String -> IO Bool +processCommand _ _ _ _ "" = return True processCommand shutdown refactorings output chan cmd = do case splitOn " " cmd of ["Exit"] -> writeChan chan Disconnect >> return False + ["AddFile", fn] -> writeChan chan (ReLoad [fn] [] []) >> return True + ["ChangeFile", fn] -> writeChan chan (ReLoad [] [fn] []) >> return True + ["RemoveFile", fn] -> writeChan chan (ReLoad [] [] [fn]) >> return True + [cmd] | cmd `elem` ["AddFile", "ChangeFile", "RemoveFile"] + -> hPutStrLn output (cmd ++ " needs one argument. None is given.") >> return False + cmd:_ | cmd `elem` ["AddFile", "ChangeFile", "RemoveFile"] + -> hPutStrLn output (cmd ++ " needs one argument. Too many arguments given.") >> return False ["Undo"] -> writeChan chan UndoLast >> return True + ["Reset"] -> writeChan chan Reset >> return True -- undocumented feature ref : rest | let modPath:selection:details = rest ++ (replicate (2 - length rest) "") , ref `elem` refactorCommands refactorings -> do writeChan chan (PerformRefactoring ref modPath selection details shutdown False) @@ -92,36 +100,41 @@ , ref `elem` refactorCommands refactorings -> do writeChan chan (PerformRefactoring ref modPath selection details shutdown True) return (not shutdown) - _ -> do liftIO $ hPutStrLn output $ "'" ++ cmd ++ "' is not a known command. Commands are: Exit, " - ++ intercalate ", " (refactorCommands refactorings) + ["Try"] -> hPutStrLn output "The 'Try' modifier requires a refactoring command specified to execute." >> return False + _ -> do liftIO $ hPutStrLn output $ "'" ++ cmd ++ "' is not a known command. Commands are: Exit, Undo, AddFile, ChangeFile, RemoveFile, Try REFACTOR" + ++ concat (map (", " ++) (refactorCommands refactorings)) return True -- | Read the responses of the daemon. The result states if the session exited normally or in an -- erronous way. readFromSocket :: Bool -> Handle -> Chan ResponseMsg -> IO Bool readFromSocket pedantic output recv = do - continue <- readChan recv >>= processMessage pedantic output - maybe (readFromSocket pedantic output recv) return continue -- repeate if not stopping + continue <- readChan recv >>= processMessage pedantic output + maybe (readFromSocket pedantic output recv) return continue -- repeate if not stopping + `catch` \(_ :: BlockedIndefinitelyOnMVar) -> return False -- other threads terminated -- | Receives a single response from daemon. Returns Nothing if the execution should continue, -- Just False on erronous termination and Just True on normal termination. processMessage :: Bool -> Handle -> ResponseMsg -> IO (Maybe Bool) processMessage _ output (ErrorMessage msg) = hPutStrLn output msg >> return (Just False) -processMessage pedantic output (CompilationProblem marks) - = do hPutStrLn output (show marks) +processMessage pedantic output (CompilationProblem marks hints) + = do mapM_ (hPutStrLn output) hints + mapM_ (\(loc, msg) -> hPutStrLn output (shortShowSpanWithFile loc ++ ": " ++ msg)) marks return (if pedantic then Just False else Nothing) -processMessage _ output (LoadedModules mods) - = do mapM (\(fp,name) -> hPutStrLn output $ "Loaded module: " ++ name ++ "( " ++ fp ++ ") ") mods +processMessage _ output (LoadedModule fp name) + = do hPutStrLn output $ "Loaded module: " ++ name ++ "( " ++ fp ++ ") " return Nothing processMessage _ output (DiffInfo diff) - = do putStrLn diff + = do hPutStrLn output diff return Nothing +processMessage _ output (LoadingModules mods) + = do hPutStrLn output $ "Found modules: " ++ intercalate ", " mods + return Nothing processMessage _ output (UnusedFlags flags) - = if not $ null flags - then do hPutStrLn output $ "Error: The following ghc-flags are not recognized: " - ++ intercalate " " flags - return $ Just False - else return Nothing + = do hPutStrLn output $ "Warning: The following ghc-flags are not recognized: " + ++ intercalate " " flags + return Nothing + processMessage _ _ Disconnected = return (Just True) processMessage _ _ _ = return Nothing
benchmark/Main.hs view
@@ -1,7 +1,5 @@ -{-# LANGUAGE LambdaCase - , ViewPatterns - , TypeFamilies +{-# LANGUAGE TypeFamilies , RecordWildCards , DeriveGeneric #-} @@ -26,8 +24,10 @@ import System.FilePath (FilePath, (</>)) import System.IO +import Language.Haskell.Tools.Daemon.Options (SharedDaemonOptions(..)) +import Language.Haskell.Tools.Daemon.PackageDB (PackageDB(..)) import Language.Haskell.Tools.Refactor.Builtin (builtinRefactorings) -import Language.Haskell.Tools.Refactor.CLI +import Language.Haskell.Tools.Refactor.CLI (CLIOptions(..), normalRefactorSession) rootDir = "examples" @@ -126,7 +126,7 @@ bm2Mcase d bm = BMCase bm <$> (bm2Mms bm) <*> (return d) benchmakable :: String -> [String] -> Benchmarkable -- IO (Either String String) -benchmakable wd rfs = Benchmarkable $ \ _ -> do +benchmakable wd rfs = toBenchmarkable $ \ _ -> do makeCliTest wd rfs makeCliTest :: String -> [String] -> IO () @@ -137,7 +137,7 @@ outKnob <- newKnob (BS.pack []) outHandle <- newFileHandle outKnob "<output>" WriteMode void $ normalRefactorSession builtinRefactorings inHandle outHandle - (CLIOptions False Nothing True Nothing Nothing [wd]) + (CLIOptions False False Nothing (SharedDaemonOptions True Nothing False False Nothing (Just DefaultDB)) [wd]) `finally` do removeDirectoryRecursive wd renameDirectory (wd ++ "_orig") wd
+ 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:)) +
exe/Main.hs view
@@ -1,15 +1,13 @@ module Main where +import Control.Monad ((=<<)) +import Data.Semigroup ((<>)) +import Options.Applicative +import Options.Applicative.Types (Parser) import System.Exit (exitSuccess, exitFailure) import System.IO (IO, stdout, stdin) -import Options.Applicative -import Options.Applicative.Types -import Control.Monad -import Control.Monad.Reader -import Data.Semigroup ((<>)) -import Data.List -import Data.List.Split +import Language.Haskell.Tools.Daemon.Options (sharedOptionsParser) import Language.Haskell.Tools.Refactor.Builtin (builtinRefactorings) import Language.Haskell.Tools.Refactor.CLI (normalRefactorSession, CLIOptions(..)) @@ -24,7 +22,7 @@ <> header "ht-refact: a command-line interface for Haskell-tools") cliOptions :: Parser CLIOptions -cliOptions = CLIOptions <$> version <*> verb <*> oneShot <*> noWatch <*> watch <*> ghcFlags +cliOptions = CLIOptions <$> version <*> verb <*> oneShot <*> sharedOptionsParser <*> packages where version = switch (long "version" <> short 'v' @@ -36,28 +34,5 @@ <> short 'e' <> metavar "COMMAND" <> help "Commands to execute in a one-shot refactoring run, separated by semicolons.") - noWatch = switch (long "no-watch" - <> help "Disables file system watching.") - watch = optional $ strOption - (long "watch-exe" - <> short 'w' - <> help "The file path of the watch executable that is used to monitor file system changes." - <> metavar "WATH_PATH") - ghcFlags - = optional $ option ghcFlagsParser - (long "ghc-options" - <> short 'g' - <> metavar "GHC_OPTIONS" - <> help "Flags passed to GHC when loading the packages, separated by spaces.") - where ghcFlagsParser :: ReadM [String] - ghcFlagsParser - = ReadM $ do str <- ask - let str' = case str of '=':rest -> rest - other -> other - let splitted = splitOn " " str' - let wrong = filter (not . isPrefixOf "-") splitted - when (not $ null wrong) - $ fail ("The following arguments passed as ghc-options are not flags: " ++ intercalate " " wrong) - return splitted packages = many $ strArgument (metavar "PACKAGE_ROOT" <> help "The root folder of packages that are refactored")
haskell-tools-cli.cabal view
@@ -1,5 +1,5 @@ name: haskell-tools-cli -version: 0.9.0.0 +version: 1.0.0.0 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 @@ -12,21 +12,23 @@ cabal-version: >=1.10 extra-source-files: examples/example-project/*.hs + , examples/CppHs/Language/Preprocessor/*.hs + , examples/CppHs/Language/Preprocessor/Cpphs/*.hs library - build-depends: base >= 4.9 && < 4.10 + build-depends: base >= 4.10 && < 4.11 , containers >= 0.5 && < 0.6 , mtl >= 2.2 && < 2.3 , split >= 0.2 && < 0.3 , directory >= 1.2 && < 1.4 , filepath >= 1.4 && < 2 - , ghc >= 8.0 && < 8.1 + , ghc >= 8.2 && < 8.3 , ghc-paths >= 0.1 && < 0.2 , references >= 0.3 && < 0.4 , strict >= 0.3 && < 0.4 - , haskell-tools-refactor >= 0.9 && < 0.10 - , haskell-tools-builtin-refactorings >= 0.9 && < 0.10 - , haskell-tools-daemon >= 0.9 && < 0.10 + , haskell-tools-refactor >= 1.0 && < 1.1 + , haskell-tools-builtin-refactorings >= 1.0 && < 1.1 + , haskell-tools-daemon >= 1.0 && < 1.1 exposed-modules: Language.Haskell.Tools.Refactor.CLI , Paths_haskell_tools_cli default-language: Haskell2010 @@ -34,14 +36,15 @@ executable ht-refact ghc-options: -rtsopts - build-depends: base >= 4.9 && < 4.10 + build-depends: base >= 4.10 && < 4.11 , split >= 0.2 && < 0.3 , mtl >= 2.2 && < 2.3 , directory >= 1.2 && < 1.4 , filepath >= 1.4 && < 2.0 - , optparse-applicative >= 0.13 && < 0.14 + , optparse-applicative >= 0.14 && < 0.15 , haskell-tools-cli - , haskell-tools-builtin-refactorings >= 0.9 && < 0.10 + , haskell-tools-daemon >= 1.0 && < 1.1 + , haskell-tools-builtin-refactorings >= 1.0 && < 1.1 hs-source-dirs: exe main-is: Main.hs default-language: Haskell2010 @@ -51,7 +54,7 @@ ghc-options: -with-rtsopts=-M2g hs-source-dirs: test main-is: Main.hs - build-depends: base >= 4.9 && < 4.10 + build-depends: base >= 4.10 && < 4.11 , tasty >= 0.11 && < 0.12 , tasty-hunit >= 0.9 && < 0.10 , directory >= 1.2 && < 1.4 @@ -59,17 +62,17 @@ , knob >= 0.1 && < 0.2 , bytestring >= 0.10 && < 0.11 , haskell-tools-cli - , haskell-tools-builtin-refactorings >= 0.9 && < 0.10 + , haskell-tools-builtin-refactorings >= 1.0 && < 1.1 default-language: Haskell2010 executable ht-test-stackage - build-depends: base >= 4.9 && < 4.10 + build-depends: base >= 4.10 && < 4.11 , directory >= 1.2 && < 1.4 - , process >= 1.4 && < 1.5 + , process >= 1.6 && < 1.7 , split >= 0.2 && < 0.3 , filepath >= 1.4 && < 2.0 - , optparse-applicative >= 0.13 && < 0.14 - , Glob >= 0.8 && < 0.9 + , optparse-applicative >= 0.14 && < 0.15 + , Glob >= 0.9 && < 0.10 ghc-options: -threaded hs-source-dirs: test-stackage main-is: Main.hs @@ -78,9 +81,9 @@ benchmark cli-benchmark type: exitcode-stdio-1.0 ghc-options: -with-rtsopts=-M2g - build-depends: base >= 4.9 && < 4.10 + build-depends: base >= 4.10 && < 4.11 , criterion >= 1.1 && < 1.3 - , time >= 1.6 && < 1.7 + , time >= 1.6 && < 1.9 , aeson >= 1.0 && < 1.3 , directory >= 1.2 && < 1.4 , filepath >= 1.4 && < 2.0 @@ -88,7 +91,8 @@ , bytestring >= 0.10 && < 0.11 , split >= 0.2 && < 0.3 , haskell-tools-cli - , haskell-tools-builtin-refactorings >= 0.9 && < 0.10 + , haskell-tools-builtin-refactorings >= 1.0 && < 1.1 + , haskell-tools-daemon >= 1.0 && < 1.1 hs-source-dirs: benchmark main-is: Main.hs default-language: Haskell2010
test-stackage/Main.hs view
@@ -1,23 +1,20 @@ {-# LANGUAGE LambdaCase , TypeApplications - , TupleSections , ScopedTypeVariables #-} module Main where import Control.Applicative ((<$>)) -import Control.Concurrent (threadDelay) -import Control.Exception +import Control.Exception (SomeException, try) import Control.Monad import Data.List -import Options.Applicative -import Data.Semigroup ((<>)) import Data.List.Split (splitOn) -import System.Directory -import System.FilePath -import System.FilePath.Glob (glob) -import System.Environment (getArgs) +import Data.Semigroup ((<>)) +import Options.Applicative +import System.Directory (removeDirectoryRecursive, getCurrentDirectory, createDirectoryIfMissing) import System.Exit (ExitCode(..)) +import System.FilePath (FilePath, (</>)) +import System.FilePath.Glob () import System.Process main :: IO () @@ -28,11 +25,13 @@ <> header "ht-test-stackage: a tester utility for Haskell-tools") options :: Parser StackageTestConfig -options = StackageTestConfig <$> noload <*> noretest <*> result <*> srcdir <*> logdir <*> inputfile +options = StackageTestConfig <$> noload <*> noretest <*> noclean <*> result <*> srcdir <*> logdir <*> inputfile <*> snapshot where noload = switch (long "no-load" <> help "Don't download the package, use the existing sources.") noretest = switch (long "no-retest" <> help "Don't run the test on packages already in the results file.") + noclean = switch (long "no-clean" + <> help "Keep the refactored files.") srcdir = strOption (long "src-dir" <> short 't' @@ -47,6 +46,10 @@ <> showDefault <> value "stackage-test-logs" <> help "The directory where the log files should be stored.") + snapshot + = optional (strOption (long "snapshot" + <> metavar "SNAPSHOT" + <> help "The stackage snapshots identifier.")) result = strOption (long "result" <> short 'r' @@ -59,10 +62,12 @@ data StackageTestConfig = StackageTestConfig { noLoad :: Bool , noRetest :: Bool + , noClean :: Bool , resultFile :: FilePath , sourceDirectory :: FilePath , logDirectory :: FilePath , inputFile :: FilePath + , stackageSnapshot :: Maybe String } testStackage :: StackageTestConfig -> IO () @@ -78,21 +83,22 @@ createDirectoryIfMissing False (logDirectory config) mapM_ testAndEvaluate filteredPackages where testAndEvaluate p = do - (res, problem) <- testPackage (noLoad config) (sourceDirectory config) (logDirectory config) p + (res, problem) <- testPackage (noLoad config) (noClean config) (sourceDirectory config) + (logDirectory config) (stackageSnapshot config) p appendFile (resultFile config) (p ++ ";" ++ show res ++ " ; " ++ problem ++ "\n") -testPackage :: Bool -> FilePath -> FilePath -> String -> IO (Result, String) -testPackage noLoad sourceDirectory logDirectory pack = do +testPackage :: Bool -> Bool -> FilePath -> FilePath -> Maybe String -> String -> IO (Result, String) +testPackage noLoad noClean sourceDirectory logDirectory resolver pack = do baseDir <- getCurrentDirectory let pkgLoc = baseDir </> sourceDirectory </> pack buildLogPath = baseDir </> logDirectory </> (pack ++ "-build-log.txt") refLogPath = baseDir </> logDirectory </> (pack ++ "-refact-log.txt") reloadLogPath = baseDir </> logDirectory </> (pack ++ "-reload-log.txt") - res <- runCommands (cleanup pkgLoc) + res <- runCommands (if noClean then return () else cleanup pkgLoc) $ init ++ load - ++ [ Left ("stack init > " ++ buildLogPath ++ " 2>&1", pkgLoc, BuildFailure) + ++ [ Left ("stack init" ++ (maybe "" (" --resolver="++) resolver) ++ " > " ++ buildLogPath ++ " 2>&1", pkgLoc, BuildFailure) , Left ("stack build --test --no-run-tests --bench --no-run-benchmarks --ghc-options=\"-w\" > " ++ buildLogPath ++ " 2>&1", pkgLoc, BuildFailure) -- correct rts option handling (on windows) requires stack 1.4 @@ -108,7 +114,7 @@ return (res, problem) where load = if noLoad then [] - else [ Right $ (either (\(e :: SomeException) -> return ()) return =<<) + else [ Right $ (either (\(_ :: SomeException) -> return ()) return =<<) $ try (removeDirectoryRecursive (sourceDirectory </> pack)) , Left ("cabal get -d " ++ sourceDirectory ++ " " ++ pack, ".", GetFailure) ] init = [ Right (forM_ [sourceDirectory,logDirectory] (createDirectoryIfMissing True)) ]
test/Main.hs view
@@ -12,7 +12,7 @@ import System.IO import Language.Haskell.Tools.Refactor.Builtin (builtinRefactorings) -import Language.Haskell.Tools.Refactor.CLI +import Language.Haskell.Tools.Refactor.CLI (SharedDaemonOptions(..), CLIOptions(..), normalRefactorSession) main :: IO () main = defaultMain allTests @@ -22,11 +22,12 @@ = testGroup "cli-tests" [ makeCliTest ( "batch", ["examples"</>"example-project"] , \s -> CLIOptions False False (Just $ "RenameDefinition " ++ "examples"</>("example-project"++s)</>"Demo.hs" ++ " 3:1 b") - True Nothing Nothing + (SharedDaemonOptions True Nothing False False Nothing Nothing) , \_ -> "" , \s _ -> checkFileContent ("examples"</>("example-project"++s)</>"Demo.hs") ("b = ()" `List.isInfixOf`)) - , makeCliTest ( "session", ["examples"</>"example-project"], \_ -> CLIOptions False False Nothing True Nothing Nothing + , makeCliTest ( "session", ["examples"</>"example-project"] + , \_ -> CLIOptions False False Nothing (SharedDaemonOptions True Nothing False False Nothing Nothing) , \s -> "RenameDefinition " ++ "examples"</>("example-project"++s)</>"Demo.hs" ++ " 3:1 b\nExit\n" , \s _ -> checkFileContent ("examples"</>("example-project"++s)</>"Demo.hs") ("b = ()" `List.isInfixOf`)) @@ -42,7 +43,7 @@ inHandle <- newFileHandle inKnob "<input>" ReadMode outKnob <- newKnob (pack []) outHandle <- newFileHandle outKnob "<output>" WriteMode - res <- normalRefactorSession builtinRefactorings inHandle outHandle (args suffix testdirs) + normalRefactorSession builtinRefactorings inHandle outHandle (args suffix testdirs) actualOut <- Data.Knob.getContents outKnob assertBool ("The result is not what is expected. Output: " ++ (unpack actualOut)) =<< outputCheck suffix (unpack actualOut)