Tools.hs

module Cartel.Tools
  ( -- * Building constraints

    -- | Helpers to build many common version constraints.

    -- ** Building constraint trees
    (&&&)
  , (|||)
  , lt
  , gt
  , eq
  , ltEq
  , gtEq

  -- ** Building package specifications
  , closedOpen
  , apiVersion
  , nextBreaking
  , nextMajor
  , exactly

  -- * Rendering a cabal file
  , render
  , renderString

  -- * Getting a list of all modules in a directory tree
  , modules
  , fileExtensions
  , modulesWithExtensions
  ) where

import qualified Cartel.Ast as A
import qualified Cartel.Render as R
import qualified System.Directory as D
import qualified System.FilePath as P
import System.FilePath ((</>))
import qualified Data.Char as C
import Data.List (intersperse, sortBy)
import Data.Monoid
import qualified Data.Version as V
import Data.Time
import qualified Paths_cartel
import qualified System.IO as IO

(&&&) :: A.ConstrTree -> A.ConstrTree -> A.ConstrTree
l &&& r = A.Branch A.And l r

infixr 3 &&&

(|||) :: A.ConstrTree -> A.ConstrTree -> A.ConstrTree
l ||| r = A.Branch A.Or l r

infixr 2 |||

lt :: [Int] -> A.ConstrTree
lt = A.Leaf . A.Constraint LT . A.Version

gt :: [Int] -> A.ConstrTree
gt = A.Leaf . A.Constraint GT . A.Version

eq :: [Int] -> A.ConstrTree
eq = A.Leaf . A.Constraint EQ . A.Version

ltEq :: [Int] -> A.ConstrTree
ltEq v = lt v ||| eq v

gtEq :: [Int] -> A.ConstrTree
gtEq v = gt v ||| eq v

-- | Creates a package interval that is closed on the left, open on
-- the right.  Useful for the common case under the PVP to specify
-- that you depend on a version that is at least a particular
-- version, but less than another version.
--
-- > closedOpen "bytestring" [0,17] [0,19] ==> bytestring >= 0.17 && < 0.19

closedOpen
  :: String
  -- ^ Package name
  -> [Int]
  -- ^ Version number for lower bound
  -> [Int]
  -- ^ Version number for upper bound
  -> A.Package
  -- ^ Resulting contraints
closedOpen n l u = A.Package n $ Just (gtEq l &&& lt u)

-- | Specifies a particular API version.  Useful to lock your
-- package dependencies down to a particular API version.
--
-- > apiVersion "base" [1] ==> base >= 1 && < 2
-- > apiVersion "base" [1,2] ==> base >= 1.2 && < 1.3
-- > apiVersion "base" [1,2,3] ==> base >= 1.2.3 && < 1.2.4

apiVersion :: String -> [Int] -> A.Package
apiVersion n v = closedOpen n v u
  where
    u = case v of
      [] -> error "apiVersion: requires a non-empty list argument"
      _ -> init v ++ [succ (last v)]

-- | Depends on the version given, up to the next breaking API
-- change.
--
-- > nextBreaking "base" [4] ==> base >= 4 && < 4.1
-- > nextBreaking "base" [4,1] ==> base >= 4.1 && < 4.2
-- > nextBreaking "base" [4,7,0,0] ==> base >= 4.7.0.0 && < 4.8

nextBreaking
  :: String
  -> [Int]
  -> A.Package
nextBreaking n v = closedOpen n v u
  where
    u = case v of
      [] -> error "nextBreaking: requires a non-empty list argument"
      x:[] -> [x, 1]
      x:y:_ -> x : succ y : []

-- | Depends on the version given, up to the next time the first
-- digit increments.  Useful for @base@.
--
-- > nextBreaking "base" [4] ==> base >= 4 && < 5

nextMajor
  :: String
  -> [Int]
  -> A.Package
nextMajor n v = closedOpen n v u
  where
    u = case v of
      [] -> error "nextMajor: requires a non-empty list argument"
      x:_ -> succ x : []

-- | Depends on exactly this version only.
--
-- > exactly "base" [4,5,0,0] ==> base ==4.5.0.0

exactly :: String -> [Int] -> A.Package
exactly n v = A.Package n (Just $ eq v)

-- | Common extensions of Haskell files and files that are
-- preprocessed into Haskell files.  Includes:
--
-- * hs (Haskell)
-- * lhs (literate Haskell)
-- * gc (greencard)
-- * chs (c2hs)
-- * hsc (hsc2hs)
-- * y and ly (happy)
-- * x (alex)
-- * cpphs

fileExtensions :: [String]
fileExtensions =
  [ "hs"
  , "lhs"
  , "gc"
  , "chs"
  , "hsc"
  , "y"
  , "ly"
  , "x"
  , "cpphs"
  ]

interestingFile
  :: [String]
  -- ^ Extensions of module files
  -> FilePath
  -> Bool

