DrIFT.hs revision 93200332914950da5c053bdbd2a8a1f8df3a26f2
82178a3043043b8813c0d7288a06ca1b7d110d4atakashi-- Based on DrIFT 1.0 by Noel Winstanley
82178a3043043b8813c0d7288a06ca1b7d110d4atakashi-- hacked for Haskell 98 by Malcolm Wallace, University of York, Feb 1999.
fd9abdda70912b99b24e3bf1a38f26fde908a74cnd-- modified by various people, now maintained by John Meacham
fd9abdda70912b99b24e3bf1a38f26fde908a74cnd-- adapted version for hets by Christian Maeder
fd9abdda70912b99b24e3bf1a38f26fde908a74cndmodule Main(main) where
82178a3043043b8813c0d7288a06ca1b7d110d4atakashiimport ChaseImports
82178a3043043b8813c0d7288a06ca1b7d110d4atakashiimport UserRulesHetCATS
82178a3043043b8813c0d7288a06ca1b7d110d4atakashiimport RuleUtils (commentLine,texts)
82178a3043043b8813c0d7288a06ca1b7d110d4atakashiimport DataP
96ad5d81ee4a2cc66a4ae19893efc8aa6d06fae7jailletcimport CommandP
82178a3043043b8813c0d7288a06ca1b7d110d4atakashiimport ParseLib2
d29d9ab4614ff992b0e8de6e2b88d52b6f1f153erbowenimport Data.List (partition)
d29d9ab4614ff992b0e8de6e2b88d52b6f1f153erbowenimport qualified System.Exit as System
d29d9ab4614ff992b0e8de6e2b88d52b6f1f153erbowenimport qualified IO
82178a3043043b8813c0d7288a06ca1b7d110d4atakashiimport RuleUtils(Rule,Tag)
82178a3043043b8813c0d7288a06ca1b7d110d4atakashiusage :: String
af33a4994ae2ff15bc67d19ff1a7feb906745bf8rbowenusage = "Usage: DrIFT file\n"
82178a3043043b8813c0d7288a06ca1b7d110d4atakashimain :: IO ()
82178a3043043b8813c0d7288a06ca1b7d110d4atakashi argv <- getArgs
b43f840409794ed298e8634f6284741f193b6c4ftakashi case argv of
82178a3043043b8813c0d7288a06ca1b7d110d4atakashi [n] -> derive n
b43f840409794ed298e8634f6284741f193b6c4ftakashi $ "single input file must be specified.\n" ++ usage
b43f840409794ed298e8634f6284741f193b6c4ftakashiderive :: FilePath -> IO ()
b43f840409794ed298e8634f6284741f193b6c4ftakashiderive fname = do
b43f840409794ed298e8634f6284741f193b6c4ftakashi fbody <- readFile fname
b43f840409794ed298e8634f6284741f193b6c4ftakashi -- don't add a comment to let other pragmas shine through
82178a3043043b8813c0d7288a06ca1b7d110d4atakashi putStrLn $ "{-# LINE 1 \"" ++ fname ++ "\" #-}"
82178a3043043b8813c0d7288a06ca1b7d110d4atakashi let modname = case papply (parse (symbol "module" >> cap))
82178a3043043b8813c0d7288a06ca1b7d110d4atakashi (0, -1) ((0, 0), fbody) of
82178a3043043b8813c0d7288a06ca1b7d110d4atakashi [(m, _)] -> m
e5ce3ac0e9b720c0fa23782e29168a0810697fdetakashi _ -> error "module name not recognized"
82178a3043043b8813c0d7288a06ca1b7d110d4atakashi let (docs, _, todo) = process modname . parser $ fbody
82178a3043043b8813c0d7288a06ca1b7d110d4atakashi moreDocs <- fmap ((\(x, _, _) -> x) . process modname)
82178a3043043b8813c0d7288a06ca1b7d110d4atakashi (chaseImports fbody todo)
82178a3043043b8813c0d7288a06ca1b7d110d4atakashi putStr fbody
82178a3043043b8813c0d7288a06ca1b7d110d4atakashi putStrLn "{- ? Generated by DrIFT : Look, but Don't Touch. ? -}"
82178a3043043b8813c0d7288a06ca1b7d110d4atakashi putStr . render . vsep $ docs ++ sepDoc : moreDocs
82178a3043043b8813c0d7288a06ca1b7d110d4atakashirules :: [(Tag, Data -> Doc)]
82178a3043043b8813c0d7288a06ca1b7d110d4atakashirules = map (\(a, b, _, _, _) -> (a, b)) hetcatsrules
82178a3043043b8813c0d7288a06ca1b7d110d4atakashivsep :: [Doc] -> Doc
82178a3043043b8813c0d7288a06ca1b7d110d4atakashivsep = vcat . map ($$ (text ""))
82178a3043043b8813c0d7288a06ca1b7d110d4atakashisepDoc :: Doc
82178a3043043b8813c0d7288a06ca1b7d110d4atakashisepDoc = commentLine . text $ " Imported from other files :-"
82178a3043043b8813c0d7288a06ca1b7d110d4atakashi-- Main Pass - Takes parsed data and rules and combines to create instances...
82178a3043043b8813c0d7288a06ca1b7d110d4atakashi-- Returns all parsed data, ande commands calling for files to be imported if
b9f522ae1c0ed2bf3fc4444245bf28b2e2449a65nd-- datatypes aren't located in this module.
b9f522ae1c0ed2bf3fc4444245bf28b2e2449a65ndprocess :: String -> ToDo -> ([Doc],[Data],ToDo)
82178a3043043b8813c0d7288a06ca1b7d110d4atakashiprocess modname i =
82178a3043043b8813c0d7288a06ca1b7d110d4atakashi (concatMap g dats ++ concatMap h moreDats, parsedData, fimports)
30471a4650391f57975f60bbb6e4a90be7b284bfhumbedooh g (tags, d) = [find t rules d | t <- tags ++ directives]
1f1b6bf13313fdd14a45e52e553d3ff28689b717coar h (tags, d) = [find t rules d | t <- tags]
b9f522ae1c0ed2bf3fc4444245bf28b2e2449a65nd directives = concatMap fst globals
b9f522ae1c0ed2bf3fc4444245bf28b2e2449a65nd (dats, commands) = partition (isData . snd) i
b9f522ae1c0ed2bf3fc4444245bf28b2e2449a65nd (globals, fors) = partition (\(_,d) -> d == Directive) commands
01d52afd5ea497df24826737569291294d5dfa04rbowen (moreDats, fimports) = resolve modname parsedData fors ([],[])
01d52afd5ea497df24826737569291294d5dfa04rbowen parsedData = map snd dats
b9f522ae1c0ed2bf3fc4444245bf28b2e2449a65ndfind :: Tag -> [Rule] -> (Data -> Doc)
b9f522ae1c0ed2bf3fc4444245bf28b2e2449a65ndfind t r = case filter ((== t) . fst) r of
b9f522ae1c0ed2bf3fc4444245bf28b2e2449a65nd [] -> const (commentLine warning)
b9f522ae1c0ed2bf3fc4444245bf28b2e2449a65nd x : _ -> snd x
01d52afd5ea497df24826737569291294d5dfa04rbowen warning = hsep . texts $ ["Warning : Rule",t,"not found."]