graphviz-2999.9.0.0: Data/GraphViz/Attributes/Internal.hs

{-# OPTIONS_HADDOCK hide #-}

{- |
   Module      : Data.GraphViz.Attributes.Internal
   Description : Internal Attribute value definitions
   Copyright   : (c) Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   This module is defined so as to avoid exposing internal functions
   in the external API.

 -}

module Data.GraphViz.Attributes.Internal
       ( PortName(..)
       , PortPos(..)
       , CompassPoint(..)
       , compassLookup
       , parseEdgeBasedPP
       ) where

import Data.GraphViz.Parsing
import Data.GraphViz.Printing

import Data.Maybe(isNothing)
import qualified Data.Map as Map
import Data.Map(Map)
import Control.Monad(liftM, liftM2)

-- -----------------------------------------------------------------------------

-- Note that printing and parsing of PortName values is specific to
-- where it's being used: record- and HTML-like labels print/parse
-- them differently from when they're on they're part of PortPos; the
-- default printing and parsing is done for the latter.

-- Should this really be exported from here?  Or in another common module?

-- | Specifies a name for ports (used also in record-based and
--   HTML-like labels).  Note that it is not valid for a 'PortName'
--   value to contain a colon (@:@) character; it is assumed that it
--   doesn't.
newtype PortName = PN { portName :: String }
                 deriving (Eq, Ord, Show, Read)

instance PrintDot PortName where
  unqtDot = unqtDot . portName

  toDot = toDot . portName

instance ParseDot PortName where
  parseUnqt = liftM PN . many1
              . orQuote $ satisfy (`notElem` ['"', ':'])

  parse= quotedParse parseUnqt
         `onFail`
         unqtPortName

unqtPortName :: Parse PortName
unqtPortName = liftM PN quotelessString

-- -----------------------------------------------------------------------------

data PortPos = LabelledPort PortName (Maybe CompassPoint)
             | CompassPoint CompassPoint
    deriving (Eq, Ord, Show, Read)

instance PrintDot PortPos where
    unqtDot (LabelledPort n mc) = unqtDot n
                                  <> maybe empty (colon <>) (fmap unqtDot mc)
    unqtDot (CompassPoint cp)   = unqtDot cp

    toDot (LabelledPort n Nothing) = toDot n
    toDot lp@LabelledPort{}        = doubleQuotes $ unqtDot lp
    toDot cp                       = unqtDot cp

instance ParseDot PortPos where
    parseUnqt = do n <- parseUnqt
                   mc <- optional $ character ':' >> parseUnqt
                   return $ if isNothing mc
                            then checkPortName n
                            else LabelledPort n mc

    parse = quotedParse parseUnqt
            `onFail`
            liftM checkPortName unqtPortName

checkPortName    :: PortName -> PortPos
checkPortName pn = maybe (LabelledPort pn Nothing) CompassPoint
                   . flip Map.lookup compassLookup
                   $ portName pn

-- | When attached to a node in a DotEdge definition, the 'PortName'
--   and the 'CompassPoint' can be in separate quotes.
parseEdgeBasedPP :: Parse PortPos
parseEdgeBasedPP = liftM2 LabelledPort parse (liftM Just $ character ':' >> parse)
                   `onFail`
                   parse

data CompassPoint = North
                  | NorthEast
                  | East
                  | SouthEast
                  | South
                  | SouthWest
                  | West
                  | NorthWest
                  | CenterPoint
                  | NoCP
                    deriving (Eq, Ord, Bounded, Enum, Show, Read)

instance PrintDot CompassPoint where
    unqtDot NorthEast   = text "ne"
    unqtDot NorthWest   = text "nw"
    unqtDot North       = text "n"
    unqtDot East        = text "e"
    unqtDot SouthEast   = text "se"
    unqtDot SouthWest   = text "sw"
    unqtDot South       = text "s"
    unqtDot West        = text "w"
    unqtDot CenterPoint = text "c"
    unqtDot NoCP        = text "_"

instance ParseDot CompassPoint where
    -- Have to take care of longer parsing values first.
    parseUnqt = oneOf [ stringRep NorthEast "ne"
                      , stringRep NorthWest "nw"
                      , stringRep North "n"
                      , stringRep SouthEast "se"
                      , stringRep SouthWest "sw"
                      , stringRep South "s"
                      , stringRep East "e"
                      , stringRep West "w"
                      , stringRep CenterPoint "c"
                      , stringRep NoCP "_"
                      ]

compassLookup :: Map String CompassPoint
compassLookup = Map.fromList [ ("ne", NorthEast)
                             , ("nw", NorthWest)
                             , ("n", North)
                             , ("e", East)
                             , ("se", SouthEast)
                             , ("sw", SouthWest)
                             , ("s", South)
                             , ("w", West)
                             , ("c", CenterPoint)
                             , ("_", NoCP)
                             ]

-- -----------------------------------------------------------------------------