#!/usr/bin/runhugs +l


Written by Ian Lynagh <igloo@debian.org>.
Copyright (C) 2003, 2004 Ian Lynagh.
Released under the GNU GPL version 2.

\begin{code}
module Main (main) where

import Control.Monad (when, unless)
import Data.Char (isAlphaNum, isAlpha)
import System.Directory (doesFileExist)
import System.Environment (getArgs)
import System.Exit (ExitCode(ExitSuccess, ExitFailure), exitWith)
import System.IO (hPutStrLn, stderr)



import Text.Regex (mkRegex, matchRegex)


type Mapping = [(String, String)]
data Pos = Pos !Int !Int

data Verbosity = Quiet | Normal | Verbose
    deriving Eq
data Action = Update | Check
data Flags = Flags { action :: Action,
                     verbosity :: Verbosity,
                     input_file :: Maybe FilePath,
                     output_file :: Maybe FilePath,
                     include_paths :: [FilePath] }
           | HelpFlag
           | VersionFlag
           | ErrorFlag String

show_pos :: Pos -> String
show_pos (Pos c l) = "line " ++ show l ++ ", character " ++ show c

parse_args :: [String] -> Flags
parse_args = pa (Flags Update Normal Nothing Nothing ["/usr/lib/haskell-utils"])
    where pa fs []
           = let fs1 = case input_file fs of
                           Nothing ->
                               fs { input_file = Just "debian/control.in" }
                           _ -> fs
                 fs2 = case (input_file fs1, output_file fs1) of
                       (Just i, Nothing) ->
                         case break ('.' ==) (reverse i) of
                         ("ni", '.':rfn) ->
                             fs1 { output_file = Just (reverse rfn) }
                         _ -> ErrorFlag "Output filename not given or deducable"
                       _ -> fs1
             in fs2
          pa _ ("--help":_) = HelpFlag
          pa _ ("-h":_) = HelpFlag
          pa _ ("--version":_) = VersionFlag
          pa _ ("-V":_) = VersionFlag
          pa fs ("--update":as) = pa (fs { action = Update }) as
          pa fs ("--check":as) = pa (fs { action = Check }) as
          pa fs ("-v":as) = pa (fs { verbosity = Verbose }) as
          pa fs ("-q":as) = pa (fs { verbosity = Quiet }) as
          pa fs ("-I":d:as) = pa (fs { include_paths = d:include_paths fs }) as
          pa _ ["-I"] = ErrorFlag "Missing argument to -I"
          pa fs ("-i":f:as) = case input_file fs of
                                  Nothing -> pa (fs { input_file = Just f }) as
                                  Just _ -> ErrorFlag "Two input files given"
          pa _ ["-i"] = ErrorFlag "Missing argument to -i"
          pa fs ("-o":f:as) = case output_file fs of
                                  Nothing -> pa (fs { output_file = Just f }) as
                                  Just _ -> ErrorFlag "Two output files given"
          pa _ ["-o"] = ErrorFlag "Missing argument to -o"
          pa _ (a:_) = ErrorFlag ("Unknown argument: " ++ a)

main :: IO ()
main = do args <- getArgs
          case parse_args args of
              ErrorFlag s -> do hPutStrLn stderr s
                                exitWith (ExitFailure 1)
              HelpFlag -> usage
              VersionFlag -> show_version
              Flags Update v (Just i) (Just o) ps -> update v i o ps
              Flags Check  v (Just i) (Just o) _  -> check  v i o
              _ -> error "update-haskell-control: Can't happen"

check :: Verbosity -> FilePath -> FilePath -> IO ()
check v i o
 = do when (v == Verbose) $ do putStrLn $ "Input filename: " ++ i
                               putStrLn $ "Check filename: " ++ o
      inp <- readFile i
      out <- readFile o
      let inp' = number inp
          (re, warnings) = mk_regexp inp'

          re' = mkRegex re

      unless (v == Quiet) $ mapM_ putStrLn warnings
      when (v == Verbose) $ do putStrLn "Regexp:"
                               putStrLn re



      case matchRegex re' out of

          Nothing -> do putStrLn "File mismatch!"
                        exitWith (ExitFailure 1)
          _ -> exitWith ExitSuccess

update :: Verbosity -> FilePath -> FilePath -> [FilePath] -> IO ()
update v i o ps
 = do when (v == Verbose) $ do putStrLn $ "Input filename: " ++ i
                               putStrLn $ "Output filename: " ++ o
                               putStrLn $ "Search path:"
                               mapM_ (putStrLn . ("  " ++)) ps
      inp <- readFile i
      mss <- mapM (get_varmappings v ps) ["ghc6", "ghc5", "nhc98", "hugs"]
      let ms = concat mss
      let inp' = number inp
          (inp'', warnings) = apply ms inp'
      unless (v == Quiet) $ mapM_ putStrLn warnings
      writeFile o inp''

get_varmappings :: Verbosity -> [FilePath] -> FilePath -> IO Mapping
get_varmappings v [] f
 = do unless (v == Quiet) $ putStrLn $ f ++ " varfile not found"
      return []
