076b559b2ea7b2f1d303df992ae71cd6c6fe563cChristian Maeder-- Based on DrIFT 1.0 by Noel Winstanley

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

81d182b21020b815887e9057959228546cf61b6bChristian Maeder-- modified by various people, now maintained by John Meacham

076b559b2ea7b2f1d303df992ae71cd6c6fe563cChristian Maedermodule Main(process,main,envGlobalRules,env,addGlobals) where

98890889ffb2e8f6f722b00e265a211f13b5a861Corneliu-Claudiu Prodescuimport ChaseImports

076b559b2ea7b2f1d303df992ae71cd6c6fe563cChristian Maederimport UserRules

3f69b6948966979163bdfe8331c38833d5d90ecdChristian Maederimport StandardRules

076b559b2ea7b2f1d303df992ae71cd6c6fe563cChristian Maederimport RuleUtils (commentLine,texts)

076b559b2ea7b2f1d303df992ae71cd6c6fe563cChristian Maederimport PreludData(preludeData)

f3a94a197960e548ecd6520bb768cb0d547457bbChristian Maederimport DataP

5b1f1d57c75562a7af79e8256f4afa07febe921bChristian Maederimport Pretty

568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederimport List (partition,isSuffixOf,sort)

568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederimport qualified System

e8ffec0fa3d3061061bdc16e44247b9cf96b050fChristian Maederimport IO hiding(try)

568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederimport GetOpt

e8ffec0fa3d3061061bdc16e44247b9cf96b050fChristian Maederimport Monad(unless)

e8ffec0fa3d3061061bdc16e44247b9cf96b050fChristian Maederimport RuleUtils(Rule,Tag)

e8ffec0fa3d3061061bdc16e44247b9cf96b050fChristian Maederimport Version

10b02b2343246df6773585636fe3ddbefa3b6a1bChristian Maeder

076b559b2ea7b2f1d303df992ae71cd6c6fe563cChristian Maederdata Op = OpList | OpDerive | OpVersion

10b02b2343246df6773585636fe3ddbefa3b6a1bChristian Maeder

35db0960aa2e2a13652381c756fae5fb2b27213bChristian Maederdata Env = Env {

568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder envVerbose :: Bool,

ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder envOutput :: (Maybe String),

ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder envOperation :: Op,

5b1f1d57c75562a7af79e8256f4afa07febe921bChristian Maeder envNoline :: Bool,

5b1f1d57c75562a7af79e8256f4afa07febe921bChristian Maeder envArgs :: [(String,String)],

5b1f1d57c75562a7af79e8256f4afa07febe921bChristian Maeder envResultsOnly :: Bool,

5b1f1d57c75562a7af79e8256f4afa07febe921bChristian Maeder envGlobalRules :: [Tag]

568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder }

99f16a0f9ca757410960ff51a79b034503384fe2Christian Maeder

5b1f1d57c75562a7af79e8256f4afa07febe921bChristian Maeder

99f16a0f9ca757410960ff51a79b034503384fe2Christian Maederenv = Env {

6e5180855658f12f9059d9041f447bf0935de344Christian Maeder envVerbose = False,

5b1f1d57c75562a7af79e8256f4afa07febe921bChristian Maeder envOutput = Nothing,

8a1f427564a5ae2db32332512237ef645289c34dChristian Maeder envOperation = OpDerive,

76647324ed70f33b95a881b536d883daccf9568dChristian Maeder envNoline = False,

76647324ed70f33b95a881b536d883daccf9568dChristian Maeder envArgs = [],

76647324ed70f33b95a881b536d883daccf9568dChristian Maeder envResultsOnly = False,

4e013227ed41ccd2e3d09dd44bedd651e1901f38Christian Maeder envGlobalRules = []

568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder }

5b1f1d57c75562a7af79e8256f4afa07febe921bChristian Maeder

76fa667489c5e0868ac68de9f0253ac10f73d0b5Christian MaederputErrDie s = hPutStr stderr s >> System.exitFailure

