-- | SiffML : Sifflet Markup Language.
-- An XML application for storing and retrieving Sifflet programs
-- and libraries.

module SiffML
    (
     ToXml(..)
    , produceFile
    , consumeFile
    , Functions(..)
    , xmlToFunctions
    , testOut                   -- testing
    , xmlToX                    -- testing
    , testIn, testFromFile      -- testing
    )

where

import Text.XML.HXT.Arrow
import Text.XML.HXT.DOM.FormatXmlTree

import Expr
import Examples
import Util

class ToXml a where
    toXml :: a -> Producer

-- | A Producer produces XML
type Producer = IOSLA (XIOState ()) XmlTree XmlTree

-- | A Consumer consumes XML
type Consumer a b = IOSLA (XIOState ()) a b

defaultOptions = [(a_indent, v_yes), (a_validate, v_no)]

produceStdout :: (ToXml a) => a -> IO ()
produceStdout src = produceFile src "-"

produceFile :: (ToXml a) => a -> FilePath -> IO ()
produceFile src path = 
    let arrow :: Producer
        arrow = toXml src
        options = defaultOptions
    in do
      {
        putStrLn ""
      ; [rc] <- runX (root [] [arrow] >>>
                      writeDocument options path >>>
                      getErrStatus)
      ; putStrLn (case rc of
                    0 -> "Okay"
                    _ -> "Failed")

      }

produceXmlTrees :: (ToXml a) => a -> IO [XmlTree]
produceXmlTrees src = 
    let arrow :: Producer
        arrow = toXml src
        options = defaultOptions
    in do
      {
        putStrLn ""
      ; docs <- runX (root [] [arrow] >>> writeDocument options "-")
      ; case docs of
          [] -> putStrLn "Failed"
          doc : _ ->
             print doc
      ; return docs

      }


consumeFile :: Consumer XmlTree a -> FilePath -> IO [a]
consumeFile fromXml filePath =
    let options = defaultOptions
    in runX (readDocument options filePath >>> fromXml)

consumeStdin :: Consumer XmlTree a -> IO [a]
consumeStdin fromXml = consumeFile fromXml "-"

-- | testFromXml :: (ToXml a, Show a) => a -> Consumer XmlTree a -> IO ()
-- VVV This type generalization (a, a to a, b) is for debugging, undo it later:
testFromXml :: (ToXml a, Show b) => a -> Consumer XmlTree b -> IO ()
testFromXml src consumer = do
  {
    produceFile src "test.xml"
  ; results <- runX (readDocument defaultOptions "test.xml" >>>
                     isElem >>> -- document root
                     getChildren >>>
                     consumer)
  ; case results of
      [] -> putStrLn "Failed"
      result : _ -> print result
  }

testToXmlAndBack :: (ToXml a, Show a) => a -> Consumer XmlTree a -> IO ()
testToXmlAndBack = testFromXml

-- | Symbols

instance ToXml Symbol where
    toXml = symbolToXml

symbolToXml :: Symbol -> Producer
symbolToXml (Symbol name) =
    selem "symbol" [txt name]

xmlToSymbol :: Consumer XmlTree Symbol
xmlToSymbol = 
    isElem >>> hasName "symbol" >>> -- symbol element
    getChildren >>> isText >>> -- text element
    getText >>> -- String
    arr Symbol  -- quasi (return . Symbol)

testXmlToSymbol :: Symbol -> IO ()
testXmlToSymbol sym = testFromXml sym xmlToSymbol


-- | Expr

instance ToXml Expr where
    toXml = exprToXml

exprToXml :: Expr -> Producer
exprToXml expr =
    case expr of
      EUndefined -> 
          eelem "undefined"
      ESymbol (Symbol name) -> 
          selem "symbol" [txt name]
      -- ** To simplify, collapse <literal><float>2.5</float></literal>
      -- to <float>2.5</float>, and similarly with other
      -- literal values?
      ELit value -> 
          selem "literal" [toXml value]
      EIf e1 e2 e3 -> 
          selem "if" [toXml e1, toXml e2, toXml e3]
      EList xs -> 
          selem "list" (map toXml xs)
      ECall (Symbol name) xs -> 
          selem "call" 
                (selem "symbol" [txt name] :
                 map toXml xs)

