{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}

module Data.Apiary.Document.Internal
    ( Doc(..)
    , Documents(..)
    , PathDoc(..)
    , QueryDoc(..)
    , MethodDoc(..)
    , Route(..)
    , docsToDocuments
    ) where

import Data.Typeable(TypeRep)
import Data.Maybe(mapMaybe)
import Data.List(groupBy)
import Data.Function(on)

import Data.Apiary.Param(StrategyRep, QueryRep)
import Data.Apiary.Method(Method)

import Text.Blaze.Html(Html)
import qualified Data.Text as T
import qualified Data.ByteString as S

data Doc
    = DocPath   T.Text       Doc
    | DocRoot                Doc
    | DocFetch  T.Text TypeRep (Maybe Html) Doc
    | DocRest   T.Text  (Maybe Html) Doc
    | DocAny    Doc
    | DocDropNext            Doc

    | DocMethod Method       Doc
    | DocQuery  T.Text StrategyRep QueryRep (Maybe Html) Doc
    | DocPrecondition Html   Doc
    | DocAccept S.ByteString Doc
    | DocGroup  T.Text       Doc
    | Document  T.Text       Doc
    | Action

--------------------------------------------------------------------------------

data Route
    = Path  T.Text                      Route
    | Fetch T.Text TypeRep (Maybe Html) Route
    | Rest  T.Text (Maybe Html) -- ^ \*\* with name
    | Any -- ^ \*\* without name
    | End

instance Eq Route where
    Path    a   d == Path  b   d'   = a == b && d == d'
    Fetch k a _ d == Fetch l b _ d' = k == l && a == b && d == d'
    Rest  k _     == Rest  l _      = k == l
    Any           == Any            = True
    End           == End            = True
    _             == _              = False

data Documents = Documents
    { noGroup :: [PathDoc]
    , groups  :: [(T.Text, [PathDoc])]
    }

data PathDoc = PathDoc
    { path    :: Route
    , methods :: [(Method, [MethodDoc])]
    }

-- | query parameters document
data QueryDoc = QueryDoc
    { queryName     :: T.Text
    , queryStrategy :: StrategyRep
    , queryRep      :: QueryRep
    , queryDocument :: (Maybe Html)
    }

data MethodDoc = MethodDoc
    { queries       :: [QueryDoc]
    , preconditions :: [Html]
    , accept        :: Maybe S.ByteString
    , document      :: T.Text
    }

--------------------------------------------------------------------------------

data ToDocumentState = ToDocumentState
    { toDocumentPath      :: Route -> Route
    , toDocumentMethodDoc :: [MethodDoc] -> [(Method, [MethodDoc])]
    , toDocumentQueries   :: [QueryDoc] -> [QueryDoc]
    , toDocumentPreconds  :: [Html] -> [Html]
    , toDocumentAccept    :: Maybe S.ByteString
    , toDocumentDocument  :: Maybe T.Text
    }

initialToDocumentState :: ToDocumentState
initialToDocumentState = ToDocumentState id (\md -> [("*", md)]) id id Nothing Nothing

docToDocument :: Doc -> Maybe (Maybe T.Text, PathDoc)
docToDocument = \case
    (DocGroup "" d') -> (Nothing,) `fmap` loop initialToDocumentState d'
    (DocGroup g  d') -> (Just  g,) `fmap` loop initialToDocumentState d'
    d'               -> (Nothing,) `fmap` loop initialToDocumentState d'
  where
    loop st (DocDropNext       d) = loop st (dropNext d)
    loop st (DocPath         p d) = loop st { toDocumentPath = toDocumentPath st . Path p } d
    loop st (DocRoot           d) = loop st { toDocumentPath = const $ Path "" End } d
    loop st (DocFetch    k t h d) = loop st { toDocumentPath = toDocumentPath st . Fetch k t h } d
    loop st (DocRest     k   h d) = loop st { toDocumentPath = toDocumentPath st . const (Rest k h) } d
    loop st (DocAny            d) = loop st { toDocumentPath = toDocumentPath st . const Any } d
    loop st (DocMethod       m d) = loop st { toDocumentMethodDoc = (\md -> [(m, md)]) } d
    loop st (DocQuery  p s q t d) = loop st { toDocumentQueries = toDocumentQueries st . (QueryDoc p s q t:) } d
    loop st (DocPrecondition h d) = loop st { toDocumentPreconds = toDocumentPreconds st . (h:) } d
    loop st (DocGroup        _ d) = loop st d
    loop st (DocAccept       a d) = loop st { toDocumentAccept = Just a } d
    loop st (Document        t d) = loop st { toDocumentDocument = Just t} d
    loop st Action                = case toDocumentDocument st of
        Nothing  -> Nothing
        Just doc -> Just . PathDoc (toDocumentPath st End) $ toDocumentMethodDoc st
            [MethodDoc (toDocumentQueries st []) (toDocumentPreconds st []) (toDocumentAccept st) doc]

    dropNext (DocPath         _ d) = d
    dropNext (DocRoot           d) = d
    dropNext (DocFetch    _ _ _ d) = d
    dropNext (DocRest       _ _ d) = d
    dropNext (DocAny            d) = d
    dropNext (DocDropNext       d) = dropNext d
    dropNext (DocMethod       _ d) = d
    dropNext (DocQuery  _ _ _ _ d) = d
    dropNext (DocPrecondition _ d) = d
    dropNext (DocGroup        _ d) = d
    dropNext (DocAccept       _ d) = d
    dropNext (Document        _ d) = d
    dropNext Action                = Action

mergePathDoc :: [PathDoc] -> [PathDoc]
mergePathDoc [] = []
mergePathDoc (pd:pds) = merge (filter (same pd) pds) : mergePathDoc (filter (not . same pd) pds)
  where
    same           = (==) `on` path
    merge pds' = PathDoc (path pd) (mergeMethods $ methods pd ++ concatMap methods pds')

mergeMethods :: [(Method, [MethodDoc])] -> [(Method, [MethodDoc])]
mergeMethods [] = []
mergeMethods (m:ms) = merge (filter (same m) ms) : mergeMethods (filter (not . same m) ms)
  where
    same = (==) `on` fst
    merge ms' = (fst m, snd m ++ concatMap snd ms')


docsToDocuments :: [Doc] -> Documents
docsToDocuments doc =
    let gds = mapMaybe docToDocument doc
        ngs = mergePathDoc . map snd $ filter ((Nothing ==) . fst)   gds
        gs  = map upGroup . groupBy ((==) `on` fst) $ mapMaybe trav gds
    in Documents ngs gs
  where
    upGroup ((g,d):ig) = (g, mergePathDoc $ d : map snd ig)
    upGroup []         = error "docsToDocuments: unknown error."

    trav (Nothing, _) = Nothing
    trav (Just a,  b) = Just (a, b)