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

module Language.Sifflet.SiffML
    (
     ToXml(..)
    , produceSiffMLFile
    , consumeSiffMLFile
    , xmlToFunctions
     -- for testing
    , testFromXml
--    , consumeString
    )

where

import Text.XML.HXT.Core

import Data.Number.Sifflet
import Language.Sifflet.Expr
import Language.Sifflet.Util

class ToXml a where
    toXml :: a -> XMLProducer

-- | An XMLProducer produces XML
type XMLProducer = IOSLA (XIOState ()) XmlTree XmlTree

-- | An XMLConsumer consumes XML
type XMLConsumer a b = IOSLA (XIOState ()) a b

defaultOptions :: SysConfigList
defaultOptions = [withIndent yes, withValidate no ]

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

      }
consumeSiffMLFile :: XMLConsumer XmlTree a -> FilePath -> IO [a]
consumeSiffMLFile fromXml filePath =
    let options = defaultOptions
    in do
		doc <- readFile filePath
		runX (readString options doc >>> fromXml)

-- | Symbols

instance ToXml Symbol where
    toXml = symbolToXml

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


-- | Expr

instance ToXml Expr where
    toXml = exprToXml

exprToXml :: Expr -> XMLProducer
exprToXml expr =
    let literal label text = 
            -- future: (omit label arg.): selem label [txt text]
            selem "literal" [selem label [txt text]]
    in case expr of
         EUndefined -> 
             eelem "undefined"
         ESymbol (Symbol name) -> 
             selem "symbol" [txt name]

         -- "Literals"
         -- New way: duplicates parts of valueToXml (bad) ***
         EBool b -> 
             -- future: selem "bool" [eelem (show b)]
             selem "literal" [selem "bool" [eelem (show b)]]
         EChar c ->
             -- future: selem "char" [txt [c]]
             literal "char" [c]
         ENumber (Exact i) ->
             -- future: selem "int" [txt (show i)]
             literal "int" (show i)
         ENumber (Inexact x) ->
             -- future: selem "float" [txt (show x)]
             literal "float" (show x)
         EString s ->
             -- future: selem "string" [txt s]
             literal "string" s

         EIf e1 e2 e3 -> 
             selem "if" [toXml e1, toXml e2, toXml e3]
         EList xs -> 
             -- I predict that this is going to be troublesome! ***
             -- No checking for whether the list elements are literals!
             selem "literal" [selem "list" 
                                    (map (toXml . literalToValue) xs)]
             -- future: selem "list" (map toXml xs)
         ELambda _ _ -> error "exprToXml: not implemented for lambda expr"
         ECall (Symbol name) xs -> 
             selem "call" 
                   (selem "symbol" [txt name] :
                    map toXml xs)
         _ -> errcats ["exprToXml: extended expr:", show expr]

-- | Convert a literal expression to a value.
-- It is an error if the expr is not a literal.
-- Compare exprToValue in Expr.hs
literalToValue :: Expr -> Value
literalToValue e =
    if exprIsLiteral e
    then case e of
           EBool b -> VBool b
           EChar c -> VChar c
           ENumber n -> VNumber n
           EString s -> VString s
           EList es -> VList (map literalToValue es)
           EGroup e' -> literalToValue e'
           _ -> error "literalToValue: expr is literal, but not literal?"
    else error ("literalToValue: expr is not a literal: " ++ show e)

xmlToExpr :: XMLConsumer XmlTree Expr
xmlToExpr = 
    isElem >>>
    (
     (hasName "undefined" >>> constA EUndefined) <+>
     (hasName "symbol" >>> getChildren >>> isText >>> getText >>>
              arr (ESymbol . Symbol)) <+>

     -- future: remove extra level "literal"
     (hasName "literal" >>> getChildren >>> xmlToExpr) <+>

     -- boolean values
     (hasName "True" >>> constA (EBool True)) <+>
     (hasName "False" >>> constA (EBool False)) <+>

     -- chars
     (hasName "char" >>> getChildren >>> isText >>> getText >>>
              -- VVV head dangerous ???
              arr (EChar . head)) <+>

     -- numbers -- why not use parser instead of read???
     (hasName "int" >>> getChildren >>> isText >>> getText >>>
              arr (ENumber . Exact . read)) <+> -- read dangerous?
     (hasName "float" >>> getChildren >>> isText >>> getText >>>
              arr (ENumber . Inexact . read))  <+> -- read dangerous?
     
     -- strings
     (hasName "string" >>> getChildren >>> isText >>> getText >>> 
              arr EString) <+>


     (hasName "if" >>> listA (getChildren >>> xmlToExpr) >>> 
              -- sometimes I get bogus run-time errors here about
              -- this pattern [a, b, c] being non-exhaustive.
              -- Of course, it *is* non-exhaustive; but it is
              -- never violated in practice
              arr (\ [a, b, c] -> EIf a b c)) <+>
     -- This is very awkward, but needed for compatibility with the
     -- present SiffML doctype:
     (hasName "list" >>> 
              -- future?: listA (getChildren >>> xmlToExpr) >>> 
              -- Anyway, *why* does this not work???
              listA (getChildren >>> xmlToExpr) >>> 
              -- past?:
              -- listA (getChildren >>> xmlToValue >>> arr valueToLiteral') >>> 
              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))
    )

