{-# OPTIONS_GHC -Wno-missing-export-lists #-}

module Burrito.Internal.Expand where

import qualified Burrito.Internal.Render as Render
import qualified Burrito.Internal.Type.Character as Character
import qualified Burrito.Internal.Type.Digit as Digit
import qualified Burrito.Internal.Type.Expression as Expression
import qualified Burrito.Internal.Type.Field as Field
import qualified Burrito.Internal.Type.Literal as Literal
import qualified Burrito.Internal.Type.MaxLength as MaxLength
import qualified Burrito.Internal.Type.Modifier as Modifier
import qualified Burrito.Internal.Type.Name as Name
import qualified Burrito.Internal.Type.Operator as Operator
import qualified Burrito.Internal.Type.Template as Template
import qualified Burrito.Internal.Type.Token as Token
import qualified Burrito.Internal.Type.Value as Value
import qualified Burrito.Internal.Type.Variable as Variable
import qualified Control.Monad.Trans.Class as Trans
import qualified Control.Monad.Trans.State as State
import qualified Data.ByteString as ByteString
import qualified Data.Char as Char
import qualified Data.Functor.Identity as Identity
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lazy as LazyText
import qualified Data.Text.Lazy.Builder as Builder

-- | Expands a template using the given values. Unlike parsing, expansion
-- always succeeds. If no value is given for a variable, it will simply not
-- appear in the output.
--
-- >>> expand [] <$> parse "valid-template"
-- Just "valid-template"
-- >>> expand [] <$> parse "template:{example}"
-- Just "template:"
-- >>> expand [("example", stringValue "true")] <$> parse "template:{example}"
-- Just "template:true"
expand :: [(String, Value.Value)] -> Template.Template -> String
expand values =
  let m = Map.mapKeys Text.pack $ Map.fromList values
  in
    Render.builderToString . Identity.runIdentity . expandWith
      (pure . flip Map.lookup m)

-- | This is like @expand@ except that it gives you more control over how
-- variables are expanded. If you can, use @expand@. It's simpler.
--
-- Instead of passing in a static mapping from names to
-- values, you pass in a function that is used to look up values on the fly.
-- This can be useful if computing values takes a while or requires some impure
-- actions.
--
-- >>> expandWith (\ x -> [Nothing, Just . stringValue $ unpack x]) <$> parse "template:{example}"
-- Just ["template:","template:example"]
-- >>> let Just template = parse "user={USER}"
-- >>> expandWith (fmap (fmap stringValue) . lookupEnv . unpack) template
-- "user=taylor"
--
-- Note that as the RFC specifies, the given function will be called at most
-- once for each variable in the template.
--
-- >>> let Just template = parse "{a}{a}"
-- >>> expandWith (\ x -> do { putStrLn $ "-- expanding " <> show x; pure . Just $ Burrito.stringValue "A" }) template
-- -- expanding "a"
-- "AA"
expandWith
  :: Monad m
  => (Text.Text -> m (Maybe Value.Value))
  -> Template.Template
  -> m Builder.Builder
expandWith f = flip State.evalStateT Map.empty . template (cached f)

type CacheT = State.StateT (Map.Map Text.Text (Maybe Value.Value))

cached
  :: Monad m
  => (Text.Text -> m (Maybe Value.Value))
  -> Name.Name
  -> CacheT m (Maybe Value.Value)
cached f x = do
  let key = LazyText.toStrict . Builder.toLazyText $ name x
  cache <- State.get
  case Map.lookup key cache of
    Just result -> pure result
    Nothing -> do
      result <- Trans.lift $ f key
      State.modify $ Map.insert key result
      pure result

template
  :: Monad m
  => (Name.Name -> CacheT m (Maybe Value.Value))
  -> Template.Template
  -> CacheT m Builder.Builder
template f = fmap mconcat . traverse (token f) . Template.tokens

token
  :: Monad m
  => (Name.Name -> CacheT m (Maybe Value.Value))
  -> Token.Token
  -> CacheT m Builder.Builder
token f x = case x of
  Token.Expression y -> expression f y
  Token.Literal y -> pure $ literal y

expression
  :: Monad m
  => (Name.Name -> CacheT m (Maybe Value.Value))
  -> Expression.Expression
  -> CacheT m Builder.Builder
expression f ex =
  let op = Expression.operator ex
  in
    fmap
      (mconcat
      . (\xs -> if null xs then xs else prefix op : xs)
      . List.intersperse (separator op)
      . Maybe.catMaybes
      )
    . traverse (variable f op)
    . NonEmpty.toList
    $ Expression.variables ex

separator :: Operator.Operator -> Builder.Builder
separator op = Builder.singleton $ case op of
  Operator.Ampersand -> '&'
  Operator.FullStop -> '.'
  Operator.None -> ','
  Operator.NumberSign -> ','
  Operator.PlusSign -> ','
  Operator.QuestionMark -> '&'
  Operator.Semicolon -> ';'
  Operator.Solidus -> '/'

prefix :: Operator.Operator -> Builder.Builder
prefix op = case op of
  Operator.Ampersand -> Builder.singleton '&'
  Operator.FullStop -> Builder.singleton '.'
  Operator.None -> mempty
  Operator.NumberSign -> Builder.singleton '#'
  Operator.PlusSign -> mempty
  Operator.QuestionMark -> Builder.singleton '?'
  Operator.Semicolon -> Builder.singleton ';'
  Operator.Solidus -> Builder.singleton '/'

variable
  :: Monad m
  => (Name.Name -> CacheT m (Maybe Value.Value))
  -> Operator.Operator
  -> Variable.Variable
  -> CacheT m (Maybe Builder.Builder)
variable f op var = do
  res <- f $ Variable.name var
  pure $ case res of
    Nothing -> Nothing
    Just val -> value op var val

value
  :: Operator.Operator
  -> Variable.Variable
  -> Value.Value
  -> Maybe Builder.Builder
value op var val = case val of
  Value.Dictionary xs -> dictionaryValue op var $ Map.toAscList xs
  Value.List xs -> listValue op var xs
  Value.String x -> Just $ stringValue op var x

dictionaryValue
  :: Operator.Operator
  -> Variable.Variable
  -> [(Text.Text, Text.Text)]
  -> Maybe Builder.Builder
dictionaryValue = items $ \op var (k, v) ->
  let f = string op Modifier.None
  in
    case Variable.modifier var of
      Modifier.Asterisk -> [f k <> Builder.singleton '=' <> f v]
      _ -> [f k, f v]

listValue
  :: Operator.Operator
  -> Variable.Variable
  -> [Text.Text]
  -> Maybe Builder.Builder
listValue = items $ \op var -> pure . stringValue
  (case Variable.modifier var of
    Modifier.Asterisk -> op
    _ -> Operator.None
  )
  var { Variable.modifier = Modifier.None }

items
  :: (Operator.Operator -> Variable.Variable -> a -> [Builder.Builder])
  -> Operator.Operator
  -> Variable.Variable
  -> [a]
  -> Maybe Builder.Builder
items f op var xs =
  let
    md = Variable.modifier var
    sep = case md of
      Modifier.Asterisk -> separator op
      _ -> Builder.singleton ','
    p = case md of
      Modifier.Asterisk -> False
      _ -> case op of
        Operator.Ampersand -> True
        Operator.QuestionMark -> True
        Operator.Semicolon -> True
        _ -> False
  in if null xs
    then Nothing
    else
      Just
      . mconcat
      . (if p then (label True var :) else id)
      . List.intersperse sep
      $ concatMap (f op var) xs

label :: Bool -> Variable.Variable -> Builder.Builder
label p v =
  name (Variable.name v) <> if p then Builder.singleton '=' else mempty

name :: Name.Name -> Builder.Builder
name =
  mconcat
    . List.intersperse (Builder.singleton '.')
    . fmap field
    . NonEmpty.toList
    . Name.fields

field :: Field.Field -> Builder.Builder
field = foldMap (character $ const True) . Field.characters

character :: (Char -> Bool) -> Character.Character tag -> Builder.Builder
character f x = case x of
  Character.Encoded y z -> Render.encodedCharacter y z
  Character.Unencoded y -> unencodedCharacter f y

stringValue
  :: Operator.Operator -> Variable.Variable -> Text.Text -> Builder.Builder
stringValue op var str =
  let
    pre = case op of
      Operator.Ampersand -> label True var
      Operator.QuestionMark -> label True var
      Operator.Semicolon -> label (not $ Text.null str) var
      _ -> mempty
  in pre <> string op (Variable.modifier var) str

string
  :: Operator.Operator -> Modifier.Modifier -> Text.Text -> Builder.Builder
string op md =
  let
    allowed x = case op of
      Operator.NumberSign -> isAllowed x
      Operator.PlusSign -> isAllowed x
      _ -> isUnreserved x
    trim = case md of
      Modifier.Colon ml -> Text.take $ MaxLength.count ml
      _ -> id
  in foldMap (unencodedCharacter allowed) . Text.unpack . trim

isAllowed :: Char -> Bool
isAllowed x = isUnreserved x || isReserved x

isUnreserved :: Char -> Bool
isUnreserved x = case x of
  '-' -> True
  '.' -> True
  '_' -> True
  '~' -> True
  _ -> Char.isAsciiUpper x || Char.isAsciiLower x || Char.isDigit x

isReserved :: Char -> Bool
isReserved x = case x of
  '!' -> True
  '$' -> True
  '&' -> True
  '\'' -> True
  '(' -> True
  ')' -> True
  '*' -> True
  '+' -> True
  ',' -> True
  ';' -> True
  '=' -> True
  ':' -> True
  '/' -> True
  '?' -> True
  '#' -> True
  '[' -> True
  ']' -> True
  '@' -> True
  _ -> False

unencodedCharacter :: (Char -> Bool) -> Char -> Builder.Builder
unencodedCharacter f x = if f x
  then Builder.singleton x
  else foldMap (uncurry Render.encodedCharacter) $ encodeCharacter x

encodeCharacter :: Char -> [(Digit.Digit, Digit.Digit)]
encodeCharacter =
  fmap Digit.fromWord8 . ByteString.unpack . Text.encodeUtf8 . Text.singleton

literal :: Literal.Literal -> Builder.Builder
literal = foldMap (character isAllowed) . Literal.characters