{-# LANGUAGE Arrows  #-}

module Data.OpenDataTable.Parser
       ( parseBindings
       , parseInput
       , parseInputInfo
       , parsePaging
       , parsePagingNextPage
       , parsePagingPageSize
       , parsePagingStart
       , parsePagingTotal
       , parseMeta
       , parseOpenDataTable
       , parseSelect ) where

import Text.Read
import Data.Maybe

import Text.XML.HXT.Core (arr, deep, constA, isElem, orElse, returnA,
                          isA, listA, getText, none,
                          hasName, getChildren,  getAttrValue0,
                          (<<<),  (>>>),
                          XmlTree, ArrowXml, ArrowList, ArrowChoice)

import Data.OpenDataTable

readBoolMaybe :: String -> Maybe Bool
readBoolMaybe "true"  = Just True
readBoolMaybe "false" = Just False
readBoolMaybe _       = Nothing

atTag :: ArrowXml a => String -> a XmlTree XmlTree
atTag tag = deep (isElem >>> hasName tag)

atOptionalTag :: ArrowXml a => String -> a XmlTree (Maybe XmlTree)
atOptionalTag tag = deep (isElem >>> hasName tag >>> arr Just)
                `orElse` (constA Nothing)

text :: ArrowXml a => a XmlTree String
text = getChildren >>> getText

textAtTag :: ArrowXml a => String -> a XmlTree String
textAtTag tag = atTag tag >>> text

getList :: ArrowXml a => String -> a XmlTree c -> a XmlTree [c]
getList tag cont = listA ( atTag tag >>> cont)

getOptionalList :: (ArrowChoice a, ArrowXml a) =>
                   String -> a XmlTree b -> a (Maybe XmlTree) [b]
getOptionalList tag cont =
  proc x -> do
    case x of
      Nothing -> returnA -< []
      Just xml -> returnA  <<< getList tag cont -< xml

significant :: String -> Bool
significant = not . all (`elem` " \n\r\t")

optionalAttr :: ArrowXml a => String -> a XmlTree (Maybe String)
optionalAttr attr =
  (getAttrValue0 attr >>> isA significant >>> arr Just)
  `orElse` (constA Nothing)

optionalTextAtTag :: ArrowXml a => String -> a XmlTree (Maybe String)
optionalTextAtTag tag =
  (textAtTag tag >>> arr Just)
  `orElse` (constA Nothing)

optionalTextAtOptionalTag :: (ArrowChoice a, ArrowXml a) =>
                             String -> a (Maybe XmlTree) (Maybe String)
optionalTextAtOptionalTag tag =
  proc mx -> do
    case mx of
     Nothing -> returnA -< Nothing
     Just x -> optionalTextAtTag tag -< x

readOptionalAttrVal :: (ArrowChoice a, ArrowList a) =>
                       (b -> Maybe c) -> a (Maybe b) (Maybe c)
readOptionalAttrVal reader =
  proc x -> do
    case x of
      Nothing   -> returnA -< Nothing
      Just attr -> do
        let mRead = reader attr
        case mRead of
          Nothing  -> none    -< Nothing
          Just val -> returnA -< Just val

readOptionalAttr :: (ArrowList a, ArrowChoice a, Read c) =>
                    a (Maybe String) (Maybe c)
readOptionalAttr = readOptionalAttrVal readMaybe

readOptionalAttrBool :: (ArrowList a, ArrowChoice a) =>
                        a (Maybe String) (Maybe Bool)
readOptionalAttrBool = readOptionalAttrVal readBoolMaybe

readAttrVal :: (ArrowChoice a, ArrowList a) => (b -> Maybe c) -> a b c
readAttrVal reader =
  proc x -> do
    let mRead = reader x
    case mRead of
      Nothing ->  none    -< Nothing
      Just val -> returnA -< val

readAttr :: (ArrowChoice a, ArrowList a, Read b) =>
            a String b
readAttr = readAttrVal readMaybe

readAttrBool :: (ArrowChoice a, ArrowList a) =>
                a String Bool
readAttrBool = readAttrVal readBoolMaybe

parseOpenDataTable :: (ArrowXml a, ArrowChoice a) =>
                  a XmlTree OpenDataTable
parseOpenDataTable =
  proc x -> do
    mHttps        <- optionalAttr "https"             -< x
    https         <- readOptionalAttr                 -< mHttps
    xmlns         <- optionalAttr "xmlns"             -< x
    securityLevel <- readOptionalAttr
                     <<< optionalAttr "securityLevel" -< x
    meta          <- parseMeta                        -< x
    mExecute      <- optionalAttr "execute"           -< x
    execute       <- readOptionalAttr                 -< mExecute
    bindings      <- parseBindings                    -< x
    returnA -< OpenDataTable
      xmlns
      securityLevel
      https
      meta
      execute
      bindings

parseMeta :: (ArrowXml a) => a XmlTree Meta
parseMeta =
  proc x -> do
    meta             <- atTag "meta"                          -< x
    author           <- optionalTextAtTag "author"            -< meta
    apiKeyUrl        <- optionalTextAtTag "apiKeyUrl"         -< meta
    description      <- optionalTextAtTag "description"       -< meta
    sampleQueries    <- getList "sampleQuery" text            -< meta
    documentationUrl <- optionalTextAtTag "documentationURL"  -< meta
    returnA -< Meta
      author
      description
      documentationUrl
      apiKeyUrl
      sampleQueries

parseBindings :: (ArrowXml a, ArrowChoice a) => a XmlTree [Binding]
parseBindings =
  proc x -> do
    bindings <- atTag "bindings"                       -< x
    selects  <- listA (atTag "select" >>> parseSelect) -< bindings
    returnA -< SelectBinding `fmap` selects

parseSelect :: (ArrowXml a, ArrowChoice a) => a XmlTree Select
parseSelect =
  proc x -> do
    itemPath                <- optionalAttr "itemPath"                    -< x
    produces                <- readOptionalAttr
                               <<< optionalAttr "produces"                -< x
    pollingFrequencySeconds <- readOptionalAttr
                               <<< optionalAttr "pollingFrequencySeconds" -< x
    url                     <- optionalTextAtOptionalTag "url"
                               <<< atOptionalTag "urls"                   -< x
    inputs                  <- parseInput                                 -< x
    execute                 <- optionalTextAtTag "execute"                -< x
    paging                  <- (arr Just <<< parsePaging)
                               `orElse` (constA Nothing)                  -< x
    returnA -< Select
      itemPath
      produces
      pollingFrequencySeconds
      url
      inputs
      execute
      paging

parseInput :: (ArrowXml a, ArrowChoice a) => a XmlTree [Input]
parseInput =
  proc x -> do
    inputs <- atOptionalTag "inputs"               -< x
    keys   <- getOptionalList "key" parseInputInfo -< inputs
    returnA -< InputKey `fmap` keys

parseInputInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree InputInfo
parseInputInfo =
  proc x -> do
    id            <- getAttrValue0 "id"                               -< x
    as            <- optionalAttr "as"                                -< x
    typ           <- readAttr
                     <<< getAttrValue0 "type"                         -< x
    paramType     <- readAttr <<< getAttrValue0 "paramType"           -< x
    required      <- readOptionalAttrBool <<< optionalAttr "required" -< x
    def           <- optionalAttr "default"                           -< x
    private       <- readOptionalAttrBool
                     <<< optionalAttr "private"                       -< x
    const         <- readOptionalAttrBool
                     <<< optionalAttr "const"                         -< x
    batchable     <- readOptionalAttrBool
                     <<< optionalAttr "batchable"                     -< x
    maxBatchItems <- readOptionalAttr
                     <<< optionalAttr "maxBatchItems"                 -< x
    returnA -< InputInfo
      id
      as
      typ
      paramType
      (fromMaybe False required)
      def
      private
      const
      batchable
      maxBatchItems

parsePaging :: (ArrowXml a, ArrowChoice a) => a XmlTree Paging
parsePaging =
  proc x -> do
    paging    <- atTag "paging"                   -< x
    mModel    <- optionalAttr "model"             -< paging
    model     <- readOptionalAttr                 -< mModel
    matrix    <- readOptionalAttrBool
                 <<< optionalAttr "matrix"        -< paging
    pageSize  <- (arr Just <<< parsePagingPageSize)
                 `orElse` (constA Nothing)        -< paging
    pageStart <- (arr Just <<< parsePagingStart)
                 `orElse` (constA Nothing)        -< paging
    pageTotal <- (arr Just <<< parsePagingTotal)
                 `orElse` (constA Nothing)        -< paging
    nextPage  <- (arr Just <<< parsePagingNextPage)
                 `orElse` (constA Nothing)        -< paging
    returnA -< Paging
      model
      matrix
      pageSize
      pageStart
      pageTotal
      nextPage

parsePagingPageSize :: ArrowXml a => a XmlTree PagingSize
parsePagingPageSize =
  proc x -> do
    pageSize <- atTag "pagesize"    -< x
    id       <- getAttrValue0 "id"  -< pageSize
    max      <- getAttrValue0 "max" -< pageSize
    returnA -< PagingSize id $ read max

parsePagingStart :: ArrowXml a => a XmlTree PagingStart
parsePagingStart =
  proc x -> do
    pagingStart <- atTag "start"           -< x
    id          <- getAttrValue0 "id"      -< pagingStart
    def         <- getAttrValue0 "default" -< pagingStart
    returnA -< PagingStart id $ read def

parsePagingTotal :: ArrowXml a => a XmlTree PagingTotal
parsePagingTotal =
  proc x -> do
    pagingTotal <- atTag "total"           -< x
    def         <- getAttrValue0 "default" -< pagingTotal
    returnA -< PagingTotal $ read def

parsePagingNextPage :: ArrowXml a => a XmlTree NextPage
parsePagingNextPage =
  proc x -> do
    nextPage <- atTag "nextpage"    -< x
    path     <- getAttrValue0 "path" -< nextPage
    returnA -< NextPage path