get_varmappings v (p:ps) f
 = do let f' = p ++ "/" ++ f ++ "_vars"
      exists <- doesFileExist f'
      if exists
        then do when (v == Verbose) $ putStrLn $ "Loading " ++ f'
                xs <- readFile f'
                let mes = map mk_maplet $ zip [1..] $ filter ("" /=) $ lines xs
                    es = [ e | Right e <- mes ]
                    ms = [ m | Left m <- mes ]
                if null es
                  then do return ms
                  else do mapM_ (hPutStrLn stderr) es
                          exitWith (ExitFailure 1)
        else do when (v == Verbose) $ putStrLn $ f' ++ " not found"
                get_varmappings v ps f

mk_maplet :: (Int, String) -> Either (String, String) String
mk_maplet (n, xs) = case break ('=' ==) xs of
                        ("", _) -> Right $ "No variable name on line " ++ s
                        (ys, '=':'"':zs) -> case read_val "" zs of
                                                Left zs' -> Left (ys, zs')
                                                Right err -> Right err
                        _ -> Right bvb
    where s = show n
          read_val acc "\"" = Left (reverse acc)
          read_val _   [] = Right bvb
          read_val _   [_] = Right bvb
          read_val acc ('\\':'n':ys) = read_val ('\n':acc) ys
          read_val acc ('\\':y:ys) = read_val (y:acc) ys
          read_val acc (y:ys) = read_val (y:acc) ys
          bvb = "Bad variable binding on line " ++ s

number :: String -> [(Char, Pos)]
number = f (Pos 1 1)
    where f _ "" = []
          f p@(Pos _ l) ('\n':xs) = seq p $ ('\n', p):f (Pos 1 (l+1)) xs
          f p@(Pos c l) (x:xs) = seq p $ (x, p):f (Pos (c+1) l) xs

apply :: Mapping -> [(Char, Pos)] -> (String, [String])
apply m = f "" []
    where f res ws [] = (reverse res, reverse ws)
          f res ws (('\\', _):(x, _):xs) = f (x:res) ws xs
          f res ws [('$', p)] = f ('$':res) (bvs p:ws) []
          f res ws (('$', p):xs)
           = case get_var_name xs of
                 Nothing -> f ('$':res) (bvs p:ws) xs
                 Just (n, xs') -> case lookup n m of
                                      Nothing -> f ('$':res) (uv n p:ws) xs
                                      Just v ->
                                          f res ws (map (\c -> (c, p)) v ++ xs')
          f res ws ((x, _):xs) = f (x:res) ws xs
          bvs p = "Bad variable spec at " ++ show_pos p
          uv v p = "Unbound variable " ++ v ++ " at " ++ show_pos p

mk_regexp :: [(Char, Pos)] -> (String, [String])
mk_regexp = f "" []
    where f res ws [] = ("^" ++ reverse res ++ "$", reverse ws)
          f res ws (('\\', _):('n', _):xs) = f ('\n':res) ws xs
          f res ws (('\\', _):(x, _):xs) = f (esc x ++ res) ws xs
          f res ws [('$', p)] = f ("$\\" ++ res) (bvs p:ws) []
          f res ws (('$', p):xs)
           = case get_var_name xs of
                 Nothing -> f ("$\\" ++ res) (bvs p:ws) xs
                 Just (_, xs') -> f ("*." ++ res) ws xs'
          f res ws ((x, _):xs) = f (esc x ++ res) ws xs
          bvs p = "Bad variable spec at " ++ show_pos p
          esc c | c `elem` ".[\\(*+?{|^$" = [c, '\\']
                | otherwise               = [c]

get_var_name :: [(Char, Pos)] -> Maybe (String, [(Char, Pos)])
get_var_name (('{', _):xs) = case break (('}' ==) . fst) xs of
                                 (ys, _:zs) -> Just (map fst ys, zs)
                                 _ -> Nothing
get_var_name xs@((c, _):_)
 | isAlpha c = case span (\(x, _) -> isAlphaNum x || x == '_') xs of
                   (ys, zs) -> Just (map fst ys, zs)
get_var_name _ = Nothing

usage :: IO ()
usage =
    do putStrLn "Usage: update-haskell-control [ --help | -h | --version | -V ]"
       putStrLn "       update-haskell-control [ OPTION ]..."
       putStrLn ""
       putStrLn "   --update       Update output filename (default)"
       putStrLn "   --check        Check output filename"
       putStrLn "   -i filename    Input filename"
       putStrLn "   -o filename    Output filename"
       putStrLn "   -I path        Add search path"
       putStrLn "   -v             Verbose"
       putStrLn "   -q             Input filename"
       putStrLn ""

show_version :: IO ()
show_version = do putStrLn "update-haskell-control 1.6"
                  putStrLn "Written by Ian Lynagh."
                  putStrLn "Copyright (C) 2004 Ian Lynagh."
\end{code}

