module ObservableDB where
import Control.Monad (liftM, liftM2)
import Text.XML.HaXml.Namespaces (localName)
import Text.XML.HaXml.Types (QName(..))
import Text.XML.HaXml.XmlContent
import XmlUtils
newtype ObservableDB = ObservableDB { unObservableDB :: [ObservableDecl] }
deriving (Show, Read)
data ObservableDecl = ObservableDecl String ObservableType
deriving (Show, Read)
data ObservableType = Double | Bool
deriving (Show, Read)
instance HTypeable ObservableDB where
toHType _ = Defined "ObservableDB" [] []
instance XmlContent ObservableDB where
parseContents = inElement "ObservableDB" $
liftM ObservableDB parseContents
toContents (ObservableDB ds) =
[mkElemC "ObservableDB" (toContents ds)]
instance HTypeable ObservableDecl where
toHType _ = Defined "ObservableDecl" [] []
instance XmlContent ObservableDecl where
parseContents = do
e@(Elem t _ _) <- element ["ObservableDecl"]
commit $ interior e $ case localName t of
"ObservableDecl" -> liftM2 ObservableDecl (attrStr (N "name") e) parseContents
toContents (ObservableDecl n t) =
[mkElemAC (N "ObservableDecl") [(N "name", str2attr n)] (toContents t)]
instance HTypeable ObservableType where
toHType _ = Defined "ObservableType" [] []
instance XmlContent ObservableType where
parseContents = do
e@(Elem t _ _) <- element ["Double", "Bool"]
commit $ interior e $ case localName t of
"Double" -> return Double
"Bool" -> return Bool
toContents Double = [mkElemC "Double" []]
toContents Bool = [mkElemC "Bool" []]
compileObservableDB :: ObservableDB -> String
compileObservableDB = unlines . map compileObservable . unObservableDB
where
compileObservable (ObservableDecl n t) =
n ++ " :: Obs " ++ ct ++ "\n" ++
n ++ " = " ++ ce ++ " " ++ show n
where
ct = case t of
Double -> "Double"
Bool -> "Bool"
ce = case t of
Double -> "primVar"
Bool -> "primCond"