DrIFT.hs revision 9715af31f7f36453a73ca1c99e59d273fbf8daad
a9de0a2f34860a24f457c777e740b7e87e6e3827Christian Maeder-- Based on DrIFT 1.0 by Noel Winstanley
6ea54752d184beb92c92fbae17ae9f7dd065d988Christian Maeder-- hacked for Haskell 98 by Malcolm Wallace, University of York, Feb 1999.
306763c67bb99228487345b32ab8c5c6cd41f23cChristian Maeder-- modified by various people, now maintained by John Meacham
3a6c7a7ff823616f56cd3d205fc44664a683effdChristian Maeder-- adapted version for hets by Christian Maeder
6ea54752d184beb92c92fbae17ae9f7dd065d988Christian Maedermodule Main(main) where
97018cf5fa25b494adffd7e9b4e87320dae6bf47Christian Maederimport ChaseImports
2eeec5240b424984e3ee26296da1eeab6c6d739eChristian Maederimport UserRulesHetCATS
306763c67bb99228487345b32ab8c5c6cd41f23cChristian Maederimport RuleUtils (commentLine,texts)
f3a94a197960e548ecd6520bb768cb0d547457bbChristian Maederimport CommandP
9f87aabedf02d74917d94fe1ac0300e07d3d4bc2Christian Maederimport ParseLib2
e9249d3ecd51a2b6a966a58669953e58d703adc6Till Mossakowskiimport List (partition)
e9249d3ecd51a2b6a966a58669953e58d703adc6Till Mossakowskiimport qualified System
e9249d3ecd51a2b6a966a58669953e58d703adc6Till Mossakowskiimport RuleUtils(Rule,Tag)
e9249d3ecd51a2b6a966a58669953e58d703adc6Till Mossakowskiimport GenUtil
556f473448dfcceee22afaa89ed7a364489cdbbbChristian Maederusage = "Usage: DrIFT file"
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder [n] -> derive n
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder _ -> putErrDie $ "single input file must be specified.\n" ++ usage
556f473448dfcceee22afaa89ed7a364489cdbbbChristian Maederderive fname = do
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder fbody <- readFile fname
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder -- don't add a comment to let other pragmas shine through
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder putStrLn $ "{-# LINE 1 \"" ++ fname ++ "\" #-}"
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder let modname = case papply (parse (symbol "module" >> cap))
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder (0, -1) ((0, 0), fbody) of
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder [(m, _)] -> m
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder _ -> error "module name not recognized"
556f473448dfcceee22afaa89ed7a364489cdbbbChristian Maeder let (docs, _, todo) = process modname . parser $ fbody
556f473448dfcceee22afaa89ed7a364489cdbbbChristian Maeder moreDocs <- fmap ((\(x, _, _) -> x) . process modname)
556f473448dfcceee22afaa89ed7a364489cdbbbChristian Maeder (chaseImports fbody todo)
556f473448dfcceee22afaa89ed7a364489cdbbbChristian Maeder putStrLn "{- ? Generated by DrIFT : Look, but Don't Touch. ? -}"
556f473448dfcceee22afaa89ed7a364489cdbbbChristian Maeder putStr . render . vsep $ docs ++ sepDoc : moreDocs
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maederrules = map (\(a, b, _, _, _) -> (a, b)) hetcatsrules
e9249d3ecd51a2b6a966a58669953e58d703adc6Till Mossakowskivsep = vcat . map ($$ (text ""))
922819b1c2d383a0fa5d70e1c4aa76667e2f1ca3Christian MaedersepDoc = commentLine . text $ " Imported from other files :-"
27166b063721ef1a2efd8f00ab3d9bc820b315fbChristian Maeder-- Main Pass - Takes parsed data and rules and combines to create instances...
19298cbfd6ee2abd904f3181af7760b965b822c3Christian Maeder-- Returns all parsed data, ande commands calling for files to be imported if
9f87aabedf02d74917d94fe1ac0300e07d3d4bc2Christian Maeder-- datatypes aren't located in this module.
27166b063721ef1a2efd8f00ab3d9bc820b315fbChristian Maederprocess :: String -> ToDo -> ([Doc],[Data],ToDo)
27166b063721ef1a2efd8f00ab3d9bc820b315fbChristian Maederprocess modname i =
27166b063721ef1a2efd8f00ab3d9bc820b315fbChristian Maeder (concatMap g dats ++ concatMap h moreDats, parsedData, fimports)
27166b063721ef1a2efd8f00ab3d9bc820b315fbChristian Maeder g (tags, d) = [find t rules d | t <- tags ++ directives]
27166b063721ef1a2efd8f00ab3d9bc820b315fbChristian Maeder h (tags, d) = [find t rules d | t <- tags]
63324a97283728a30932828a612c7b0b0f687624Christian Maeder directives = concatMap fst globals
556f473448dfcceee22afaa89ed7a364489cdbbbChristian Maeder (dats, commands) = partition (isData . snd) i
e9249d3ecd51a2b6a966a58669953e58d703adc6Till Mossakowski (globals, fors) = partition (\(_,d) -> d == Directive) commands
59fa9b1349ae1e001d996da732c4ac805c2938e2Christian Maeder (moreDats, fimports) = resolve modname parsedData fors ([],[])
e9249d3ecd51a2b6a966a58669953e58d703adc6Till Mossakowski parsedData = map snd dats
e9249d3ecd51a2b6a966a58669953e58d703adc6Till Mossakowskifind :: Tag -> [Rule] -> (Data -> Doc)
e9249d3ecd51a2b6a966a58669953e58d703adc6Till Mossakowskifind t r = case filter ((== t) . fst) r of
53310804002cd9e3c9c5844db3b984abcf001788Christian Maeder [] -> const (commentLine warning)
e9249d3ecd51a2b6a966a58669953e58d703adc6Till Mossakowski x : _ -> snd x
e9249d3ecd51a2b6a966a58669953e58d703adc6Till Mossakowski warning = hsep . texts $ ["Warning : Rule",t,"not found."]