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

{-# OPTIONS_GHC -fno-warn-unused-imports #-}
  -- for Data.Semigroup import, which becomes redundant under GHC 8.4

-----------------------------------------------------------------------------
-- |
-- 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 = [AName] -> Name
Name ([AName] -> Name) -> (a -> [AName]) -> a -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AName -> [AName] -> [AName]
forall a. a -> [a] -> [a]
:[]) (AName -> [AName]) -> (a -> AName) -> a -> [AName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AName
forall a. (Typeable a, Ord a, Show a) => a -> AName
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 :: AName -> Name
toName = [AName] -> Name
Name ([AName] -> Name) -> (AName -> [AName]) -> AName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AName -> [AName] -> [AName]
forall a. a -> [a] -> [a]
:[])

instance Eq AName where
  AName a
a1 == :: AName -> AName -> Bool
== AName a
a2 =
    case a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a2 of
      Maybe a
Nothing  -> Bool
False
      Just a
a2' -> a
a1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a2'

instance Ord AName where
  AName a
a1 compare :: AName -> AName -> Ordering
`compare` AName a
a2 =
    case a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a2 of
      Just a
a2' -> a
a1 a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` a
a2'
      Maybe a
Nothing  -> a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a1 TypeRep -> TypeRep -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a2

instance Show AName where
  showsPrec :: Int -> AName -> ShowS
showsPrec Int
d (AName a
a) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString String
"AName " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 a
a

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

-- | A (qualified) name is a (possibly empty) sequence of atomic names.
newtype Name = Name [AName]
  deriving (Name -> Name -> Bool
(Name -> Name -> Bool) -> (Name -> Name -> Bool) -> Eq Name
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c== :: Name -> Name -> Bool
Eq, Eq Name
Eq Name
-> (Name -> Name -> Ordering)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Name)
-> (Name -> Name -> Name)
-> Ord Name
Name -> Name -> Bool
Name -> Name -> Ordering
Name -> Name -> Name
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Name -> Name -> Name
$cmin :: Name -> Name -> Name
max :: Name -> Name -> Name
$cmax :: Name -> Name -> Name
>= :: Name -> Name -> Bool
$c>= :: Name -> Name -> Bool
> :: Name -> Name -> Bool
$c> :: Name -> Name -> Bool
<= :: Name -> Name -> Bool
$c<= :: Name -> Name -> Bool
< :: Name -> Name -> Bool
$c< :: Name -> Name -> Bool
compare :: Name -> Name -> Ordering
$ccompare :: Name -> Name -> Ordering
$cp1Ord :: Eq Name
Ord, b -> Name -> Name
NonEmpty Name -> Name
Name -> Name -> Name
(Name -> Name -> Name)
-> (NonEmpty Name -> Name)
-> (forall b. Integral b => b -> Name -> Name)
-> Semigroup Name
forall b. Integral b => b -> Name -> Name
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Name -> Name
$cstimes :: forall b. Integral b => b -> Name -> Name
sconcat :: NonEmpty Name -> Name
$csconcat :: NonEmpty Name -> Name
<> :: Name -> Name -> Name
$c<> :: Name -> Name -> Name
Semigroup, Semigroup Name
Name
Semigroup Name
-> Name
-> (Name -> Name -> Name)
-> ([Name] -> Name)
-> Monoid Name
[Name] -> Name
Name -> Name -> Name
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Name] -> Name
$cmconcat :: [Name] -> Name
mappend :: Name -> Name -> Name
$cmappend :: Name -> Name -> Name
mempty :: Name
$cmempty :: Name
$cp1Monoid :: Semigroup Name
Monoid, Typeable)

instance Rewrapped Name Name
instance Wrapped Name where
  type Unwrapped Name = [AName]
  _Wrapped' :: p (Unwrapped Name) (f (Unwrapped Name)) -> p Name (f Name)
_Wrapped' = (Name -> [AName])
-> ([AName] -> Name) -> Iso Name Name [AName] [AName]
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(Name [AName]
ns) -> [AName]
ns) [AName] -> Name
Name

instance Each Name Name AName AName where
  each :: (AName -> f AName) -> Name -> f Name
each = ([AName] -> f [AName]) -> Name -> f Name
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped (([AName] -> f [AName]) -> Name -> f Name)
-> ((AName -> f AName) -> [AName] -> f [AName])
-> (AName -> f AName)
-> Name
-> f Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AName -> f AName) -> [AName] -> f [AName]
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
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 :: Traversal' Name a
eachName = (AName -> f AName) -> Name -> f Name
forall s t a b. Each s t a b => Traversal s t a b
each ((AName -> f AName) -> Name -> f Name)
-> ((a -> f a) -> AName -> f AName) -> (a -> f a) -> Name -> f Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f a) -> AName -> f AName
forall a. (Typeable a, Ord a, Show a) => Prism' AName a
_AName

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

instance IsName Name where
  toName :: Name -> Name
toName = Name -> Name
forall a. a -> a
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
a1 .> :: a1 -> a2 -> Name
.> a2
a2 = a1 -> Name
forall a. IsName a => a -> Name
toName a1
a1 Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> a2 -> Name
forall a. IsName a => a -> Name
toName a2
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
  .>> :: a -> Name -> Name
(.>>) = a -> Name -> Name
forall a1 a2. (IsName a1, IsName a2) => a1 -> a2 -> Name
(.>)

instance Qualifiable a => Qualifiable (TransInv a) where
  .>> :: a -> TransInv a -> TransInv a
(.>>) a
n = ASetter
  (TransInv a)
  (TransInv a)
  (TransInv (TransInv a))
  (TransInv (TransInv a))
-> (TransInv (TransInv a) -> TransInv (TransInv a))
-> TransInv a
-> TransInv a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Unwrapped (TransInv (TransInv a)) -> TransInv (TransInv a))
-> Iso' (Unwrapped (TransInv (TransInv a))) (TransInv (TransInv a))
forall s. Wrapped s => (Unwrapped s -> s) -> Iso' (Unwrapped s) s
_Unwrapping' Unwrapped (TransInv (TransInv a)) -> TransInv (TransInv a)
forall t. t -> TransInv t
TransInv) (a
n a -> TransInv (TransInv a) -> TransInv (TransInv a)
forall q a. (Qualifiable q, IsName a) => a -> q -> q
.>>)

instance (Qualifiable a, Qualifiable b) => Qualifiable (a,b) where
  a
n .>> :: a -> (a, b) -> (a, b)
.>> (a
a,b
b) = (a
n a -> a -> a
forall q a. (Qualifiable q, IsName a) => a -> q -> q
.>> a
a, a
n a -> b -> b
forall q a. (Qualifiable q, IsName a) => a -> q -> q
.>> b
b)

instance (Qualifiable a, Qualifiable b, Qualifiable c) => Qualifiable (a,b,c) where
  a
n .>> :: a -> (a, b, c) -> (a, b, c)
.>> (a
a,b
b,c
c) = (a
n a -> a -> a
forall q a. (Qualifiable q, IsName a) => a -> q -> q
.>> a
a, a
n a -> b -> b
forall q a. (Qualifiable q, IsName a) => a -> q -> q
.>> b
b, a
n a -> c -> c
forall q a. (Qualifiable q, IsName a) => a -> q -> q
.>> c
c)

instance Qualifiable a => Qualifiable [a] where
  a
n .>> :: a -> [a] -> [a]
.>> [a]
as = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a
n a -> a -> a
forall q a. (Qualifiable q, IsName a) => a -> q -> q
.>>) [a]
as

instance (Ord a, Qualifiable a) => Qualifiable (S.Set a) where
  a
n .>> :: a -> Set a -> Set a
.>> Set a
s = (a -> a) -> Set a -> Set a
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (a
n a -> a -> a
forall q a. (Qualifiable q, IsName a) => a -> q -> q
.>>) Set a
s

instance Qualifiable a => Qualifiable (M.Map k a) where
  a
n .>> :: a -> Map k a -> Map k a
.>> Map k a
m = (a -> a) -> Map k a -> Map k a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
n a -> a -> a
forall q a. (Qualifiable q, IsName a) => a -> q -> q
.>>) Map k a
m

instance Qualifiable a => Qualifiable (b -> a) where
  a
n .>> :: a -> (b -> a) -> b -> a
.>> b -> a
f = (a
n a -> a -> a
forall q a. (Qualifiable q, IsName a) => a -> q -> q
.>>) (a -> a) -> (b -> a) -> b -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
f

instance Qualifiable a => Qualifiable (Measured n a) where
  a
n .>> :: a -> Measured n a -> Measured n a
.>> Measured n a
m = (a -> a) -> Measured n a -> Measured n a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
n a -> a -> a
forall q a. (Qualifiable q, IsName a) => a -> q -> q
.>>) Measured n a
m

infixr 5 .>>
infixr 5 .>