-- Based on DrIFT 1.0 by Noel Winstanley

-- hacked for Haskell 98 by Malcolm Wallace, University of York, Feb 1999.

-- modified by various people, now maintained by John Meacham

module Main(main) where

import ChaseImports

import UserRules

-- import StandardRules

import RuleUtils (commentLine,texts)

import PreludData(preludeData)

import DataP

import Pretty

import List (partition,isSuffixOf,sort, groupBy, sortBy)

import qualified System

import IO hiding(try)

import GetOpt

import Monad(unless)

import RuleUtils(Rule,Tag)

import Version

import GenUtil

data Op = OpList | OpDerive | OpVersion

data Env = Env {

envVerbose :: Bool,

envOutput :: (Maybe String),

envOperation :: Op,

envNoline :: Bool,

envArgs :: [(String,String)],

envResultsOnly :: Bool,

envGlobalRules :: [Tag],

envIgnoreDirectives :: Bool

}

env = Env {

envVerbose = False,

envOutput = Nothing,

envOperation = OpDerive,

envNoline = False,

envArgs = [],

envResultsOnly = False,

envIgnoreDirectives = False,

envGlobalRules = []

}

getOutput e = maybe (return stdout) (\fn -> openFile fn WriteMode) (envOutput e)

options :: [OptDescr (Env -> Env)]

options =

[ Option ['v'] ["verbose"] (NoArg (\e->e{envVerbose = True})) "chatty output on stderr"

, Option ['V'] ["version"] (NoArg (\e->e{envOperation = OpVersion})) "show version number"

, Option ['l'] ["list"] (NoArg (\e->e{envOperation = OpList})) "list available derivations"

, Option ['L'] ["noline"] (NoArg (\e->e{envNoline = True})) "omit line pragmas from output"

, Option ['o'] ["output"] (ReqArg (\x e->e{envOutput = (Just x)}) "FILE") "output FILE"

, Option ['s'] ["set"] (ReqArg setArg "name:value") "set argument to value"

, Option ['r'] ["resultsonly"] (NoArg (\e->e{envResultsOnly = True})) "output only results, do not include source file"

, Option ['g'] ["global"] (ReqArg addGlobalRule "rule") "addition rules to apply globally"

, Option ['i'] ["ignore"] (NoArg (\e->e{envIgnoreDirectives = True})) "ignore directives in file. useful with -g"

]

setArg x e = e {envArgs = (n, tail rest):(envArgs e)} where

(n,rest) = span (/= ':') x

addGlobalRule x e = e {envGlobalRules = x:(envGlobalRules e)}

categorize :: Ord c => [(c,a)] -> [(c,[a])]

categorize xs = map f $ groupBy fstEq $ sortBy fstOrd xs where

f ys = (fst (head ys),snds ys)

fstEq (a,_) (b,_) = a == b

fstOrd (a,_) (b,_) = compare a b

doList = do

let rn = categorize [(c,(n,h)) | (n,_,c,h,_) <- userRules] -- ++ standardRules

putStrLn $ unlines $ buildTableLL $ concat [ (c ++ ":","") : (map (\(a,b) -> (" " ++ a, b)) $ sort xs)| (c,xs)<- rn]

header = "Usage: DrIFT [OPTION...] file"

main = do

argv <- System.getArgs

(env,n) <- case (getOpt Permute options argv) of

(as,n,[]) -> return (foldr ($) env as ,n)

(_,_,errs) -> putErrDie (concat errs ++ usageInfo header options)

case env of

Env { envOperation = OpList } -> doList

Env { envOperation = OpVersion} -> putStr ("Version " ++ fullName ++ "\n")

_ -> case n of

[n] -> derive env n

_ -> putErrDie ("single input file must be specified.\n" ++ usageInfo header options)

derive env fname = do

file <- readFile fname

handle <- getOutput env

hPutStr handle $ "{- Generated by " ++ package ++ " (Automatic class derivations for Haskell) -}\n"

unless (envNoline env) $ hPutStr handle $ "{-# LINE 1 \"" ++ fname ++ "\" #-}\n"

let

(body,_) = userCode file

b = ".lhs" `isSuffixOf` fname --isLiterate body

(docs,dats,todo) = process . addGlobals env . parser . fromLit b $ body

moreDocs <- fmap ((\(x,_,_) -> x) . process) (chaseImports body todo)

let

result = toLit b . (\r -> codeSeperator ++ '\n':r) .

render . vsep $ (docs ++ sepDoc:moreDocs)

unless (envResultsOnly env) $ hPutStr handle body

hPutStr handle result

addGlobals env tds = (envGlobalRules env,Directive):concatMap f tds where

f x | not (envIgnoreDirectives env) = [x]

f (_,Directive) = []

f (_,TypeName _) = []

f (_,d) = [([],d)]

rules = map (\(a,b,_,_,_) -> (a,b)) $ userRules -- ++ standardRules

-- codeRender doc = fullRender PageMode 80 1 doc "" -- now obsolete

vsep = vcat . map ($$ (text ""))

sepDoc = commentLine . text $ " Imported from other files :-"

backup :: FilePath -> FilePath

backup f = (reverse . dropWhile (/= '.') . reverse ) f ++ "bak"

newfile :: FilePath -> FilePath

newfile f = (reverse . dropWhile (/= '.') . reverse ) f ++ "DrIFT"

-- Main Pass - Takes parsed data and rules and combines to create instances...

-- Returns all parsed data, ande commands calling for files to be imported if

-- datatypes aren't located in this module.

process :: ToDo -> ([Doc],[Data],ToDo)

process i = (concatMap g dats ++ concatMap h moreDats,parsedData,imports)

where

g (tags,d) = [(find t rules) d | t <- (tags ++ directives)]

h (tags,d) = [(find t rules) d | t <- tags]

directives = concatMap fst globals

(dats,commands) = partition (isData . snd) i

(globals,fors) = partition (\(_,d) -> d == Directive) commands

(moreDats,imports) = resolve parsedData fors ([],[])

parsedData = map snd dats ++ preludeData

find :: Tag -> [Rule] -> (Data -> Doc)

find t r = case filter ((==t) . fst) $ r of

[] -> const (commentLine warning)

(x:xs) -> snd x

where

warning = hsep . texts $ ["Warning : Rule",t,"not found."]