@@ -16,11 +16,15 @@
1616module Main where
1717
1818import Control.Applicative ((<*>), (<$>))
19+import Control.Monad (unless)
1920
2021import Data.List (intercalate,nub,sort)
22+import Data.Foldable (for_)
2123import Data.Version (showVersion)
2224
2325import System.Console.CmdTheLine
26+import System.Directory (createDirectoryIfMissing)
27+import System.FilePath ((</>))
2428import System.Exit (exitFailure, exitSuccess)
2529
2630import Text.Parsec (ParseError)
@@ -41,6 +45,9 @@ instance Ord SuperMap where
4145 where
4246 getCls = either id snd
4347
48+runModuleName :: P.ModuleName -> String
49+runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns)
50+
4451readInput :: FilePath -> IO (Either ParseError [P.Module])
4552readInput p = do
4653 text <- U.readFile p
@@ -51,13 +58,21 @@ compile input mOutput = do
5158 modules <- readInput input
5259 case modules of
5360 Left err -> U.print err >> exitFailure
54− Right (P.Module _ decls _ : _) -> do
55− let tcs = filter P.isTypeClassDeclaration decls
56− let supers = sort . nub . filter (not . null) $ fmap superClasses tcs
57− let hier = "digraph Prelude {\n" ++ intercalate "\n" (concatMap (fmap ((" " ++) . (++ ";") . show)) supers) ++ "\n}"
58− case mOutput of
59− Just output -> U.writeFile output hier
60− Nothing -> U.putStrLn hier
61+ Right ms -> do
62+ for_ ms $ \(P.Module moduleName decls _) ->
63+ let name = runModuleName moduleName
64+ tcs = filter P.isTypeClassDeclaration decls
65+ supers = sort . nub . filter (not . null) $ fmap superClasses tcs
66+ prologue = "digraph " ++ name ++ " {\n"
67+ --body = intercalate "\n" (concatMap (fmap ((" " ++) . (++ ";") . show)) supers)
68+ body = intercalate "\n" (concatMap (fmap (\s -> " " ++ show s ++ ";")) supers)
69+ epilogue = "\n}"
70+ hier = prologue ++ body ++ epilogue
71+ in unless (null supers) $ case mOutput of
72+ Just output -> do
73+ createDirectoryIfMissing True output
74+ U.writeFile (output </> name) hier
75+ Nothing -> U.putStrLn hier
6176 exitSuccess
6277
6378superClasses :: P.Declaration -> [SuperMap]
@@ -69,10 +84,11 @@ superClasses _ = []
6984
7085outputFile :: Term (Maybe FilePath)
7186outputFile = value $ opt Nothing $ (optInfo [ "o", "output" ])
72− { optDoc = "The output file" }
87+ { optDoc = "The output directory" }
7388
7489inputFile :: Term FilePath
75−inputFile = value $ pos 0 "main.purs" $ posInfo { posDoc = "The input file to generate a hierarchy from" }
90+inputFile = value $ pos 0 "main.purs" $ posInfo
91+ { posDoc = "The input file to generate a hierarchy from" }
7692
7793term :: Term (IO ())
7894term = compile <$> inputFile <*> outputFile