xmlToExpr :: Consumer XmlTree Expr
xmlToExpr = 
    isElem >>>
    (
     (hasName "undefined" >>> constA EUndefined) <+>
     (hasName "symbol" >>> getChildren >>> isText >>> getText >>>
              arr (ESymbol . Symbol)) <+>
     (hasName "literal" >>> getChildren >>> xmlToValue >>> arr ELit) <+>
     (hasName "if" >>> listA (getChildren >>> xmlToExpr) >>> 
              arr (\ [a, b, c] -> EIf a b c)) <+>
     (hasName "list" >>> listA (getChildren >>> xmlToExpr) >>> arr EList) <+>
     -- VVV Would be less awkward if ECall :: Symbol -> [Expr] -> Expr
     -- were changed to ECall :: Expr -> [Expr] -> Expr
     (hasName "call" >>> listA (getChildren >>> xmlToExpr) >>>
              arr (\ (ESymbol symf : args) -> ECall symf args))
    )

exampleIfExpr = (EIf (ELit (VBool False)) -- (eCall ">" [eInt 32, eInt 61]) 
                     (ELit (VStr "yes")) 
                     (ELit (VStr "no")))

exampleListExpr = EList [ELit (VInt 1), ELit (VInt 2), ELit (VInt 3)]

exampleCallExpr = ECall (Symbol "foo") [ESymbol (Symbol "x"), ELit (VInt 2)]

-- | Values

instance ToXml Value where
    toXml = valueToXml

valueToXml :: Value -> Producer
valueToXml value =
    case value of
      VBool b ->
          -- <True/> or <False/> 
          -- complicate? selem "bool" [txt (show b)]
          eelem (show b)
      VChar c ->
          selem "char" [txt [c]]
      VStr s ->
          selem "string" [txt s]
      VInt i ->
          selem "int" [txt (show i)]
      VFloat x ->
          selem "float" [txt (show x)]
      -- *** Are VFun and VList needed???
      VFun f ->
          selem "function" [toXml f]
      VList vs ->
          selem "list" (map toXml vs)

exampleVList :: Value
exampleVList = VList [VInt 32, VInt 64, VInt 69]

xmlToValue :: Consumer XmlTree Value
xmlToValue = 
    isElem >>>
    ((hasName "True" >>> constA (VBool True)) <+>
     (hasName "False" >>> constA (VBool False)) <+>
     (hasName "char" >>> getChildren >>> isText >>> getText >>>
              arr (VChar . head)) <+>
     (hasName "string" >>> getChildren >>> isText >>> getText >>> 
              arr VStr) <+>
     (hasName "int" >>> getChildren >>> isText >>> getText >>>
              arr (VInt . read)) -- dangerous?
     <+>
     (hasName "float" >>> getChildren >>> isText >>> getText >>>
              arr (VFloat . read)) -- dangerous?

     <+>
     (hasName "function" >>> getChildren >>> xmlToFunction >>> arr VFun) 

     <+>
     -- listA arr collects the results of arr into a list, so to speak;
     -- note that listA (arr1 >>> arr2) 
     -- does not equal listA arr1 >>> listA arr2
     -- and probably will not even have a well-defined type.
     -- In particular:
     -- getChildren --> [child1]
     -- listA getChildren --> [childi for i = 1 to n]
     -- listA getChildren >>> xmlToValue
     --   --> [child1] if child1 passes xmlToValue (it does not)
     -- listA (getChildren >>> xmlToValue)
     --   --> [childi for i = 1 to n if childi passes xmlToValue]
     (hasName "list" >>> listA (getChildren >>> xmlToValue) >>>
              arr VList)
    )

-- | VpTypes

instance ToXml VpType where
    toXml = vpTypeToXml

vpTypeToXml :: VpType -> Producer
vpTypeToXml vtype =
    case vtype of
      VpTypeString -> eelem "string-type"
      VpTypeChar -> eelem "char-type"
      VpTypeNum -> eelem "num-type"
      VpTypeBool -> eelem "bool-type"
      VpTypeList eltType -> selem "list-type" [vpTypeToXml eltType]
      VpTypeVar typeVarName -> selem "type-variable" [txt typeVarName]

xmlToVpType :: Consumer XmlTree VpType
xmlToVpType =
    isElem >>> 
    ((hasName "string-type" >>> constA VpTypeString) <+>
     (hasName "char-type" >>> constA VpTypeChar) <+>
     (hasName "num-type" >>> constA VpTypeNum) <+>
     (hasName "bool-type" >>> constA VpTypeBool) <+>
     (hasName "list-type" >>> getChildren >>> xmlToVpType >>> 
              arr VpTypeList) <+>
     (hasName "type-variable" >>> getChildren >>>
      isText >>> getText >>> arr VpTypeVar)
    )

