content: -- Copyright James D. Brock (c) 2018
  --
  -- Boost Software License - Version 1.0 - August 17th, 2003
  -- See accompanying file LICENSE
  --
  --     cabal v2-run
  --
  
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE RecordWildCards #-}
  
  module Main where
  
  import Data.Maybe
  import Data.Monoid
  import Data.List
  import Data.Function
  import Control.Monad
  import Data.Default.Class
  import Data.Map.Strict (Map)
  import qualified Data.Map.Strict as Map
  import qualified Data.Text as T.Strict
  import qualified Data.Text.Lazy.IO as T
  import Data.Text.Lazy.Builder (toLazyText, fromText)
  import Data.Text.Lazy.Builder.Int (decimal)
  import Data.Text.Format as T (right)
  import qualified Data.Text.Read as T.Read
  import qualified Text.XML as XML
  import Text.XML.Cursor as XML
  import Control.Monad.Writer.Lazy
  
  -- Data Structures
  -- ===============
  
  -- One FIX field for one version of the FIX spec
  data Field = Field
          { fname    :: T.Strict.Text -- FIX field name
          , ftype    :: T.Strict.Text -- FIX field type
          , fversion :: T.Strict.Text -- FIX version introduced
          , fdesc    :: T.Strict.Text -- FIX field description
          }
    deriving (Show, Eq)
  
  -- Map of FIX tag to all of the fields names for each version of FIX
  type Fields = Map Int Field
  
  -- One Message Type for one version of the FIX spec
  data MsgType = MsgType
          { mname    :: T.Strict.Text -- MessageType name
          , mvalue   :: T.Strict.Text -- MessageType field value
          , mversion :: T.Strict.Text -- FIX version introduced
          }
  
  main :: IO ()
  main = do
  
      -- Step 1. Read and parse the spec files
  
      fixrepoFields <- XML.readFile def "../FIXRepository/Basic/Fields.xml"
      fixrepoMsgs   <- XML.readFile def "../FIXRepository/Basic/Messages.xml"
  
      -- Extra FIX fields omitted by the spec
      let extraflds = Map.fromList [
              ( 20
              , Field
                  { fname    = "ExecTransType"
                  , ftype    = "char"
                  , fversion = "FIX.4.2" -- just a guess
                  , fdesc =
                      "Identifies transaction type\n\n" <>
                      "Valid values:\n" <>
                      "   0 = New\n" <>
                      "   1 = Cancel\n" <>
                      "   2 = Correct\n" <>
                      "   3 = Status\n"
                  }
              )
              ]
  
      -- All the FIX fields from the spec, plus the extraflds
      let fields :: Fields
          fields = foldl' (flip addFieldRepo) extraflds $
              XML.fromDocument fixrepoFields
              $| element "Fields" &/ element "Field"
            where
              -- Read the FIX field information out of one FIX Repository
              -- Fields.xml entry and add it to a Fields Map.
              addFieldRepo :: Cursor -> Fields -> Fields
              addFieldRepo curs = maybe id (uncurry Map.insert) $ do
                  fversion <- listToMaybe $ attribute "added" curs
                  ftagText <- listToMaybe $ curs $/ element "Tag" &// content
                  (ftag,_) <- either (const Nothing) Just $ T.Read.decimal ftagText
                  ftype    <- listToMaybe $ curs $/ element "Type" &// content
                  fname    <- listToMaybe $ curs $/ element "Name" &// content
                  fdesc    <-
                      listToMaybe $ curs $/ element "Description" &// content
                  return (ftag, Field{..})
  
      -- All the FIX MessageTypes from the spec
      let msgTypes :: [MsgType]
          msgTypes = mapMaybe mkMsg $ XML.fromDocument fixrepoMsgs
              $| element "Messages" &/ element "Message"
            where
              -- Make a MsgType from an element of the FIX Repository
              -- Messages.xml file.
              mkMsg :: Cursor -> Maybe MsgType
              mkMsg curs = do
                  mname    <- listToMaybe $ curs $/ element "Name" &// content
                  mvalue   <- listToMaybe $ curs $/ element "MsgType" &// content
                  mversion <- listToMaybe $ attribute "added" curs
                  return $ MsgType {..}
  
  
      -- Step 2. Write hffix_fields.hpp to stdout.
  
      T.putStr $ toLazyText $ execWriter $ do
  
          let tll x = tell $ x <> "\n" -- tell line
  
          tll "/*!"
          tll "\\file"
          tll "\\brief The hffix_fields.hpp file is generated by the fixspec/spec-parse-fields Haskell program from the FIX Protocol specification documents in the fixspec/ directory."
          tll ""
          tll "Do not edit this file, instead modify the fixspec/spec-parse-fields program and run it from the fixspec/spec-parse-fields directory as shown here."
          tll "Requires Nix."
          tll ""
          tll "    cd fixspec/spec-parse-fields"
          tll "    nix develop"
          tll "    cabal v2-build"
          tll "    cabal v2-run > hffix_fields.hpp"
          tll "    mv hffix_fields.hpp ../../include/hffix_fields.hpp"
          tll ""
          tll "Line comments for each field indicate the data type of the field for each version of the FIX spec in which the field appears."
          tll "*/"
          tll ""
          tll "#ifndef HFFIX_FIELDS_HEADER"
          tll "#define HFFIX_FIELDS_HEADER"
          tll "namespace hffix {"
          tll ""
          tll "/*!"
          tll "\\brief Namespace for all field tag name enums."
          tll "*/"
          tll "namespace tag {"
          tll "enum {"
  
          -- Write C++ enum of all field tags.
          tell $ flip foldMap (markbounds $ Map.toAscList fields)
              $ \((ftag, Field {..}), _, isLast) ->
                  let tagbuild = decimal ftag
                  in
                  T.right 50 ' ' fname <> " = " <> tagbuild <>
                  (if isLast then mempty else ",") <>
                  " /*!< " <> tagbuild <> " " <>
                  "(" <> fromText ftype <> " " <> fromText fversion <> ") " <>
                  -- Double-\n for the description so the line breaks become
                  -- paragraph breaks in Doxygen.
                  -- HTML entities.
                  fromText (T.Strict.replace "\n" "\n\n" $
                            T.Strict.replace "<" "&lt;" $
                            T.Strict.replace ">" "&gt;" fdesc) <>
                  "*/\n"
  
          tll "};"
          tll "} // namespace tag"
  
  
          tll ""
          tll "namespace {"
          tll "//! Sorted list of all field tags which are of type Length"
          tll "int length_fields[] = {"
  
          -- Write C++ array of all field tags for fields of type Length.
          let lengthFields = fields
                  & Map.filter ((== "Length") . ftype)
                  & Map.delete 9 -- lol BodyLength is not a field length
                  & Map.delete 383 -- Not a field length https://github.com/jamesdbrock/hffix/issues/44
  
          tell $ flip foldMap (markbounds $ Map.toAscList lengthFields)
              $ \((ftag, Field{..}), _, isLast) ->
                  T.right 35 ' ' ("tag::" <> fromText fname <>
                                 (if isLast then "" else ",")) <>
                  " // " <> decimal ftag <> " " <>
                  "Length" <> " " <> fromText fversion <> "\n"
          tll "};"
          tll "}"
  
  
          tll ""
          tll "/*!"
          tll " * \\brief Populate an AssociativeContainer with the names of all the FIX fields."
          tll " *"
          tll " * \\param dictionary A reference to an AssociativeContainer<int, std::string>"
          tll " */"
          tll " template <typename AssociativeContainer> void dictionary_init_field(AssociativeContainer& dictionary) {"
  
          -- Write C++ init method for a associative container for run-time
          -- field tag lookup.
          tell $ flip foldMap (Map.toAscList fields) $ \(_, Field {..}) ->
              T.right 50 ' ' ("dictionary[tag::" <> fromText fname <> "]") <>
              " = " <>
              T.right 50 ' ' ("\"" <> fromText fname <> "\";") <>
              " // " <> "(" <> fromText ftype <> " " <> fromText fversion <> ")\n"
          tll "}"
  
          -- Write C++ C-string constants for message types in a ::msg_type
          -- namespace.
          tll ""
          tll "/*!"
          tll "\\brief Namespace for message type constant strings."
          tll "*/"
          tll "namespace msg_type {"
          tll "#if __cplusplus >= 201103L"
          tell $ flip foldMap msgTypes $ \MsgType{..} ->
              "static constexpr const char* const " <>
              T.right 40 ' ' (fromText mname) <>
              " = " <>
              T.right 10 ' ' ("\"" <> fromText mvalue <> "\";") <>
              " /*!< " <> fromText mvalue <> " " <> " (" <> fromText mversion <> ") */\n"
          tll "#else"
          tell $ flip foldMap msgTypes $ \MsgType{..} ->
              "static const char* const " <>
              T.right 40 ' ' (fromText mname) <>
              " = " <>
              T.right 10 ' ' ("\"" <> fromText mvalue <> "\";") <>
              " /*!< " <> fromText mvalue <> " " <> " (" <> fromText mversion <> ") */\n"
          tll "#endif"
          tll "} // namespace msg_type"
  
  
          -- Write C++ init method for a associative container for run-time
          -- message name lookup.
          tll ""
          tll "/*!"
          tll " * \\brief Populate an AssociativeContainer with the names of all the FIX message types."
          tll " *"
          tll " * \\param dictionary A reference to an AssociativeContainer<std::string, std::string>"
          tll " */"
          tll " template <typename AssociativeContainer> void dictionary_init_message(AssociativeContainer& dictionary) {"
  
          tell $ flip foldMap msgTypes $ \MsgType{..} ->
              T.right 25 ' ' ("dictionary[\"" <> fromText mvalue <> "\"]") <>
              " = " <>
              T.right 40 ' ' ("\"" <> fromText mname <> "\";") <>
              " //" <> " (" <> fromText mversion <> ")\n"
  
          tll "}"
          tll "} // namespace hffix"
          tll "#endif // HFFIX_FIELDS_HEADER"
  
  
  -- | Annotate elements of a list with Bools, the first of which is True if
  -- the element is the head of the list, the second of which is True if the
  -- element is the last of the list. Both are True for singleton.
  markbounds :: [a] -> [(a, Bool, Bool)]
  markbounds [] = []
  markbounds [x] = [(x, True, True)]
  markbounds (x:xs) = (x, True, False) : tailbound xs
    where
      tailbound [y] = [(y, False, True)]
      tailbound (y:ys) = (y, False, False): tailbound ys
      tailbound [] = []
  
  