module Sifflet.Language.SiffML
(
ToXml(..)
, produceSiffMLFile
, consumeSiffMLFile
, xmlToFunctions
)
where
import Text.XML.HXT.Arrow
import Sifflet.Language.Expr
import Sifflet.Util
class ToXml a where
toXml :: a -> XMLProducer
type XMLProducer = IOSLA (XIOState ()) XmlTree XmlTree
type XMLConsumer a b = IOSLA (XIOState ()) a b
defaultOptions :: [(String, String)]
defaultOptions = [(a_indent, v_yes), (a_validate, v_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 runX (readDocument options filePath >>> fromXml)
instance ToXml Symbol where
toXml = symbolToXml
symbolToXml :: Symbol -> XMLProducer
symbolToXml (Symbol name) =
selem "symbol" [txt name]
instance ToXml Expr where
toXml = exprToXml
exprToXml :: Expr -> XMLProducer
exprToXml expr =
case expr of
EUndefined ->
eelem "undefined"
ESymbol (Symbol name) ->
selem "symbol" [txt name]
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 :: XMLConsumer 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) <+>
(hasName "call" >>> listA (getChildren >>> xmlToExpr) >>>
arr (\ (ESymbol symf : args) -> ECall symf args))
)
instance ToXml Value where
toXml = valueToXml
valueToXml :: Value -> XMLProducer
valueToXml value =
case value of
VBool 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)]
VFun f ->
selem "function" [toXml f]
VList vs ->
selem "list" (map toXml vs)
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 VStr) <+>
(hasName "int" >>> getChildren >>> isText >>> getText >>>
arr (VInt . read))
<+>
(hasName "float" >>> getChildren >>> isText >>> getText >>>
arr (VFloat . read))
<+>
(hasName "function" >>> getChildren >>> xmlToFunction >>> arr VFun)
<+>
(hasName "list" >>> listA (getChildren >>> xmlToValue) >>>
arr VList)
)
instance ToXml VpType where
toXml = vpTypeToXml
vpTypeToXml :: VpType -> XMLProducer
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]
VpTypeFunction _ _ -> errcats ["vpTypeToXml: VpTypeFunction cannot be",
"converted to XML"]
xmlToVpType :: XMLConsumer 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)
)
instance ToXml Function where
toXml = functionToXml
functionToXml :: Function -> XMLProducer
functionToXml (Function mName argTypes retType impl) =
case impl of
Primitive _ ->
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" [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 :: 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 VpType
getReturnType = hasName "return-type" >>> getChildren >>> xmlToVpType
getArgTypes :: XMLConsumer XmlTree [VpType]
getArgTypes = hasName "arg-types" >>>
listA (getChildren >>> xmlToVpType)
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" >>>
(
(
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 >>>
getChildren >>>
hasName "functions" >>>
listA (getChildren >>> xmlToFunction) >>>
arr Functions
instance ToXml Functions where
toXml = functionsToXml