-- | Functions

instance ToXml Function where
    toXml = functionToXml

functionToXml :: Function -> Producer
functionToXml (Function mName argTypes retType impl) =
    case impl of
      Primitive _ ->
          -- shouldn't happen
          errcats ["functionToXml:",
                   "primitive functions cannot be exported to XML",
                   show (mName, argTypes, retType)]
      Compound argNames body ->
          selem "compound-function"
                (let name name = selem "name" [txt name]
                     rest = 
                         [selem "return-type" [vpTypeToXml retType],
                          selem "arg-types" (map vpTypeToXml argTypes),
                          selem "arg-names" (map name argNames),
                          selem "body" [toXml body]]
                 in case mName of
                      Nothing -> rest
                      Just fName -> name fName : rest
                )

xmlToFunction :: Consumer XmlTree Function
xmlToFunction = 
    let getChildElem :: Consumer XmlTree XmlTree
        getChildElem = getChildren >>> isElem

        getFuncName ::  Consumer XmlTree String
        getFuncName = hasName "name" >>> getChildren >>> isText >>> getText

        getReturnType :: Consumer XmlTree VpType
        getReturnType = hasName "return-type" >>> getChildren >>> xmlToVpType

        getArgTypes :: Consumer XmlTree [VpType]
        getArgTypes = hasName "arg-types" >>> 
                      listA (getChildren >>> xmlToVpType)

        getArgNames :: Consumer XmlTree [String]
        getArgNames = hasName "arg-names" >>> 
                      listA (getChildElem >>> getFuncName)

        getBody :: Consumer XmlTree Expr
        getBody = hasName "body" >>> getChildren >>> xmlToExpr                  

    in 
      isElem >>> hasName "compound-function" >>> 
      -- NOTE:
      -- If arr1 "produces" a, and arr2 "produces" b,
      -- then (arr1 &&& arr2) "produces" (a, b).
      (
       ( -- function name is optional, though it *should* be in the XML file
         listA (getChildElem >>> getFuncName)) &&& 
       (getChildElem >>> getReturnType) &&&
       (getChildElem >>> getArgTypes) &&&
       (getChildElem >>> getArgNames) &&&
       (getChildElem >>> getBody)
      )
    >>>
    (arr (\ (names, (returnType, (argTypes, (argNames, body)))) -> 
              Function (case names of 
                          [] -> Nothing
                          (fname : _) -> (Just fname)
                       )
                       argTypes
                       returnType (Compound argNames body)))

exampleFunction = 
    let esym = ESymbol . Symbol
    in Function (Just "cincr") 
                [VpTypeBool, VpTypeNum, VpTypeNum]
                VpTypeNum
                (Compound ["incr", "a", "b"]
                          (EIf (esym "incr")
                               (ECall (Symbol "+") [esym "a", esym "b"])
                               (esym "a")))

-- | A collection of functions, to be saved or read from a file

data Functions = Functions [Function]
               deriving (Eq, Show)

functionsToXml :: Functions -> Producer
functionsToXml (Functions fs) =
    selem "functions" (map toXml fs)

xmlToFunctions :: Consumer XmlTree Functions
xmlToFunctions =
    isElem >>>                  -- document root
    getChildren >>>
    hasName "functions" >>>
    listA (getChildren >>> xmlToFunction) >>>
    arr Functions


-- | This is for testing, when I don't know the type 
-- of the result I'm getting
xmlToX :: Consumer XmlTree Functions -- [Function] -- XmlTree
xmlToX = 
    isElem                      -- document root
    >>>
    getChildren
    >>>
    hasName "functions" 
    >>>
    listA (getChildren >>> xmlToFunction) 
    >>>
    arr Functions

instance ToXml Functions where
    toXml = functionsToXml

-- | Tests

testOut :: IO ()
testOut = 
    produceStdout (Functions [exampleFunctions !! 0, exampleFunctions !! 1])


testFromFile :: (Show a) => Consumer XmlTree a -> FilePath -> IO ()
testFromFile fromXml filePath = do
  {
    results <- consumeFile fromXml filePath
  ; putStrLn ""
  ; print (length results)
  ; print results
  ; putStrLn ""
  }

testIn :: (Show a) => Consumer XmlTree a -> IO ()
testIn fromXml = testFromFile fromXml "-"