module Dingo.Selector
       ( RefinableSelector
       , Selector
       , SimpleSelector
       , ToSelector(..)
       , (.>*.)
       , (.+.)
       , (.>.)
       , (.~.)
       , anyElement
       , element
       , fromSelector
       , with
       , withId
       , withClass
       , withAttribute
       , withAttributeValue
       , withAttributeValueElement
       , withAttributeValuePrefix
       ) where

import Data.Monoid (mconcat)
import Data.Text.Lazy (Text)
import Data.Text.Lazy.Builder (Builder, fromLazyText)
import Web.CSS.Escaping (escapeIdentifier, escapeString)

-- JQuery Selectors.
data TypeOrUniversal = SAny                      -- Universal selector
                     | SType Text                -- Type selector

data Qualifier = SAttributePresent Text
               | SAttributeEquals Text Text
               | SSpacedAttributeContains Text Text
               | SHypenatedAttributeContains Text Text
               | SClass Text
               | SId Text

renderQualifier :: Qualifier -> Builder
renderQualifier (SAttributePresent a) =
  mconcat [ "["
          , fromLazyText $ escapeIdentifier a
          , "]"
          ]
renderQualifier (SAttributeEquals a v) =
  mconcat [ "["
          , fromLazyText $ escapeIdentifier a
          , "="
          , fromLazyText $ escapeString v
          , "]"
          ]
renderQualifier (SSpacedAttributeContains a v) =
  mconcat [ "["
          , fromLazyText $ escapeIdentifier a
          , "~="
          , fromLazyText $ escapeString v
          , "]"
          ]
renderQualifier (SHypenatedAttributeContains a v) =
  mconcat [ "["
          , fromLazyText $ escapeIdentifier a
          , "|="
          , fromLazyText $ escapeString v
          , "]"
          ]
renderQualifier (SClass c) =
  mconcat [ "."
          , fromLazyText $ escapeIdentifier c
          ]
renderQualifier (SId i) =
  mconcat [ "#"
          , fromLazyText $ escapeIdentifier i
          ]

newtype Discriminators = Discriminators [Qualifier]

data SimpleSelector = SimpleSelector TypeOrUniversal Discriminators

-- | Match a particular element type.
element :: Text -> SimpleSelector
element e = SimpleSelector (SType e) (Discriminators [])

-- | Match any element.
anyElement :: SimpleSelector
anyElement = SimpleSelector SAny (Discriminators [])

-- | Match by HTML/XML element ID.
withId :: RefinableSelector a => a -> Text -> a
withId s i = with s $ SId i

-- | Match by HTML class.
withClass :: RefinableSelector a => a -> Text -> a
withClass s c = with s $ SClass c

-- | Match by attribute presence
withAttribute :: RefinableSelector a => a -> Text -> a
withAttribute r a = with r $ SAttributePresent a

-- | Match by attribute value.
withAttributeValue :: RefinableSelector a => a -> Text -> Text -> a
withAttributeValue r a v = with r $ SAttributeEquals a v

-- | Match by value contained in a space-separated attribute value.
withAttributeValueElement :: RefinableSelector a => a -> Text -> Text -> a
withAttributeValueElement r a v = with r $ SSpacedAttributeContains a v

-- | Match by value at the left of a hyphen-separated attribute value.
withAttributeValuePrefix :: RefinableSelector a => a -> Text -> Text -> a
withAttributeValuePrefix r a v = with r $ SHypenatedAttributeContains a v

-- | A selector that can be refined.
class RefinableSelector a where
  with :: a -> Qualifier -> a

instance RefinableSelector Discriminators where
  with (Discriminators a) aop = Discriminators (aop:a)

instance RefinableSelector SimpleSelector where
  with (SimpleSelector tou discriminators) aop =
    SimpleSelector tou (with discriminators aop)

--
data Selector = SSimple SimpleSelector
              | SDescendant SimpleSelector Selector
              | SChild SimpleSelector Selector
              | SAdjacent SimpleSelector Selector
              | SFollowing SimpleSelector Selector

fromTypeOrUniversal :: TypeOrUniversal -> Builder
fromTypeOrUniversal SAny = "*"
fromTypeOrUniversal (SType e) = fromLazyText $ escapeIdentifier e

fromSimpleSelector :: SimpleSelector -> Builder
fromSimpleSelector (SimpleSelector tou (Discriminators qualifiers)) =
  mconcat [ fromTypeOrUniversal tou
          , mconcat $ map renderQualifier qualifiers ]

fromSelector :: ToSelector a => a -> Builder
fromSelector = go . toSelector
  where
    go (SSimple s) = fromSimpleSelector s
    go (SDescendant s r) = mconcat [fromSimpleSelector s, " ", go r]
    go (SChild s r) = mconcat [fromSimpleSelector s, ">", go r]
    go (SAdjacent s r) = mconcat [fromSimpleSelector s, "+", go r]
    go (SFollowing s r) = mconcat [fromSimpleSelector s, "~", go r]

-- Class for default conversions "upwards" in the ADT hierarchy.
class ToSelector a where
  toSelector :: a -> Selector

instance ToSelector Qualifier where
  toSelector a = toSelector $ SimpleSelector SAny (Discriminators [a])

instance ToSelector SimpleSelector where
  toSelector = SSimple

instance ToSelector Selector where
  toSelector = id

class ToSimpleSelector a where
  toSimpleSelector :: a -> SimpleSelector

instance ToSimpleSelector SimpleSelector where
  toSimpleSelector = id

-- | Descendant combinator.
(.>*.) :: (ToSimpleSelector a, ToSelector b) => a -> b -> Selector
(.>*.) s d = SDescendant (toSimpleSelector s) (toSelector d)

infixr .>*.

-- | Child combinator.
(.>.) :: (ToSimpleSelector a, ToSelector b) => a -> b -> Selector
(.>.) s d = SChild (toSimpleSelector s) (toSelector d)

infixr .>.

-- | Adjacent combinator.
(.+.) :: (ToSimpleSelector a, ToSelector b) => a -> b -> Selector
(.+.) s d = SAdjacent (toSimpleSelector s) (toSelector d)

infixr .+.

-- | Following combinator.
(.~.) :: (ToSimpleSelector a, ToSelector b) => a -> b -> Selector
(.~.) s d = SFollowing (toSimpleSelector s) (toSelector d)

infixr .~.