{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables #-}
module Network.URI.Template.Internal where
import Control.Monad.Writer.Strict
import Data.DList hiding (map)
import Data.List (intersperse)
import Data.Maybe
import Data.Monoid
import Network.HTTP.Base (urlEncode)
import Network.URI.Template.Types

type StringBuilder = Writer (DList Char)

addChar :: Char -> StringBuilder ()
addChar = tell . singleton

addString :: String -> StringBuilder ()
addString = tell . fromList

data Allow = Unreserved | UnreservedOrReserved

allowEncoder Unreserved           = urlEncode
allowEncoder UnreservedOrReserved = id

data ProcessingOptions = ProcessingOptions
  { modifierPrefix :: Maybe Char
  , modifierSeparator :: Char
  , modifierSupportsNamed :: Bool
  , modifierIfEmpty :: Maybe Char
  , modifierAllow :: Allow
  }

type BoundValue = (String, WrappedValue)

option :: Maybe Char -> Char -> Bool -> Maybe Char -> Allow -> ProcessingOptions
option = ProcessingOptions

options :: Modifier -> ProcessingOptions
options m = case m of
  Simple            -> option  Nothing   ',' False  Nothing    Unreserved
  Reserved          -> option  Nothing   ',' False  Nothing    UnreservedOrReserved
  Label             -> option (Just '.') '.' False  Nothing    Unreserved
  PathSegment       -> option (Just '/') '/' False  Nothing    Unreserved
  PathParameter     -> option (Just ';') ';' True   Nothing    Unreserved
  Query             -> option (Just '?') '&' True  (Just '=')  Unreserved
  QueryContinuation -> option (Just '&') '&' True  (Just '=')  Unreserved
  Fragment          -> option (Just '#') ',' False  Nothing    UnreservedOrReserved

templateValueIsEmpty :: TemplateValue a -> Bool
templateValueIsEmpty (Single s)      = null s
templateValueIsEmpty (Associative s) = null s
templateValueIsEmpty (List s)        = null s

namePrefix :: ProcessingOptions -> String -> TemplateValue a -> StringBuilder ()
namePrefix opts name val = do
  addString name
  if templateValueIsEmpty val
    then maybe (return ()) addChar $ modifierIfEmpty opts
    else addChar '='

processVariable :: Modifier -> Bool -> Variable -> WrappedValue -> StringBuilder ()
processVariable m isFirst (Variable varName varMod) (WrappedValue val) = do
  if isFirst
    then maybe (return ()) addChar $ modifierPrefix settings
    else addChar $ modifierSeparator settings
  case varMod of
    Normal -> do
      when (modifierSupportsNamed settings) (namePrefix settings varName val)
      unexploded
    Explode -> exploded
    (MaxLength l) -> do
      when (modifierSupportsNamed settings) (namePrefix settings varName val)
      unexploded
  where
    settings = options m

    addEncodeString :: String -> StringBuilder ()
    addEncodeString = addString . (allowEncoder $ modifierAllow settings)

    sepByCommas = sequence_ . intersperse (addChar ',')

    associativeCommas :: (String -> String) -> (TemplateValue Single, TemplateValue Single) -> StringBuilder ()
    associativeCommas f (Single n, Single v) = addEncodeString n >> addChar ',' >> addEncodeString (f v)

    preprocess :: String -> String
    preprocess = case varMod of
      MaxLength l -> take l
      _ -> id

    unexploded = case val of
      (Associative l) -> sepByCommas $ map (associativeCommas preprocess) l
      (List l) -> sepByCommas $ map (\(Single s) -> addEncodeString $ preprocess s) l
      (Single s) -> addEncodeString $ preprocess s

    explodedAssociative :: (TemplateValue Single, TemplateValue Single) -> StringBuilder ()
    explodedAssociative (Single k, Single v) = do
      addEncodeString k
      addChar '='
      addEncodeString $ preprocess v

    exploded :: StringBuilder ()
    exploded = case val of
      (Single s) -> do
        when (modifierSupportsNamed settings) (namePrefix settings varName val)
        addEncodeString $ preprocess s
      (Associative l) -> sequence_ $ intersperse (addChar $ modifierSeparator settings) $ map explodedAssociative l
      (List l) -> sequence_ $ intersperse (addChar $ modifierSeparator settings) $ map (\(Single s) -> addEncodeString $ preprocess s) l

processVariables :: [(String, WrappedValue)] -> Modifier -> [Variable] -> StringBuilder ()
processVariables env m vs = sequence_ $ processedVariables
  where
    findValue (Variable varName _) = lookup varName env

    nonEmptyVariables :: [(Variable, WrappedValue)]
    nonEmptyVariables = catMaybes $ map (\v -> fmap (\mv -> (v, mv)) $ findValue v) vs

    processors :: [Variable -> WrappedValue -> StringBuilder ()]
    processors = (processVariable m True) : repeat (processVariable m False)

    processedVariables :: [StringBuilder ()]
    processedVariables = zipWith uncurry processors nonEmptyVariables

render :: UriTemplate -> [BoundValue] -> String
render tpl env = render' tpl env

render' :: UriTemplate -> [BoundValue] -> String
render' tpl env = Data.DList.toList $ execWriter $ mapM_ go tpl
  where
    go :: TemplateSegment -> StringBuilder ()
    go (Literal s) = addString s
    go (Embed m vs) = processVariables env m vs