module Network.YAML.API
(Type (..), Method (..), API (..),
readAPI
) where
import Control.Monad
import Control.Monad.IO.Class
import Data.Char
import Data.Yaml
import qualified Data.ByteString as B
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.HashMap.Strict as H
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Lift
instance (Lift a, Lift b) => Lift (M.Map a b) where
lift m = [| M.fromList $ $(lift list) |]
where list = M.assocs m
instance Lift T.Text where
lift text = [| T.pack $(lift str) |]
where str = T.unpack text
data Type =
TVoid
| TString
| TText
| TInteger
| TDouble
| TMaybe Type
| TList Type
| TUser (M.Map T.Text Type)
| THaskell T.Text
deriving (Eq, Show)
$(deriveLift ''Type)
data Method = Method {
methodArgs :: [Type]
, methodReturnType :: Type
} deriving (Eq, Show)
$(deriveLift ''Method)
data API = API {
apiUri :: T.Text
, apiTypes :: M.Map T.Text Type
, apiMethods :: M.Map T.Text Method
} deriving (Eq, Show)
$(deriveLift ''API)
instance FromJSON Type where
parseJSON (String "Void") = return TVoid
parseJSON (String "String") = return TString
parseJSON (String "Text") = return TText
parseJSON (String "Integer") = return TInteger
parseJSON (String "Double") = return TDouble
parseJSON (String text) = do
let lst = filter (not . T.null) $ T.split isSpace text
if (length lst == 2)
then case head lst of
"List" -> TList `fmap` parseJSON (String $ lst !! 1)
"Maybe" -> TMaybe `fmap` parseJSON (String $ lst !! 1)
_ -> return (THaskell text)
else return (THaskell text)
parseJSON x@(Object v) = do
typeFields <- parseJSON x
return $ TUser typeFields
parseJSON x = fail $ "Invalid type description: " ++ show x
instance FromJSON Method where
parseJSON (Object v) = do
returnType <- v .:? "return" .!= TVoid
args <- v .:? "arguments" .!= []
return $ Method args returnType
parseJSON x = fail $ "Invalid method description: " ++ show x
resolveType :: M.Map T.Text Type -> Type -> Type
resolveType types t@(THaskell name) =
case M.lookup name types of
Just result -> result
Nothing -> t
resolveType _ t = t
resolveMethodTypes :: M.Map T.Text Type -> Method -> Method
resolveMethodTypes types (Method args returnType) =
let args' = map (resolveType types) args
returnType' = resolveType types returnType
in Method args' returnType'
instance FromJSON API where
parseJSON (Object v) = do
uri <- v .: "uri"
types <- v .:? "types" .!= M.empty
methods <- v .:? "methods" .!= M.empty
return $ API uri types methods
parseJSON x = fail $ "Invalid API description: " ++ show x
instance ToJSON Type where
toJSON TVoid = String "Void"
toJSON TString = String "String"
toJSON TText = String "Text"
toJSON TInteger = String "Integer"
toJSON TDouble = String "Double"
toJSON (TList t) = case toJSON t of
String s -> String $ "List " `T.append` s
x -> error $ "Unsupported inner type for List: " ++ show x
toJSON (TMaybe t) = case toJSON t of
String s -> String $ "Maybe " `T.append` s
x -> error $ "Unsupported inner type for Maybe: " ++ show x
toJSON (TUser fields) = Object $ H.fromList [(name, toJSON t) | (name, t) <- M.assocs fields]
toJSON (THaskell name) = String name
instance ToJSON Method where
toJSON (Method args returnType) =
object [
"arguments" .= args,
"return" .= returnType ]
instance ToJSON API where
toJSON (API uri types methods) =
object ["uri" .= uri,
"types" .= types,
"methods" .= methods]
testAPI :: API
testAPI = API {
apiUri = "http://home.iportnov.ru/test.api"
, apiTypes = M.fromList [("User",TUser (M.fromList [("fullName",TText),("login",TText)]))]
, apiMethods = M.fromList [("sayHello", Method {methodArgs = [THaskell "User"],
methodReturnType = TText})]
}
readAPI :: FilePath -> TH.ExpQ
readAPI path = do
x <- TH.runIO $ (decodeFile path :: IO (Maybe API))
case x of
Nothing -> fail $ "Cannot read API from " ++ path
Just api -> lift api