    {-# LANGUAGE CPP                   #-}
    {-# LANGUAGE FlexibleContexts      #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE StandaloneDeriving    #-}
    {-# LANGUAGE TypeFamilies          #-}
    {-# LANGUAGE UndecidableInstances  #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Diagrams.Located
    -- Copyright   :  (c) 2013-2015 diagrams-lib team (see LICENSE)
    -- License     :  BSD-style (see LICENSE)
    -- Maintainer  :  diagrams-discuss@googlegroups.com
    --
    -- \"Located\" things, /i.e./ things with a concrete location:
    -- intuitively, @Located a ~ (a, Point)@.  Wrapping a translationally
    -- invariant thing (/e.g./ a 'Segment' or 'Trail') in @Located@ pins
    -- it down to a particular location and makes it no longer
    -- translationally invariant.
    --
    -----------------------------------------------------------------------------

    module Diagrams.Located
        ( Located (..)
        , at, viewLoc, mapLoc, located, _loc
        )
        where

    import           Control.Lens            (Lens, Lens')
    #if __GLASGOW_HASKELL__ < 710
    import           Data.Functor            ((<$>))
    #endif
    import           Text.Read

    import           Linear.Affine
    import           Linear.Vector

    import           Diagrams.Core
    import           Diagrams.Core.Transform
    import           Diagrams.Parametric

    -- | \"Located\" things, /i.e./ things with a concrete location:
    --   intuitively, @Located a ~ (Point, a)@.  Wrapping a translationally
    --   invariant thing (/e.g./ a 'Segment' or 'Trail') in 'Located' pins
    --   it down to a particular location and makes it no longer
    --   translationally invariant.
    --
    --   @Located@ is intentionally abstract.  To construct @Located@
    --   values, use 'at'.  To destruct, use 'viewLoc', 'unLoc', or 'loc'.
    --   To map, use 'mapLoc'.
    --
    --   Much of the utility of having a concrete type for the @Located@
    --   concept lies in the type class instances we can give it.  The
    --   'HasOrigin', 'Transformable', 'Enveloped', 'Traced', and
    --   'TrailLike' instances are particularly useful; see the documented
    --   instances below for more information.
    data Located a =
      Loc { loc   :: Point (V a) (N a)  -- ^ Project out the
                                    --   location of a @Located@
                                    --   value.
          , unLoc :: a              -- ^ Project the value
                                    --   of type @a@ out of
                                    --   a @Located a@,
                                    --   discarding the
                                    --   location.
          }

    infix 5 `at`

    -- | Construct a @Located a@ from a value of type @a@ and a location.
    --   @at@ is intended to be used infix, like @x \`at\` origin@.
    at :: a -> Point (V a) (N a) -> Located a
    at a p = Loc p a

    -- | Deconstruct a @Located a@ into a location and a value of type
    --   @a@.  @viewLoc@ can be especially useful in conjunction with the
    --   @ViewPatterns@ extension.
    viewLoc :: Located a -> (Point (V a) (N a), a)
    viewLoc (Loc p a) = (p,a)

    -- | 'Located' is not a @Functor@, since changing the type could
    --   change the type of the associated vector space, in which case the
    --   associated location would no longer have the right type. 'mapLoc'
    --   has an extra constraint specifying that the vector space must
    --   stay the same.
    --
    --   (Technically, one can say that for every vector space @v@,
    --   @Located@ is a little-f (endo)functor on the category of types
    --   with associated vector space @v@; but that is not covered by the
    --   standard @Functor@ class.)
    mapLoc :: SameSpace a b => (a -> b) -> Located a -> Located b
    mapLoc f (Loc p a) = Loc p (f a)

    -- | A lens giving access to the object within a 'Located' wrapper.
    located :: SameSpace a b => Lens (Located a) (Located b) a b
    located f (Loc p a) = Loc p <$> f a

    -- | Lens onto the location of something 'Located'.
    _loc :: Lens' (Located a) (Point (V a) (N a))
    _loc f (Loc p a) = flip Loc a <$> f p

    deriving instance (Eq   (V a (N a)), Eq a  ) => Eq   (Located a)
    deriving instance (Ord  (V a (N a)), Ord a ) => Ord  (Located a)

    instance (Show (V a (N a)), Show a) => Show (Located a) where
      showsPrec d (Loc p a) = showParen (d > 5) $
        showsPrec 6 a . showString " `at` " . showsPrec 6 p

    instance (Read (V a (N a)), Read a) => Read (Located a) where
      readPrec = parens . prec 5 $ do
        a <- readPrec
        Punc "`"   <- lexP
        Ident "at" <- lexP
        Punc "`"   <- lexP
        p <- readPrec
        return (Loc p a)

    type instance V (Located a) = V a
    type instance N (Located a) = N a

    -- | @Located a@ is an instance of @HasOrigin@ whether @a@ is or not.
    --   In particular, translating a @Located a@ simply translates the
    --   associated point (and does /not/ affect the value of type @a@).
    instance (Num (N a), Additive (V a)) => HasOrigin (Located a) where
      moveOriginTo o (Loc p a) = Loc (moveOriginTo o p) a

    -- | Applying a transformation @t@ to a @Located a@ results in the
    --   transformation being applied to the location, and the /linear/
    --   /portion/ of @t@ being applied to the value of type @a@ (/i.e./
    --   it is not translated).
    instance (Additive (V a), Num (N a), Transformable a) => Transformable (Located a) where
      transform t@(Transformation t1 t2 _) (Loc p a)
        = Loc (transform t p) (transform (Transformation t1 t2 zero) a)

    -- | The envelope of a @Located a@ is the envelope of the @a@,
    --   translated to the location.
    instance Enveloped a => Enveloped (Located a) where
      getEnvelope (Loc p a) = moveTo p (getEnvelope a)

    instance Enveloped a => Juxtaposable (Located a) where
      juxtapose = juxtaposeDefault

    -- | The trace of a @Located a@ is the trace of the @a@,
    --   translated to the location.
    instance (Traced a, Num (N a)) => Traced (Located a) where
      getTrace (Loc p a) = moveTo p (getTrace a)

    instance Qualifiable a => Qualifiable (Located a) where
      n .>> Loc p a = Loc p (n .>> a)

    type instance Codomain (Located a) = Point (Codomain a)

    instance (InSpace v n a, Parametric a, Codomain a ~ v)
        => Parametric (Located a) where
      Loc x a `atParam` p = x .+^ (a `atParam` p)

    instance DomainBounds a => DomainBounds (Located a) where
      domainLower (Loc _ a) = domainLower a
      domainUpper (Loc _ a) = domainUpper a

    instance (InSpace v n a, EndValues a, Codomain a ~ v) => EndValues (Located a)

    instance (InSpace v n a, Fractional n, Parametric a, Sectionable a, Codomain a ~ v)
        => Sectionable (Located a) where
      splitAtParam (Loc x a) p = (Loc x a1, Loc (x .+^ (a `atParam` p)) a2)
        where (a1,a2) = splitAtParam a p

      reverseDomain (Loc x a) = Loc (x .+^ y) (reverseDomain a)
        where y = a `atParam` domainUpper a

    instance (InSpace v n a, Fractional n, HasArcLength a, Codomain a ~ v)
        => HasArcLength (Located a) where
      arcLengthBounded eps (Loc _ a) = arcLengthBounded eps a
      arcLengthToParam eps (Loc _ a) = arcLengthToParam eps a