content: {- Copyright (c) 2011 Galois, Inc. -}
  {-|
  
  Rewrite the paths of a cabal-install config file, canonicalizing them
  relative to the current path, supporting limited tilde expansion
  (tilde expansion for the current user only)
  
  This module is written so that it will work out-of-the-box with GHC >=
  6.8 && < 6.13 with no other packages installed.
  
  -}
  {-# LANGUAGE CPP #-}
  
  module Distribution.Dev.RewriteCabalConfig
      ( rewriteCabalConfig
      , Rewrite(..)
      , ppTopLevel
      , readConfigF
      , readConfigF_
      )
  where
  
  import qualified Control.Exception as Ex ( catch, IOException )
  import Control.Applicative               ( Applicative, pure, (<$>) )
  import Data.Maybe                        ( fromMaybe )
  import Data.Traversable                  ( traverse, Traversable )
  import Distribution.ParseUtils           ( Field(..), readFields, ParseResult(..) )
  import Distribution.Simple.Utils         ( readUTF8File )
  import Text.PrettyPrint.HughesPJ
  
  data Rewrite = Rewrite { homeDir          :: FilePath
                         , sandboxDir       :: FilePath
                         , packageDb        :: FilePath
                         , quoteInstallDirs :: Bool
                         }
  
  readConfig :: String -> Either String [Field]
  readConfig s = case readFields s of
                   ParseOk _ fs  -> Right fs
                   ParseFailed e -> Left $ show e
  
  -- XXX: we should avoid this lazy IO that leaks a file handle.
  readConfigF :: FilePath -> IO (Either String [Field])
  readConfigF fn = (readConfig <$> readUTF8File fn) `Ex.catch` handler
    where
      handler :: Ex.IOException -> IO (Either String [Field])
      handler  = return . Left . show
  
  readConfigF_ :: FilePath -> IO [Field]
  readConfigF_ fn = either error id <$> readConfigF fn
  
  -- |Rewrite a cabal-install config file so that all paths are made
  -- absolute and canonical.
  rewriteCabalConfig :: Applicative f => Rewrite -> [Field] -> f [Field]
  rewriteCabalConfig r = rewriteConfig expand (setPackageDb $ packageDb r)
    where
      expand = expandCabalConfig (quoteInstallDirs r) (homeDir r) (sandboxDir r)
  
  -- |Given an expansion configuration, read the input config file and
  -- write the expansion into the output config file
  rewriteConfig :: Applicative f =>
                   Expand f -> ([Field] -> [Field]) -> [Field] -> f [Field]
  rewriteConfig expand proc fs = proc <$> rewriteTopLevel expand fs
  
  setPackageDb :: FilePath -> [Field] -> [Field]
  setPackageDb pkgDb = (F 0 "package-db" pkgDb:) . filter (not . isPackageDb)
      where
        isPackageDb (F _ "package-db" _) = True
        isPackageDb _                  = False
  
  rewriteTopLevel :: Applicative f => Expand f -> [Field] -> f [Field]
  rewriteTopLevel = traverse . rewriteField
  
  rewriteField :: Applicative m => Expand m -> Field -> m Field
  rewriteField expand field =
      case field of
        F l name val -> F l name <$> rewriteLeaf name val
        Section l name key fs -> Section l name key <$>
                                 rewriteSection name fs
        _ -> error $ "Only top-level fields and sections "
                  ++ "supported. Not: " ++ show field
      where
        rewriteLeaf name val
            | name `elem` eLeaves expand = eExpand expand val
            | otherwise                  = pure val
  
        rewriteSection s = rewriteTopLevel $
                           fromMaybe don'tExpand $
                           lookup s $ eSections expand
  
  --------------------------------------------------
  -- Output formatting
  
  ppField :: Field -> Doc
  ppField (F _ k v) = text k <> colon <+> text v
  ppField (Section _ k v fs) = (text k <+> text v) $+$
                               nest 2 (vcat $ map ppField fs)
  ppField f = error $ "Pretty printing not implemented: " ++ show f
  
  ppTopLevel :: [Field] -> Doc
  ppTopLevel = vcat . map ppField
  
  --------------------------------------------------
  -- Expanding fields
  
  data Expand f = Expand { eExpand :: String -> f String
                         , eLeaves :: [String]
                         , eSections :: [(String, Expand f)]
                         }
  
  -- |Replace a tilde as an initial path segment with a path.
  expandTilde :: FilePath -> String -> String
  expandTilde home s = case break (== '/') s of
                         ("~", rest) -> home ++ rest
                         _           -> s
  
  -- |Replace a tilde as an initial path segment with a path.
  expandDot :: FilePath -> String -> String
  expandDot sandbox s = case break (== '/') s of
                          (".", rest) -> sandbox ++ rest
                          _           -> s
  
  -- |Identity expansion
  don'tExpand :: Applicative f => Expand f
  don'tExpand = Expand pure [] []
  
  -- This is the part that's specific to the cabal-install config file:
  -- These are the parts of the config file that are paths into the
  -- local filesystem. Ideally, we'd use the cabal-install Config module
  -- and operate on the datatype instead of the raw config file, but
  -- that's internal to the cabal-install config file, so we use this
  -- ad-hoc approach instead.
  --
  -- If the cabal-install config file changes, or if this list is not
  -- complete, this code will have to be updated.
  expandCabalConfig :: Applicative f =>
                       Bool -- ^Whether the install-dirs section of the
                            -- cabal config file will quote paths.
                            -- Versions of cabal-install prior to 0.9
                            -- required quoting. Versions 0.9 and later
                            -- forbit it.
                       -> FilePath -> FilePath -> Expand f
  expandCabalConfig shouldQuote home sandbox =
      Expand { eExpand = ePath
             , eLeaves = [ "remote-repo-cache"
                         , "local-repo"
                         , "with-compiler"
                         , "with-hc-pkg"
                         , "scratchdir"
                         , "package-db"
                         , "extra-include-dirs"
                         , "extra-lib-dirs"
                         , "doc-index-file"
                         , "root-cmd"
                         , "symlink-bindir"
                         , "build-summary"
                         , "build-log"
                         ]
             , eSections = [("install-dirs", expandInstallDirs)]
             }
      where
        expandInstallDirs =
            Expand { eExpand = quote . ePath
                   , eLeaves =
                       [ "prefix"
                       , "bindir"
                       , "libdir"
                       , "libsubdir"
                       , "libexecdir"
                       , "datadir"
                       , "datasubdir"
                       , "docdir"
                       , "htmldir"
                       , "haddockdir"
                       ]
                   , eSections = []
                   }
  
        -- How install-dirs should quote its paths
        quote | shouldQuote = fmap show
              | otherwise   = id
  
        ePath = pure . expandDot sandbox . expandTilde home
  