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