@@ -16,11 +16,15 @@
16module Main where
16module Main where
18import Control.Applicative ((<*>), (<$>))
18import Control.Applicative ((<*>), (<$>))
19+import Control.Monad (unless)
20import Data.List (intercalate,nub,sort)
21import Data.List (intercalate,nub,sort)
22+import Data.Foldable (for_)
21import Data.Version (showVersion)
23import Data.Version (showVersion)
23import System.Console.CmdTheLine
25import System.Console.CmdTheLine
26+import System.Directory (createDirectoryIfMissing)
27+import System.FilePath ((</>))
24import System.Exit (exitFailure, exitSuccess)
28import System.Exit (exitFailure, exitSuccess)
26import Text.Parsec (ParseError)
30import Text.Parsec (ParseError)
@@ -41,6 +45,9 @@ instance Ord SuperMap where
42 getCls = either id snd
46 getCls = either id snd
48+runModuleName :: P.ModuleName -> String
49+runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns)
44readInput :: FilePath -> IO (Either ParseError [P.Module])
51readInput :: FilePath -> IO (Either ParseError [P.Module])
45readInput p = do
52readInput p = do
46 text <- U.readFile p
53 text <- U.readFile p
@@ -51,13 +58,21 @@ compile input mOutput = do
51 modules <- readInput input
58 modules <- readInput input
52 case modules of
59 case modules of
53 Left err -> U.print err >> exitFailure
60 Left err -> U.print err >> exitFailure
54− Right (P.Module _ decls _ : _) -> do
62+ for_ ms $ \(P.Module moduleName decls _) ->
63+ let name = runModuleName moduleName
55− let tcs = filter P.isTypeClassDeclaration decls
64+ tcs = filter P.isTypeClassDeclaration decls
56− let supers = sort . nub . filter (not . null) $ fmap superClasses tcs
65+ supers = sort . nub . filter (not . null) $ fmap superClasses tcs
66+ prologue = "digraph " ++ name ++ " {\n"
57− let hier = "digraph Prelude {\n" ++ intercalate "\n" (concatMap (fmap ((" " ++) . (++ ";") . show)) supers) ++ "\n}"
67+ --body = intercalate "\n" (concatMap (fmap ((" " ++) . (++ ";") . show)) supers)
68+ body = intercalate "\n" (concatMap (fmap (\s -> " " ++ show s ++ ";")) supers)
70+ hier = prologue ++ body ++ epilogue
58− case mOutput of
71+ in unless (null supers) $ case mOutput of
73+ createDirectoryIfMissing True output
59− Just output -> U.writeFile output hier
74+ U.writeFile (output </> name) hier
60− Nothing -> U.putStrLn hier
75+ Nothing -> U.putStrLn hier
61 exitSuccess
76 exitSuccess
63superClasses :: P.Declaration -> [SuperMap]
78superClasses :: P.Declaration -> [SuperMap]
@@ -69,10 +84,11 @@ superClasses _ = []
70outputFile :: Term (Maybe FilePath)
85outputFile :: Term (Maybe FilePath)
71outputFile = value $ opt Nothing $ (optInfo [ "o", "output" ])
86outputFile = value $ opt Nothing $ (optInfo [ "o", "output" ])
72− { optDoc = "The output file" }
87+ { optDoc = "The output directory" }
74inputFile :: Term FilePath
89inputFile :: Term FilePath
90+inputFile = value $ pos 0 "main.purs" $ posInfo
75−inputFile = value $ pos 0 "main.purs" $ posInfo { posDoc = "The input file to generate a hierarchy from" }
91+ { posDoc = "The input file to generate a hierarchy from" }
77term :: Term (IO ())
93term :: Term (IO ())
78term = compile <$> inputFile <*> outputFile
94term = compile <$> inputFile <*> outputFile