summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-04-15 17:41:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-04-15 17:41:00 (GMT)
commit04b3be14a6ecb9f962b1d812dd1d6bcced9893d9 (patch)
treebe0c6c7c3a854b581bb780b268602274966fe57f
parent365e910aab012ac04814c0059363a16bc5b48869 (diff)
version 0.4.18.20.4.18.2
-rw-r--r--docgen/Main.hs25
-rw-r--r--hierarchy/Main.hs103
-rw-r--r--purescript.cabal11
3 files changed, 130 insertions, 9 deletions
diff --git a/docgen/Main.hs b/docgen/Main.hs
index 9fea026..a5d289c 100644
--- a/docgen/Main.hs
+++ b/docgen/Main.hs
@@ -14,17 +14,17 @@
module Main where
-import qualified Language.PureScript as P
-import System.Console.CmdTheLine
import Control.Applicative
import Control.Monad
import Control.Monad.Writer
-import System.Exit (exitSuccess, exitFailure)
-import qualified System.IO.UTF8 as U
-import qualified Paths_purescript as Paths
-import Data.Version (showVersion)
-import Data.List
import Data.Function (on)
+import Data.List
+import Data.Version (showVersion)
+import qualified Language.PureScript as P
+import qualified Paths_purescript as Paths
+import qualified System.IO.UTF8 as U
+import System.Console.CmdTheLine
+import System.Exit (exitSuccess, exitFailure)
docgen :: FilePath -> IO ()
docgen input = do
@@ -61,6 +61,7 @@ renderModules ms = do
renderModule :: P.Module -> Docs
renderModule (P.Module moduleName ds exps) =
let exported = filter (isExported exps) ds
+ hasTypeclasses = any isTypeClassDeclaration ds
in do
headerLevel 2 $ "Module " ++ P.runModuleName moduleName
spacer
@@ -70,6 +71,9 @@ renderModule (P.Module moduleName ds exps) =
spacer
headerLevel 3 "Type Classes"
spacer
+ when hasTypeclasses $ do
+ renderTypeclassImage moduleName
+ spacer
renderTopLevel exps (filter isTypeClassDeclaration exported)
spacer
headerLevel 3 "Type Class Instances"
@@ -83,7 +87,7 @@ renderModule (P.Module moduleName ds exps) =
isExported :: Maybe [P.DeclarationRef] -> P.Declaration -> Bool
isExported Nothing _ = True
-isExported _ (P.TypeInstanceDeclaration _ _ _ _ _) = True
+isExported _ P.TypeInstanceDeclaration{} = True
isExported exps (P.PositionedDeclaration _ d) = isExported exps d
isExported (Just exps) decl = any (matches decl) exps
where
@@ -108,6 +112,11 @@ renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl
renderDeclaration 4 exps decl
spacer
+renderTypeclassImage :: P.ModuleName -> Docs
+renderTypeclassImage name =
+ let name' = P.runModuleName name
+ in tell ["![" ++ name' ++ "](images/" ++ name' ++ ".png)"]
+
renderDeclaration :: Int -> Maybe [P.DeclarationRef] -> P.Declaration -> Docs
renderDeclaration n _ (P.TypeDeclaration ident ty) =
atIndent n $ show ident ++ " :: " ++ P.prettyPrintType ty
diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs
new file mode 100644
index 0000000..977f3f6
--- /dev/null
+++ b/hierarchy/Main.hs
@@ -0,0 +1,103 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Main
+-- Copyright : (c) Hardy Jones 2014
+-- License : MIT
+--
+-- Maintainer : Hardy Jones <jones3.hardy@gmail.com>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- Generate Directed Graphs of PureScript TypeClasses
+--
+-----------------------------------------------------------------------------
+
+module Main where
+
+import Control.Applicative ((<*>), (<$>))
+import Control.Monad (unless)
+
+import Data.List (intercalate,nub,sort)
+import Data.Foldable (for_)
+import Data.Version (showVersion)
+
+import System.Console.CmdTheLine
+import System.Directory (createDirectoryIfMissing)
+import System.FilePath ((</>))
+import System.Exit (exitFailure, exitSuccess)
+
+import Text.Parsec (ParseError)
+
+import qualified Language.PureScript as P
+import qualified Paths_purescript as Paths
+import qualified System.IO.UTF8 as U
+
+newtype SuperMap = SuperMap { unSuperMap :: Either P.ProperName (P.ProperName, P.ProperName) }
+ deriving Eq
+
+instance Show SuperMap where
+ show (SuperMap (Left sub)) = show sub
+ show (SuperMap (Right (super, sub))) = show super ++ " -> " ++ show sub
+
+instance Ord SuperMap where
+ compare (SuperMap s) (SuperMap s') = getCls s `compare` getCls s'
+ where
+ getCls = either id snd
+
+runModuleName :: P.ModuleName -> String
+runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns)
+
+readInput :: FilePath -> IO (Either ParseError [P.Module])
+readInput p = do
+ text <- U.readFile p
+ return $ P.runIndentParser p P.parseModules text
+
+compile :: FilePath -> Maybe FilePath -> IO ()
+compile input mOutput = do
+ modules <- readInput input
+ case modules of
+ Left err -> U.print err >> exitFailure
+ Right ms -> do
+ for_ ms $ \(P.Module moduleName decls _) ->
+ let name = runModuleName moduleName
+ tcs = filter P.isTypeClassDeclaration decls
+ supers = sort . nub . filter (not . null) $ fmap superClasses tcs
+ prologue = "digraph " ++ name ++ " {\n"
+ body = intercalate "\n" (concatMap (fmap (\s -> " " ++ show s ++ ";")) supers)
+ epilogue = "\n}"
+ hier = prologue ++ body ++ epilogue
+ in unless (null supers) $ case mOutput of
+ Just output -> do
+ createDirectoryIfMissing True output
+ U.writeFile (output </> name) hier
+ Nothing -> U.putStrLn hier
+ exitSuccess
+
+superClasses :: P.Declaration -> [SuperMap]
+superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _) =
+ fmap (\(P.Qualified _ super, _) -> SuperMap (Right (super, sub))) supers
+superClasses (P.TypeClassDeclaration sub _ _ _) = [SuperMap (Left sub)]
+superClasses (P.PositionedDeclaration _ decl) = superClasses decl
+superClasses _ = []
+
+outputFile :: Term (Maybe FilePath)
+outputFile = value $ opt Nothing $ (optInfo [ "o", "output" ])
+ { optDoc = "The output directory" }
+
+inputFile :: Term FilePath
+inputFile = value $ pos 0 "main.purs" $ posInfo
+ { posDoc = "The input file to generate a hierarchy from" }
+
+term :: Term (IO ())
+term = compile <$> inputFile <*> outputFile
+
+termInfo :: TermInfo
+termInfo = defTI
+ { termName = "hierarchy"
+ , version = showVersion Paths.version
+ , termDoc = "Creates a GraphViz directed graph of PureScript TypeClasses"
+ }
+
+main :: IO ()
+main = run (term, termInfo)
diff --git a/purescript.cabal b/purescript.cabal
index e23d122..910fff2 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.4.18.1
+version: 0.4.18.2
cabal-version: >=1.8
build-type: Custom
license: MIT
@@ -125,6 +125,15 @@ executable docgen
other-modules:
ghc-options: -Wall -O2
+executable hierarchy
+ build-depends: base >=4 && <5, cmdtheline -any, purescript -any, utf8-string -any,
+ process -any, mtl -any, parsec -any, filepath -any, directory -any
+ main-is: Main.hs
+ buildable: True
+ hs-source-dirs: hierarchy
+ other-modules:
+ ghc-options: -Wall -O2
+
test-suite tests
build-depends: base >=4 && <5, containers -any, directory -any,
filepath -any, mtl -any, parsec -any, purescript -any, syb >= 0.4.1 && < 0.5,