-- 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

-- adapted version for hets by Christian Maeder

module Main(main) where

import ChaseImports

import UserRulesHetCATS

import RuleUtils (commentLine,texts)

import DataP

import CommandP

import ParseLib2

import Text.PrettyPrint.HughesPJ

import Data.List (partition)

import System.Environment

import qualified System.Exit as System

import qualified System.IO as IO

import RuleUtils(Rule,Tag)

usage :: String

usage = "Usage: DrIFT file\n"

main :: IO ()

main = do

argv <- getArgs

case argv of

[n] -> derive n

_ -> do

IO.hPutStr IO.stderr

$ "single input file must be specified.\n" ++ usage

System.exitFailure

derive :: FilePath -> IO ()

derive fname = do

fbody <- readFile fname

-- don't add a comment to let other pragmas shine through

putStrLn $ "{-# LINE 1 \"" ++ fname ++ "\" #-}"

let modname = case papply (parse (symbol "module" >> cap))

(0, -1) ((0, 0), fbody) of

[(m, _)] -> m

_ -> error "module name not recognized"

let (docs, _, todo) = process modname . parser $ fbody

moreDocs <- fmap ((\(x, _, _) -> x) . process modname)

(chaseImports fbody todo)

putStr fbody

putStrLn "{- ? Generated by DrIFT : Look, but Don't Touch. ? -}"

putStr . render . vsep $ docs ++ sepDoc : moreDocs

rules :: [(Tag, Data -> Doc)]

rules = map (\(a, b, _, _, _) -> (a, b)) hetcatsrules

vsep :: [Doc] -> Doc

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

sepDoc :: Doc

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

-- 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 :: String -> ToDo -> ([Doc],[Data],ToDo)

process modname i =

(concatMap g dats ++ concatMap h moreDats, parsedData, fimports)

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, fimports) = resolve modname parsedData fors ([],[])

parsedData = map snd dats

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

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

[] -> const (commentLine warning)

x : _ -> snd x

where

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