Cabal-2.0.0.2: Distribution/Text.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Text
-- Copyright   :  Duncan Coutts 2007
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This defines a 'Text' class which is a bit like the 'Read' and 'Show'
-- classes. The difference is that is uses a modern pretty printer and parser
-- system and the format is not expected to be Haskell concrete syntax but
-- rather the external human readable representation used by Cabal.
--
module Distribution.Text (
  Text(..),
  defaultStyle,
  display,
  flatStyle,
  simpleParse,
  stdParse,
  ) where

import Prelude ()
import Distribution.Compat.Prelude

import qualified Distribution.Compat.ReadP as Parse
import qualified Text.PrettyPrint          as Disp

import Data.Version (Version(Version))

class Text a where
  disp  :: a -> Disp.Doc
  parse :: Parse.ReadP r a

-- | The default rendering style used in Cabal for console
-- output. It has a fixed page width and adds line breaks
-- automatically.
defaultStyle :: Disp.Style
defaultStyle = Disp.Style { Disp.mode           = Disp.PageMode
                          , Disp.lineLength     = 79
                          , Disp.ribbonsPerLine = 1.0
                          }

-- | Pretty-prints with the default style.
display :: Text a => a -> String
display = Disp.renderStyle defaultStyle . disp

-- | A style for rendering all on one line.
flatStyle :: Disp.Style
flatStyle = Disp.Style { Disp.mode = Disp.LeftMode
                       , Disp.lineLength = err "lineLength"
                       , Disp.ribbonsPerLine = err "ribbonsPerLine"
                       }
  where
    err x = error ("flatStyle: tried to access " ++ x ++ " in LeftMode. " ++
                   "This should never happen and indicates a bug in Cabal.")

simpleParse :: Text a => String -> Maybe a
simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str
                       , all isSpace s ] of
  []    -> Nothing
  (p:_) -> Just p

stdParse :: Text ver => (ver -> String -> res) -> Parse.ReadP r res
stdParse f = do
  cs   <- Parse.sepBy1 component (Parse.char '-')
  _    <- Parse.char '-'
  ver  <- parse
  let name = intercalate "-" cs
  return $! f ver (lowercase name)
  where
    component = do
      cs <- Parse.munch1 isAlphaNum
      if all isDigit cs then Parse.pfail else return cs
      -- each component must contain an alphabetic character, to avoid
      -- ambiguity in identifiers like foo-1 (the 1 is the version number).

lowercase :: String -> String
lowercase = map toLower

-- -----------------------------------------------------------------------------
-- Instances for types from the base package

instance Text Bool where
  disp  = Disp.text . show
  parse = Parse.choice [ (Parse.string "True" Parse.+++
                          Parse.string "true") >> return True
                       , (Parse.string "False" Parse.+++
                          Parse.string "false") >> return False ]

instance Text Int where
  disp  = Disp.text . show
  parse = (fmap negate $ Parse.char '-' >> parseNat) Parse.+++ parseNat

-- | Parser for non-negative integers.
parseNat :: Parse.ReadP r Int
parseNat = read `fmap` Parse.munch1 isDigit -- TODO: eradicateNoParse


instance Text Version where
  disp (Version branch _tags)     -- Death to version tags!!
    = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch))

  parse = do
      branch <- Parse.sepBy1 parseNat (Parse.char '.')
                -- allow but ignore tags:
      _tags  <- Parse.many (Parse.char '-' >> Parse.munch1 isAlphaNum)
      return (Version branch [])