interestingFile xs s = case s of
  "" -> False
  x:_
    | not (C.isUpper x) -> False
    | otherwise -> let mayExt = P.takeExtension s
                   in case mayExt of
                       [] -> False
                       _ : ext -> ext `elem` xs

interestingDir :: FilePath -> Bool
interestingDir p = case p of
  [] -> False
  x:_
    | not (C.isUpper x) -> False
    | otherwise -> not $ '.' `elem` p

-- | Gets all Haskell modules in a given directory tree.  Only files
-- with one of the extensions listed in 'fileExtensions' are
-- returned.  Files and directories that do not begin with an
-- uppercase letter are ignored.  (This also ignores files that
-- start with a dot.)  Directories with a dot anywhere in the name
-- are ignored.

modules
  :: FilePath
  -- ^ Start searching within this directory.
  -> IO [String]
  -- ^ A list of Haskell modules in the given directory tree.  The
  -- file contents are not examined; only the file names matter.
  -- Returned as a list of dotted names.
modules = modulesWithExtensions fileExtensions


-- | Gets all Haskell modules in a given directory tree.  Allows you
-- to specify what extensions you are interested in.

modulesWithExtensions
  :: [String]
  -- ^ Look for files that have one of these extensions.
  -- 'fileExtensions' covers the most common cases.  Files without
  -- one of these extensions are ignored.  Files and directories
  -- that do not begin with an uppercase letter are ignored.  (This
  -- also ignores files that start with a dot.)  Directories with a
  -- dot anywhere in the name are ignored.

  -> FilePath
  -- ^ Start searching within this directory.

  -> IO [String]
  -- ^ A list of Haskell modules in the given directory tree.  The
  -- file contents are not examined; only the file names matter.
  -- Returned as a list of dotted names.

modulesWithExtensions exts start
  = fmap (map modName . sortBy sorter . map reverse)
  $ modulesInDir exts start []
  where
    modName = concat . intersperse "."

sorter :: [String] -> [String] -> Ordering
sorter x y = mconcat (zipWith compare x y) <> compare lenX lenY
  where
    (lenX, lenY) = (length x, length y)

modulesInDir
  :: [String]
  -- ^ Extensions of module files
  -> FilePath
  -- Search is rooted in this directory
  -> [FilePath]
  -- ^ Stack of directories we're in
  -> IO [[String]]
  -- ^ Returns a list of modules in this directory.
modulesInDir exts start dirs = do
  cs <- D.getDirectoryContents (start </> P.joinPath (reverse dirs))
  fmap concat . mapM (processFile exts start dirs) $ cs

processFile
  :: [String]
  -- ^ Extensions of module files
  -> FilePath
  -- ^ Search is rooted in this directory
  -> [FilePath]
  -- Stack of directories we're in, including current directory
  -> FilePath
  -- ^ Interesting file under investigation
  -> IO [[String]]
processFile exts start dirs this = do
  isDir <- D.doesDirectoryExist
    (start </> (P.joinPath . reverse $ this : dirs))
  if isDir
    then if interestingDir this
          then modulesInDir exts start (this : dirs)
          else return []
    else return $ if interestingFile exts this
          then [(P.dropExtension this : dirs)]
          else []

-- | Renders a 'A.Cabal' data type as a string.
renderString
  :: String
  -- ^ Name of program used
  -> ZonedTime
  -- ^ When this output is being created
  -> V.Version
  -- ^ Cartel package version
  -> A.Cabal
  -> String
renderString nm zt ver cbl = hdr ++ R.cabal cbl
  where
    hdr = unlines $
      [ "-- This Cabal file generated using the Cartel library."
      , "-- Cartel is available at:"
      , "-- http://www.github.com/massysett/cartel"
      , "--"
      ] ++ case nm of
            [] -> []
            _ -> ["-- Script name used to generate: " ++ nm]
      ++
      [ "-- Generated on: " ++ show zt
      , "-- Cartel library version: " ++ showVer
      ]
    showVer = concat
      . intersperse "."
      . map show
      . V.versionBranch
      $ ver

-- | Render a Cabal file to standard output.  The output will have
-- comments at the beginning indicating that it was built with
-- Cartel, and what version of the Cartel library was used, and when
-- the output was produced, along with (optionally) the filename of
-- the program used to produce the output.
--
-- Ensures that the output is UTF-8, as required by Cabal.
render
  :: String
  -- ^ The name of the program used to produce this output.  Put the
  -- name of your script here so it can appear in the output.  This
  -- is optional; to omit it, use the empty string here.

  -> A.Cabal
  -> IO ()
render nm cbl = do
  zt <- getZonedTime
  IO.hSetBinaryMode IO.stdout False
  IO.hSetEncoding IO.stdout IO.utf8
  putStr $ renderString nm zt Paths_cartel.version cbl