Names.hs

{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeSynonymInstances       #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Core.Names
-- Copyright   :  (c) 2011-2015 diagrams-core team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- This module defines a type of names which can be used for referring
-- to subdiagrams, and related types.
--
-----------------------------------------------------------------------------

module Diagrams.Core.Names
  (-- * Names
   -- ** Atomic names
    AName(..)
  , _AName

   -- ** Names
  , Name(..)
  , IsName(..)
  , (.>)
  , eachName

   -- ** Qualifiable
  , Qualifiable(..)

  ) where

import           Control.Lens            hiding ((.>))
import qualified Data.Map                as M
import           Data.Semigroup
import qualified Data.Set                as S
import           Data.Typeable

import           Diagrams.Core.Transform
import           Diagrams.Core.Measure

------------------------------------------------------------
--  Names  -------------------------------------------------
------------------------------------------------------------

-- | Class for those types which can be used as names.  They must
--   support 'Typeable' (to facilitate extracting them from
--   existential wrappers), 'Ord' (for comparison and efficient
--   storage) and 'Show'.
--
--   To make an instance of 'IsName', you need not define any methods,
--   just declare it.
--
--   WARNING: it is not recommended to use
--   @GeneralizedNewtypeDeriving@ in conjunction with @IsName@, since
--   in that case the underlying type and the @newtype@ will be
--   considered equivalent when comparing names.  For example:
--
--   @
--     newtype WordN = WordN Int deriving (Show, Ord, Eq, Typeable, IsName)
--   @
--
--   is unlikely to work as intended, since @(1 :: Int)@ and @(WordN 1)@
--   will be considered equal as names.  Instead, use
--
--   @
--     newtype WordN = WordN Int deriving (Show, Ord, Eq, Typeable, IsName)
--     instance IsName WordN
--   @
class (Typeable a, Ord a, Show a) => IsName a where
  toName :: a -> Name
  toName = Name . (:[]) . AName

instance IsName ()
instance IsName Bool
instance IsName Char
instance IsName Int
instance IsName Float
instance IsName Double
instance IsName Integer
instance IsName a => IsName [a]
instance IsName a => IsName (Maybe a)
instance (IsName a, IsName b) => IsName (a,b)
instance (IsName a, IsName b, IsName c) => IsName (a,b,c)

-- | Atomic names.  @AName@ is just an existential wrapper around
--   things which are 'Typeable', 'Ord' and 'Show'.
data AName where
  AName :: (Typeable a, Ord a, Show a) => a -> AName
  deriving Typeable

instance IsName AName where
  toName = Name . (:[])

instance Eq AName where
  AName a1 == AName a2 =
    case cast a2 of
      Nothing  -> False
      Just a2' -> a1 == a2'

instance Ord AName where
  AName a1 `compare` AName a2 =
    case cast a2 of
      Just a2' -> a1 `compare` a2'
      Nothing  -> typeOf a1 `compare` typeOf a2

instance Show AName where
  showsPrec d (AName a) = showParen (d > 10) $
    showString "AName " . showsPrec 11 a

-- | Prism onto 'AName'.
_AName :: (Typeable a, Ord a, Show a) => Prism' AName a
_AName = prism' AName (\(AName a) -> cast a)

-- | A (qualified) name is a (possibly empty) sequence of atomic names.
newtype Name = Name [AName]
  deriving (Eq, Ord, Semigroup, Monoid, Typeable)

instance Rewrapped Name Name
instance Wrapped Name where
  type Unwrapped Name = [AName]
  _Wrapped' = iso (\(Name ns) -> ns) Name

instance Each Name Name AName AName where
  each = _Wrapped . traversed
  {-# INLINE each #-}

-- | Traversal over each name in a 'Name' that matches the target type.
--
-- @
-- >>> toListOf eachName ('a' .> False .> 'b') :: String
-- "ab"
-- >>> 'a' .> True .> 'b' & eachName %~ not
-- 'a' .> False .> 'b'
-- @
--
-- Note that the type of the name is very important.
--
-- @
-- >>> sumOf eachName ((1::Int) .> (2 :: Integer) .> (3 :: Int)) :: Int
-- 4
-- >>> sumOf eachName ((1::Int) .> (2 :: Integer) .> (3 :: Int)) :: Integer
-- 2
-- @
eachName :: (Typeable a, Ord a, Show a) => Traversal' Name a
eachName = each . _AName

instance Show Name where
  showsPrec d (Name xs) = case xs of
    []     -> showParen (d > 10) $ showString "toName []"
    [n]    -> showParen (d > 10) $ showString "toName " . showsName 11 n
    (n:ns) -> showParen (d > 5)  $ showsName 6 n . go ns
      where
        go (y:ys) = showString " .> " . showsName 6 y . go ys
        go _      = id
    where showsName dd (AName a) = showsPrec dd a

instance IsName Name where
  toName = id

-- | Convenient operator for writing qualified names with atomic
--   components of different types.  Instead of writing @toName a1 \<\>
--   toName a2 \<\> toName a3@ you can just write @a1 .> a2 .> a3@.
(.>) :: (IsName a1, IsName a2) => a1 -> a2 -> Name
a1 .> a2 = toName a1 <> toName a2

-- | Instances of 'Qualifiable' are things which can be qualified by
--   prefixing them with a name.
class Qualifiable q where
  -- | Qualify with the given name.
  (.>>) :: IsName a => a -> q -> q

-- | Of course, names can be qualified using @(.>)@.
instance Qualifiable Name where
  (.>>) = (.>)

instance Qualifiable a => Qualifiable (TransInv a) where
  (.>>) n = over (_Unwrapping' TransInv) (n .>>)

instance (Qualifiable a, Qualifiable b) => Qualifiable (a,b) where
  n .>> (a,b) = (n .>> a, n .>> b)

instance (Qualifiable a, Qualifiable b, Qualifiable c) => Qualifiable (a,b,c) where
  n .>> (a,b,c) = (n .>> a, n .>> b, n .>> c)

instance Qualifiable a => Qualifiable [a] where
  n .>> as = map (n .>>) as

instance (Ord a, Qualifiable a) => Qualifiable (S.Set a) where
  n .>> s = S.map (n .>>) s

instance Qualifiable a => Qualifiable (M.Map k a) where
  n .>> m = fmap (n .>>) m

instance Qualifiable a => Qualifiable (b -> a) where
  n .>> f = (n .>>) . f

instance Qualifiable a => Qualifiable (Measured n a) where
  n .>> m = fmap (n .>>) m

infixr 5 .>>
infixr 5 .>