music-util (empty) → 0.5
raw patch · 4 files changed
+440/−0 lines, 4 filesdep +Cabaldep +basedep +containerssetup-changed
Dependencies added: Cabal, base, containers, fgl, graphviz, process, shelly, text
Files
- COPYING +26/−0
- Setup.lhs +4/−0
- music-util.cabal +34/−0
- src/music-util.hs +376/−0
+ COPYING view
@@ -0,0 +1,26 @@++Copyright (c) 2013, Hans Höglund+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of the <organization> nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ music-util.cabal view
@@ -0,0 +1,34 @@++name: music-util+version: 0.5+cabal-version: >= 1.10+author: Hans Hoglund+maintainer: Hans Hoglund <hans@hanshoglund.se>+license: BSD3+license-file: COPYING+synopsis: Utility for developing the Music Suite.+category: +tested-with: GHC+build-type: Simple++description:+ Utility program for installing and developing the music suite.++source-repository head+ type: git+ location: git://github.com/hanshoglund/music-util.git++executable "music-util"+ build-depends:+ base >= 4 && < 5,+ text,+ containers,+ shelly,+ process,+ graphviz,+ fgl,+ Cabal >= 1.16 && < 2+ hs-source-dirs: src+ default-language: Haskell2010+ main-is:+ music-util.hs
+ src/music-util.hs view
@@ -0,0 +1,376 @@++{-# LANGUAGE OverloadedStrings #-}++import Control.Applicative+import Control.Exception (SomeException, try)+-- import Data.Graph+-- import qualified Data.Graph as OG++import Data.Graph.Inductive hiding (run, run_)+import Data.GraphViz+import Data.GraphViz.Attributes.Complete++import System.Process (system)+import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Monoid+import Data.String (IsString, fromString)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Distribution.ModuleName as ModuleName+import qualified Distribution.PackageDescription as PackageDescription+import Distribution.PackageDescription.Parse (readPackageDescription)+import Distribution.Verbosity (silent)+import Shelly+import qualified System.Environment as E+default (T.Text)+main = shelly $ verbosely $ main2++show' :: (Show a, IsString b) => a -> b+show' = fromString . show++getEnvOr :: String -> String -> IO String+getEnvOr n def = fmap (either (const def) id) $ (try (E.getEnv n) :: IO (Either SomeException String))++packages :: [String]+packages = labels dependencies++dependencies :: Gr String String+dependencies = mkGraph+ [+ (0, "abcnotation") ,+ (1, "musicxml2") ,+ (2, "lilypond") ,+ (3, "music-pitch-literal") ,+ (4, "music-dynamics-literal") ,+ (5, "music-score") ,+ (6, "music-pitch") ,+ (7, "music-dynamics") ,+ (8, "music-articulation") ,+ (9, "music-parts") ,+ (10, "music-preludes") ,+ (11, "music-graphics") ,+ (12, "music-sibelius") ,+ (99, "music-docs")+ ]+ [+ (0, 3, ""),+ (0, 4, ""),+ (1, 3, ""),+ (1, 4, ""),+ (2, 3, ""),+ (2, 4, ""),+ (6, 3, ""),+ (7, 4, ""),++ (5, 0, ""),+ (5, 1, ""),+ (5, 2, ""),+ (5, 3, ""),+ (5, 4, ""),++ (10, 5, ""),+ (10, 6, ""),+ (10, 7, ""),+ (10, 8, ""),+ (10, 9, ""),++ (11, 10, ""),+ (12, 10, "") + ]+++dependencyParams :: GraphvizParams Int String String () String+dependencyParams = nonClusteredParams {+ globalAttributes = ga,+ fmtNode = fn,+ fmtEdge = fe+ }+ where+ ga = [+ GraphAttrs [],+ NodeAttrs []+ ]++ fn (n,l) = [(Label . StrLabel . TL.pack) l]+ fe (f,t,l) = [(Label . StrLabel . TL.pack) l] ++showDependencyGraph :: Sh ()+showDependencyGraph = do+ writefile "/tmp/deps.dot" (TL.toStrict $ printDotGraph dg)+ liftIO $ system "dot -Tpdf /tmp/deps.dot > music-suite-deps.pdf"+ liftIO $ system "open music-suite-deps.pdf"+ return ()+ where+ dg = graphToDot dependencyParams dependencies++getPackageDeps :: String -> [String]+getPackageDeps l = List.nub $ l : concatMap getPackageDeps children+ where+ children = getPackageDeps1 l++getPackageDeps1 :: String -> [String]+getPackageDeps1 label = depNames -- TODO recur+ where+ -- node id of given package+ node :: Node+ node = fromMaybe (error "Unknown package") $ fromLab label dependencies+ + -- node ids of direct deps+ deps :: [Node]+ deps = suc dependencies node++ depNames :: [String]+ depNames = catMaybes $ fmap (lab dependencies) deps +++++main2 :: Sh ()+main2 = do+ args <- liftIO $ E.getArgs+ path <- liftIO $ getEnvOr "MUSIC_SUITE_DIR" ""+ if path == "" then error "Needs $MUSIC_SUITE_DIR to be set" else return ()++ -- TODO check path++ -- echo $ fromString path+ chdir (fromString path) (main3 args)++main3 args = do+ if length args <= 0 then usage else do+ if (args !! 0 == "document") then document args else return ()+ if (args !! 0 == "install") then install args else return ()+ if (args !! 0 == "list") then list args else return ()+ if (args !! 0 == "graph") then graph args else return ()+ if (args !! 0 == "foreach") then forEach (tail args) else return ()+ if (args !! 0 == "setup") then setup args else return ()++usage :: Sh ()+usage = do+ echo $ "usage: music <command> [<args>]"+ echo $ ""+ echo $ "When commands is one of:"+ echo $ " list Show a list all packages in the Music Suite"+ echo $ " graph Show a graph all packages in the Music Suite (requires Graphviz)"+ echo $ " setup Download all packages (but do not build)"+ echo $ " install <package> Reinstall the given package and its dependencies"+ echo $ " foreach <command> Run a command in each source directory"+ echo $ " document Generate and upload documentation"+ echo $ " --reinstall-transf Reinstall the transf package"+ echo $ " --no-api Skip creating the API documentation"+ echo $ " --no-reference Skip creating the reference documentation"+ echo $ " --local Skip uploading"+ echo ""++setup :: [String] -> Sh ()+setup _ = do+ path <- pwd+ echo $ "Ready to setup music-suite in path\n " <> unFilePath path+ echo $ ""+ echo $ "Please enter 'ok' to confirm..."+ conf <- liftIO $ getLine+ when (conf /= "ok") $ echo $ "Aborted"+ when (conf == "ok") $ do+ mapM_ clonePackage packages+ return ()+ return ()++clonePackage :: String -> Sh ()+clonePackage name = do+ echo "======================================================================"+ liftIO $ system $ "git clone git@github.com:music-suite/" <> name <> ".git"+ echo "======================================================================"+ return ()++list :: [String] -> Sh ()+list _ = mapM_ (echo . fromString) packages++graph _ = showDependencyGraph++forEach :: [String] -> Sh ()+forEach cmdArgs = do+ mapM_ (forEach' cmdArgs) packages+ return ()++forEach' :: [String] -> String -> Sh ()+forEach' [] _ = error "foreach: empty command list"+forEach' (cmd:args) name = do+ -- TODO check dir exists, otherwise return and warn+ echo "======================================================================"+ echo $ fromString name+ echo "======================================================================"+ chdir (fromString name) $ do+ run_ (fromString cmd) (fmap fromString args)++install :: [String] -> Sh ()+install (_:name:_) = do+ let all = List.nub $ reverse $ getPackageDeps name+ -- echo $ show' $ all++ echo "======================================================================"+ echo "Reinstalling the following packages:"+ mapM (\x -> echo $ " " <> fromString x) all+ echo "======================================================================"++ mapM reinstall all+ return ()++document :: [String] -> Sh ()+document args = do++ let flagReinstall = "--reinstall-transf" `elem` args+ let flagNoApi = "--no-api" `elem` args+ let flagNoRef = "--no-reference" `elem` args+ let flagLocal = "--local" `elem` args++ if (flagReinstall)+ then do+ echo ""+ echo "======================================================================"+ echo "Reinstalling transf"+ echo "======================================================================"+ reinstallTransf+ else return ()+ if (not flagNoApi)+ then do+ echo ""+ echo "======================================================================"+ echo "Making API documentation"+ echo "======================================================================"+ makeApiDocs+ else return ()+ if (not flagNoRef)+ then do+ echo ""+ echo "======================================================================"+ echo "Making reference documentation"+ echo "======================================================================"+ makeRef+ else return ()+ if (not flagLocal)+ then do+ echo ""+ echo "======================================================================"+ echo "Uploading documentation"+ echo "======================================================================"+ upload+ else return ()+ return ()+++reinstallTransf :: Sh ()+reinstallTransf = do+ -- TODO check dir exists, otherwise return and warn+ chdir "transf" $ do+ run_ "cabal" ["clean"]+ run_ "cabal" ["configure"]+ run_ "cabal" ["install"]++reinstall :: String -> Sh ()+reinstall name = do+ -- TODO check dir exists, otherwise return and warn+ chdir (fromString name) $ do+ run_ "cabal" ["install",+ "--force-reinstalls",+ "--disable-documentation" -- speeds things up considerably+ ]+++suffM :: Monad m => [Char] -> Shelly.FilePath -> m Bool+suffM s = (\p -> return $ List.isSuffixOf s (unFilePath p::String))++-- Real hack...+unFilePath :: IsString a => Shelly.FilePath -> a+unFilePath = fromString . read . drop (length ("FilePath "::String)) . show++getHsFiles :: Sh [Shelly.FilePath]+getHsFiles = do+ let srcPaths = fmap (<> "src") (fmap fromString packages)+ fmap concat $ mapM (findWhen (suffM ".hs")) srcPaths++{-+getHsFiles2 :: Sh [Shelly.FilePath]+getHsFiles2 = do+ let cabalFilePaths = fmap (\x -> x <> "/" <> x <> ".cabal") $ packages+ cabalDefs <- liftIO $ mapM (readPackageDescription silent) cabalFilePaths+ let cabalLibs = fmap (PackageDescription.condLibrary) $ cabalDefs+ let cabalPublicMods = map (condLibToModList . PackageDescription.condLibrary) $ cabalDefs+ let cabalPublicMods2 = zipWith (\package (fmap ModuleName.components -> mods) ->+ (\m -> (List.intercalate "/" $ [package, "src"] ++ m) ++ ".hs") `fmap` mods+ ) packages cabalPublicMods++ echo $ show' cabalPublicMods2+ return $ fmap fromString $ concat cabalPublicMods2+ where+ condLibToModList Nothing = []+ condLibToModList (Just (PackageDescription.CondNode (PackageDescription.Library ms _ _) _ _)) = ms+-}++{-+TODO works but wrong w.r.t. hslinks++makeApiDocs :: Sh ()+makeApiDocs = do+ home <- liftIO $ getEnvOr "HOME" ""+ let pdb = home ++ "/.ghc/x86_64-darwin-7.6.3/package.conf.d"+ run "standalone-haddock" $ ["-o", "musicsuite.github.io/docs/api", "--package-db", fromString pdb] ++ fmap fromString packages+ return ()+-}++makeApiDocs :: Sh ()+makeApiDocs = do++ hsFiles <- getHsFiles+ liftIO $ mapM_ print $ hsFiles++ mkdir_p "musicsuite.github.io/docs/api/src"++ let opts = ["-h"::Text, "--odir=musicsuite.github.io/docs/api"]+ -- let opts1 = "--source-module=src/%{MODULE/./-}.html --source-entity=src/%{MODULE/./-}.html#%{NAME}"+ let opts1 = []+ let opts2 = ["--title=The\xA0Music\xA0Suite"] -- Must use nbsp++ run "haddock" (concat [opts, opts1, opts2, fmap unFilePath hsFiles])+ return ()++makeRef :: Sh ()+makeRef = do+ -- TODO check dir exists, otherwise return and warn+ chdir "music-docs" $ do+ run_ "make" ["html"]++ -- cp_r "music-docs/build/" "musicsuite.github.io/docs/ref"+ run_ "cp" ["-r", "-f", "music-docs/build/", "musicsuite.github.io/docs/ref"]++appendNL path = do+ c <- readfile path+ writefile path (c <> "\n")++upload :: Sh ()+upload = do+ chdir "musicsuite.github.io" $ do++ -- Hack: Append a newline to a file so that git commands never fail+ appendNL "docs/ref/index.html"++ run "git" ["add", "docs/api"]+ run "git" ["add", "docs/ref"]+ run "git" ["commit", "-m", "Documentation"]+ run "git" ["push"]+ return ()+++-- TODO move to fgl+-- | Get all labels+labels :: Graph gr => gr a b -> [a]+labels gr = catMaybes . fmap (lab gr) . nodes $ gr++-- | Get node from label+fromLab :: Eq a => Graph gr => a -> gr a b -> Maybe Node+fromLab l' = getFirst . ufold (\(_,n,l,_) -> if l == l' then (<> First (Just n)) else id) mempty++