{- | 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, Rule, Tag)

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

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

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 "\n-- Generated by DrIFT, look but don't touch!\n"

putStr . render . vsep $ docs ++ moreDocs

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

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

vsep :: [Doc] -> Doc

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

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

x : _ -> snd x

[] -> const $ commentLine

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