76647324ed70f33b95a881b536d883daccf9568dChristian MaederexitSuccess = System.exitWith System.ExitSuccess

76fa667489c5e0868ac68de9f0253ac10f73d0b5Christian Maeder

5b1f1d57c75562a7af79e8256f4afa07febe921bChristian MaedergetOutput e = maybe (return stdout) (\fn -> openFile fn WriteMode) (envOutput e)

76fa667489c5e0868ac68de9f0253ac10f73d0b5Christian Maeder

76647324ed70f33b95a881b536d883daccf9568dChristian Maederoptions :: [OptDescr (Env -> Env)]

fd5d3885a092ac0727fa2436cdfc3b248318ebd8Christian Maederoptions =

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

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

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

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

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

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

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

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

529f678f015ae5276f87da63114cdce750b366aeChristian Maeder ]

ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder

8a1f427564a5ae2db32332512237ef645289c34dChristian MaedersetArg x e = e {envArgs = (n, tail rest):(envArgs e)} where

529f678f015ae5276f87da63114cdce750b366aeChristian Maeder (n,rest) = span (/= ':') x

b475a916d62584a2af5f51749240db7a5f0c8b82Christian MaederaddGlobalRule x e = e {envGlobalRules = x:(envGlobalRules e)}

529f678f015ae5276f87da63114cdce750b366aeChristian Maeder

568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederheader = "Usage: DrIFT [OPTION...] file"

ac510075311023bf24175f7a76b89ec2bbda0626Christian Maedermain = do

fd5d3885a092ac0727fa2436cdfc3b248318ebd8Christian Maeder argv <- System.getArgs

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

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

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

ac9e33c3c35b2663e5cb76483228910f142d9576Christian Maeder case env of

ac9e33c3c35b2663e5cb76483228910f142d9576Christian Maeder Env { envOperation = OpList } -> mapM_ putStrLn (sort $ map fst rules)

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

5b1f1d57c75562a7af79e8256f4afa07febe921bChristian Maeder _ -> case n of

5b1f1d57c75562a7af79e8256f4afa07febe921bChristian Maeder [n] -> derive env n

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

ac9e33c3c35b2663e5cb76483228910f142d9576Christian Maeder

ac9e33c3c35b2663e5cb76483228910f142d9576Christian Maeder

ac9e33c3c35b2663e5cb76483228910f142d9576Christian Maederderive env fname = do

ac9e33c3c35b2663e5cb76483228910f142d9576Christian Maeder file <- readFile fname

ac9e33c3c35b2663e5cb76483228910f142d9576Christian Maeder handle <- getOutput env

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

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

4be371b81d055e03a5946e4ec333613f313d689bChristian Maeder let

ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder (body,_) = userCode file

7de39d39bc1700cc8a9bb9df90b920aad9e18d4aChristian Maeder b = ".lhs" `isSuffixOf` fname --isLiterate body

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

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

529f678f015ae5276f87da63114cdce750b366aeChristian Maeder let

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

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

568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder unless (envResultsOnly env) $ hPutStr handle body

ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder hPutStr handle result

fd5d3885a092ac0727fa2436cdfc3b248318ebd8Christian Maeder

81700fac589336e88451a2a8474a893a28506438Christian MaederaddGlobals :: [Tag] -> ToDo -> ToDo

76647324ed70f33b95a881b536d883daccf9568dChristian MaederaddGlobals tags tds = (tags,Directive):tds

ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder

7c57322afb6342e5cc8b1fdc96050b707407fc61Christian Maederrules = userRules ++ standardRules

5b1f1d57c75562a7af79e8256f4afa07febe921bChristian Maeder-- codeRender doc = fullRender PageMode 80 1 doc "" -- now obsolete

5b1f1d57c75562a7af79e8256f4afa07febe921bChristian Maedervsep = vcat . map ($$ (text ""))

5b1f1d57c75562a7af79e8256f4afa07febe921bChristian MaedersepDoc = commentLine . text $ " Imported from other files :-"

5b1f1d57c75562a7af79e8256f4afa07febe921bChristian Maeder

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."]