module Cartel.Tools
  ( -- * Logic trees
    LogicTree(..)
  
    -- * 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

  -- * Field class
  , Field(..)

  -- ** Conditionals
  , cif
  , system
  , arch
  , impl
  , flag
  , true
  , false

  -- ** Build info builders
  , buildDepends
  , otherModules
  , hsSourceDirs
  , extensions
  , buildTools
  , buildable
  , ghcOptions
  , ghcProfOptions
  , ghcSharedOptions
  , hugsOptions
  , nhc98Options
  , includes
  , installIncludes
  , includeDirs
  , cSources
  , extraLibraries
  , extraLibDirs
  , ccOptions
  , cppOptions
  , ldOptions
  , pkgConfigDepends
  , frameworks
  , defaultLanguage

  -- * 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

class LogicTree a where
  (&&&) :: a -> a -> a
  (|||) :: a -> a -> a

infixr 3 &&&
infixr 2 |||

instance LogicTree A.ConstrTree where
  l &&& r = A.Branch A.And l r
  l ||| r = A.Branch A.Or l r

instance LogicTree A.CondTree where
  l &&& r = A.CBranch A.And l r
  l ||| r = A.CBranch A.Or l r


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 []

-- | Things that can be an item in a field in a Cabal file.
class Field a where

  -- | Takes a conditional block and wraps it in the field type.
  conditional :: A.CondBlock a -> a

  -- | Takes a build information field and wraps it in the field
  -- type.
  buildInfo :: A.BuildInfoField -> a

instance Field A.LibraryField where
  conditional = A.LibConditional
  buildInfo = A.LibInfo

instance Field A.ExecutableField where
  conditional = A.ExeConditional
  buildInfo = A.ExeInfo

instance Field A.TestSuiteField where
  conditional = A.TestConditional
  buildInfo = A.TestInfo

instance Field A.BenchmarkField where
  conditional = A.BenchmarkConditional
  buildInfo = A.BenchmarkInfo

-- # Build info helpers
buildDepends :: Field a => [A.Package] -> a
buildDepends = buildInfo . A.BuildDepends

otherModules :: Field a => [String] -> a
otherModules = buildInfo . A.OtherModules

hsSourceDirs :: Field a => [String] -> a
hsSourceDirs = buildInfo . A.HsSourceDirs

extensions :: Field a => [String] -> a
extensions = buildInfo . A.Extensions

buildTools :: Field a => [A.Package] -> a
buildTools = buildInfo . A.BuildTools

buildable :: Field a => Bool -> a
buildable = buildInfo . A.Buildable

ghcOptions :: Field a => [String] -> a
ghcOptions = buildInfo . A.GHCOptions

ghcProfOptions :: Field a => [String] -> a
ghcProfOptions = buildInfo . A.GHCProfOptions

ghcSharedOptions :: Field a => [String] -> a
ghcSharedOptions = buildInfo . A.GHCSharedOptions

hugsOptions :: Field a => [String] -> a
hugsOptions = buildInfo . A.HugsOptions

nhc98Options :: Field a => [String] -> a
nhc98Options = buildInfo . A.Nhc98Options

includes :: Field a => [String] -> a
includes = buildInfo . A.Includes

installIncludes :: Field a => [String] -> a
installIncludes = buildInfo . A.InstallIncludes

includeDirs :: Field a => [String] -> a
includeDirs = buildInfo . A.IncludeDirs

cSources :: Field a => [String] -> a
cSources = buildInfo . A.CSources

extraLibraries :: Field a => [String] -> a
extraLibraries = buildInfo . A.ExtraLibraries

extraLibDirs :: Field a => [String] -> a
extraLibDirs = buildInfo . A.ExtraLibDirs

ccOptions :: Field a => [String] -> a
ccOptions = buildInfo . A.CCOptions

cppOptions :: Field a => [String] -> a
cppOptions = buildInfo . A.CPPOptions

ldOptions :: Field a => [String] -> a
ldOptions = buildInfo . A.LDOptions

pkgConfigDepends :: Field a => [A.Package] -> a
pkgConfigDepends = buildInfo . A.PkgConfigDepends

frameworks :: Field a => [String] -> a
frameworks = buildInfo . A.Frameworks

defaultLanguage :: Field a => A.Language -> a
defaultLanguage = buildInfo . A.DefaultLanguage

-- | Builds @if@ statements.  Use with the following functions, such
-- as 'flag', to make it easy to build conditional blocks.  For
-- example:
--
-- > cif (flag "buildExe") [buildable True] [buildable False]
--
-- A little more complicated:
--
-- > cif (flag "buildExe" &&& system "windows")
-- >   [buildable True] [buildable False]
cif
  :: Field a
  => A.CondTree
  -- ^ Condition to satisfy
  -> [a]
  -- ^ Use these results if condition is true
  -> [a]
  -- ^ Use these results if condition if false
  -> a
cif tree ifTrue ifFalse =
  conditional $ A.CondBlock tree ifTrue ifFalse

-- | Operating system; tested against @System.Info.os@ on the
-- target system.
system :: String -> A.CondTree
system = A.CLeaf . A.OS

-- | Argument is matched against @System.Info.arch@ on the target
-- system.
arch :: String -> A.CondTree
arch = A.CLeaf . A.Arch

-- | Tests for the configured Haskell implementation.
impl :: A.Compiler -> Maybe A.ConstrTree -> A.CondTree
impl cm cn = A.CLeaf $ A.Impl (cm, cn)

-- | Evaluates to the current assignment of the flag of the given
-- name.  Flag names are case insensitive.  Testing for flags that
-- have not been introduced with a flag section is an error.
flag :: String -> A.CondTree
flag = A.CLeaf . A.CFlag

-- | Always true.
true :: A.CondTree
true = A.CLeaf A.CTrue

-- | Always false.
false :: A.CondTree
false = A.CLeaf A.CFalse


-- | 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