purescript 0.4.18.1 → 0.4.18.2
raw patch · 3 files changed
+130/−9 lines, 3 filesdep ~cmdthelinedep ~directorynew-component:exe:hierarchyPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: cmdtheline, directory
API changes (from Hackage documentation)
Files
- docgen/Main.hs +17/−8
- hierarchy/Main.hs +103/−0
- purescript.cabal +10/−1
docgen/Main.hs view
@@ -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 @@ 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 @@ 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 @@ 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@@ -107,6 +111,11 @@ renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do 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) =
+ hierarchy/Main.hs view
@@ -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)
purescript.cabal view
@@ -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@@ -122,6 +122,15 @@ main-is: Main.hs buildable: True hs-source-dirs: 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