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

module Data.Apiary.Document where

import Control.Applicative
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.ByteString as S
import Data.Typeable
import Data.Maybe
import Data.Apiary.Param
import qualified Network.HTTP.Types as HT
import Text.Blaze.Html
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Data.Monoid
import Data.List
import Data.Function

data StrategyRep = StrategyRep
    { strategyInfo :: T.Text }
    deriving (Show, Eq)

data Doc
    = DocPath   T.Text       Doc
    | DocRoot                Doc
    | DocFetch  TypeRep (Maybe Html) Doc
    | DocMethod HT.Method    Doc
    | DocQuery  S.ByteString StrategyRep QueryRep Html Doc
    | DocGroup  T.Text       Doc
    | Document  (Maybe T.Text)

data Route
    = Path  T.Text               Route
    | Fetch TypeRep (Maybe Html) Route
    | End

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

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

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

data QueryDoc = QueryDoc
    { queryName     :: S.ByteString
    , queryStrategy :: StrategyRep
    , queryRep      :: QueryRep
    , queryDocument :: Html
    }

data MethodDoc = MethodDoc
    { queries  :: [QueryDoc]
    , document :: T.Text
    }

docToDocument :: Doc -> Maybe (Maybe T.Text, PathDoc)
docToDocument = \case
    (DocGroup g d') -> (Just  g,) <$> loop id (\md -> [("ANY", md)]) id d'
    d'              -> (Nothing,) <$> loop id (\md -> [("ANY", md)]) id d'
  where
    loop ph mh qs (DocPath        t d)  = loop (ph . Path t) mh qs d
    loop _  mh qs (DocRoot          d)  = loop (const $ Path "" End) mh qs d
    loop ph mh qs (DocFetch     t h d)  = loop (ph . Fetch t h) mh qs d
    loop ph _  qs (DocMethod      m d)  = loop ph (\md -> [(m, md)]) qs d
    loop ph mh qs (DocQuery p s q t d)  = loop ph mh (qs . (QueryDoc p s q t:)) d
    loop ph mh qs (DocGroup       _ d)  = loop ph mh qs d
    loop ph mh qs (Document   (Just t)) = Just . PathDoc (ph End) $ mh (MethodDoc (qs []) t)
    loop _  _  _  (Document   Nothing)  = Nothing

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

docsToDocuments :: [Doc] -> Documents
docsToDocuments doc =
    let gds = mapMaybe docToDocument doc
        ngs = mergeMethod . 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, mergeMethod $ d : map snd ig)
    upGroup []         = error "docsToDocuments: unknown error."

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

routeToHtml :: Route -> (Html, Html)
routeToHtml = loop (1::Int) mempty []
  where
    sp = H.span "/" ! A.class_ "splitter"
    loop i r p (Path s d)          = loop i (r <> sp <> H.span (toHtml s) ! A.class_ "path") p d
    loop i r p (Fetch t Nothing d) = 
        loop i (r <> sp <> H.span (toHtml $ ':' : show t) ! A.class_ "fetch") p d
    loop i r p (Fetch t (Just h) d) = 
        loop (succ i) (r <> sp <> H.span (toHtml (':' : show t) <> H.sup (toHtml i)) ! A.class_ "fetch")
            (p <> [H.tr $ H.td (toHtml i) <> H.td (toHtml $ show t) <> H.td h]) d
    loop _ r p End =
        (r, if null p
            then mempty
            else H.table ! A.class_ "table table-condensed col-sm-offset-1 col-md-offset-1" $
                 H.caption "Route Parameters" <>
                 H.tr (H.th "#" <> H.th "type" <> H.th "description") <>
                 mconcat p
        )


defaultDocumentToHtml :: Documents -> Html
defaultDocumentToHtml docs = H.docTypeHtml $ H.head headH <> H.body body
  where
    css u = H.link ! A.rel "stylesheet" ! A.href u
    headH = H.title "API documentation" <>
        css "//maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css"

    htmlQR (Strict   r) = toHtml (show r)
    htmlQR (Nullable r) = toHtml (show r ++ "?")
    htmlQR  Check       = toHtml ("check" :: T.Text)

    query (QueryDoc p s q t) = H.tr $
        H.td (toHtml $ T.decodeUtf8 p) <> H.td (toHtml $ strategyInfo s) <> H.td (htmlQR q) <> H.td t

    queriesH []    = mempty
    queriesH qs    =
        H.table ! A.class_ "table table-condensed col-sm-offset-1 col-md-offset-1" $
        H.caption "Query Parameters" <>
        H.tr (H.th "name" <> H.th "num" <> H.th "type" <> H.th "description") <>
        mconcat (map query qs)

    method (m, MethodDoc qs d) = 
        H.div ! A.class_ "col-sm-offset-1 col-md-offset-1" $
        H.h4 (toHtml $ T.decodeUtf8 m) <> 
        (H.p ! A.class_ "col-sm-offset-1 col-md-offset-1") (toHtml d) <>
        queriesH qs

    pathH (PathDoc r ms) =
        let (route, rdoc) = routeToHtml r
            in H.div $ H.h3 route <> rdoc <> (H.div $ mconcat (map method ms))

    groupH (g, p) = H.div $ H.h2 (toHtml g) <> (mconcat $ map pathH p)

    doc (Documents n g) = H.div (mconcat $ map pathH n) <> mconcat (map groupH g)

    body  = H.div ! A.class_ "container" $
        H.h1 "API documentation" <> doc docs