-- | Values
-- Still used in exprToXml in the EList case :-(

instance ToXml Value where
    toXml = valueToXml

-- Is this still needed? ***
valueToXml :: Value -> XMLProducer
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]]
      VString s ->
          selem "string" [txt s]
      VNumber (Exact i) ->
          selem "int" [txt (show i)]
      VNumber (Inexact x) ->
          selem "float" [txt (show x)]
      -- Are VFun and VList needed???
      VFun f ->
          selem "function" [toXml f]
      VList vs ->
          selem "list" (map toXml vs)

-- xmlToValue: still needed? ***
xmlToValue :: XMLConsumer 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 VString) <+>
     (hasName "int" >>> getChildren >>> isText >>> getText >>>
              arr (VNumber . Exact . read)) -- dangerous?
     <+>
     (hasName "float" >>> getChildren >>> isText >>> getText >>>
              arr (VNumber . Inexact . 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)
    )

-- | Types

instance ToXml Type where
    toXml = typeToXml

typeToXml :: Type -> XMLProducer
typeToXml vtype =
    case vtype of
      TypeVar typeVarName -> selem "type-variable" [txt typeVarName]
      TypeCons "String" [] -> eelem "string-type"
      TypeCons "Char" [] -> eelem "char-type"
      TypeCons "Num" [] -> eelem "num-type"
      TypeCons "Bool" [] -> eelem "bool-type"
      TypeCons "List" [eltType] -> selem "list-type" [typeToXml eltType]
      TypeCons "Function" [argT, resultT] -> 
          selem "function-type" [typeToXml argT, typeToXml resultT]
          -- error "typeToXml: TypeCons Function cannot be converted to XML"
      TypeCons _ _ ->
          errcats ["typeToXml:", show vtype, "cannot be converted to XML"]

xmlToType :: XMLConsumer XmlTree Type
xmlToType =
    isElem >>> 
    ((hasName "string-type" >>> constA typeString) <+>
     (hasName "char-type" >>> constA typeChar) <+>
     (hasName "num-type" >>> constA typeNum) <+>
     (hasName "bool-type" >>> constA typeBool) <+>
     (hasName "list-type" >>> getChildren >>> xmlToType >>> arr typeList) <+>
     (hasName "function-type" >>> 
              listA (getChildren >>> xmlToType) >>>
              -- there must be exactly two children, but I'm not checking
              arr (\ ts -> TypeCons "Function" ts)) <+>
     (hasName "type-variable" >>> getChildren >>>
      isText >>> getText >>> arr TypeVar)
    )

-- | Functions

instance ToXml Function where
    toXml = functionToXml

functionToXml :: Function -> XMLProducer
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 s = selem "name" [txt s]
                     rest = 
                         [selem "return-type" [typeToXml retType],
                          selem "arg-types" (map typeToXml argTypes),
                          selem "arg-names" (map name argNames),
                          selem "body" [toXml body]]
                 in case mName of
                      Nothing -> rest
                      Just fName -> name fName : rest
                )

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

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

        getReturnType :: XMLConsumer XmlTree Type
        getReturnType = hasName "return-type" >>> getChildren >>> xmlToType

        getArgTypes :: XMLConsumer XmlTree [Type]
        getArgTypes = hasName "arg-types" >>> 
                      listA (getChildren >>> xmlToType)

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

        getBody :: XMLConsumer 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)))

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

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

instance ToXml Functions where
    toXml = functionsToXml

-- -- | Examples and tests

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

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

-- -- | Tests

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


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

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

-- UNUSED:

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

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


-- xmlToSymbol :: XMLConsumer 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



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


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

--       }



-- consumeStdin :: XMLConsumer XmlTree a -> IO [a]
-- consumeStdin fromXml = consumeSiffMLFile fromXml "-"