diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,23 @@ +Copyright (c) 2014, Fabian Bergmark +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/apis.cabal b/apis.cabal new file mode 100644 --- /dev/null +++ b/apis.cabal @@ -0,0 +1,77 @@ +name: apis +version: 0.0.0 +synopsis: A Template Haskell library for generating type safe API calls +description: A library that uses Open Data Tables and JSON Schemas to + generate Haskell types and API calls. +homepage: https://github.com/fabianbergmark/APIs +category: Web +author: Fabian Bergmark +maintainer: fabian.bergmark@gmail.com +license: BSD2 +license-file: LICENSE +cabal-version: >= 1.10 +build-type: Simple + +extra-source-files: apis/krisinformation/krisinformation.feed.json + apis/krisinformation/krisinformation.feed.xml + apis/smhi/smhi.pmp.json + apis/smhi/smhi.pmp.xml + LICENSE + +source-repository head + type: git + location: https://github.com/fabianbergmark/APIs.git + +library + default-language: Haskell2010 + + hs-source-dirs: src/ + + exposed-modules: Control.Monad.Trans.API + Data.Settings.YQL + Data.State.YQL + TH.API + TH.API.Input + TH.API.Output + TH.APIs + TH.YQL + TH.YQLs + + other-modules: Data.JSON.Void + Data.JSON.Schema + Data.TH.API + Data.TH.Convert + Data.TH.FFI + Data.TH.Object + Data.TH.YQL + Helper.File + Helper.Name + Helper.YQL + + ghc-options: -fno-warn-orphans -fno-warn-unused-binds -fno-warn-unused-matches + + build-depends: aeson == 0.8.* + , yql == 0.0.* + , base == 4.* + , containers == 0.4.* || == 0.5.* + , deepseq == 1.3.* + , directory == 1.2.* + , ecma262 == 0.0.* + , exceptions == 0.6.* + , filemanip == 0.3.* + , filepath == 1.3.* + , hslogger == 1.2.* + , http-conduit == 2.1.* + , hxt == 9.3.* + , mtl == 2.2.* + , opendatatable == 0.0.* + , split == 0.2.* + , template-haskell == 2.9.* + , text == 1.1.* + , th-lift == 0.6.* + , time == 1.4.* + , transformers == 0.4.* + , unordered-containers == 0.2.* + , utf8-string == 0.3.* + + diff --git a/apis/krisinformation/krisinformation.feed.json b/apis/krisinformation/krisinformation.feed.json new file mode 100644 --- /dev/null +++ b/apis/krisinformation/krisinformation.feed.json @@ -0,0 +1,65 @@ +{ + "properties": { + "Entries": { + "items": { + "properties": { + "Author": { + "type": "string" + }, + "CapArea": { + "items": { + "properties": { + "CapAreaDesc": { + "type": "string" + }, + "Coordinate": { + "type": "string" + } + }, + "required": [ + "CapAreaDesc", + "Coordinate" + ], + "type": "object" + }, + "type": "array" + }, + "CapEvent": { + "type": "string" + }, + "ID": { + "type": "string" + }, + "Link": { + "type": "string" + }, + "Summary": { + "type": "string" + }, + "Title": { + "type": "string" + }, + "Updated": { + "type": "string" + } + }, + "required": [ + "ID", + "Updated", + "CapEvent", + "Author", + "Title", + "Link", + "Summary", + "CapArea" + ], + "type": "object" + }, + "type": "array" + } + }, + "required": [ + "Entries" + ], + "type": "object" +} diff --git a/apis/krisinformation/krisinformation.feed.xml b/apis/krisinformation/krisinformation.feed.xml new file mode 100644 --- /dev/null +++ b/apis/krisinformation/krisinformation.feed.xml @@ -0,0 +1,17 @@ + + + + Fabian Bergmark + http://www.krisinformation.se/web/Pages/Page____73795.aspx + select * from {table} + + + + +
diff --git a/apis/smhi/smhi.pmp.json b/apis/smhi/smhi.pmp.json new file mode 100644 --- /dev/null +++ b/apis/smhi/smhi.pmp.json @@ -0,0 +1,94 @@ +{ + "properties": { + "lat": { + "type": "number" + }, + "lon": { + "type": "number" + }, + "referenceTime": { + "type": "string" + }, + "timeseries": { + "items": { + "properties": { + "gust": { + "type": "number" + }, + "hcc": { + "type": "number" + }, + "lcc": { + "type": "number" + }, + "mcc": { + "type": "number" + }, + "msl": { + "type": "number" + }, + "pcat": { + "type": "number" + }, + "pis": { + "type": "number" + }, + "pit": { + "type": "number" + }, + "r": { + "type": "number" + }, + "t": { + "type": "number" + }, + "tcc": { + "type": "number" + }, + "tstm": { + "type": "number" + }, + "validTime": { + "type": "string" + }, + "vis": { + "type": "number" + }, + "wd": { + "type": "number" + }, + "ws": { + "type": "number" + } + }, + "required": [ + "validTime", + "t", + "msl", + "vis", + "wd", + "ws", + "r", + "tstm", + "tcc", + "lcc", + "mcc", + "hcc", + "gust", + "pcat", + "pis", + "pit" + ], + "type": "object" + }, + "type": "array" + } + }, + "required": [ + "lat", + "lon", + "referenceTime", + "timeseries" + ], + "type": "object" +} diff --git a/apis/smhi/smhi.pmp.xml b/apis/smhi/smhi.pmp.xml new file mode 100644 --- /dev/null +++ b/apis/smhi/smhi.pmp.xml @@ -0,0 +1,26 @@ + + + + Fabian Bergmark + http://www.smhi.se/klimatdata/Oppna-data/Meteorologiska-data/api-for-vaderprognosdata-1.34233 + select * from {table} where lat="58.59" and lon="16.18" + + + + +
diff --git a/src/Control/Monad/Trans/API.hs b/src/Control/Monad/Trans/API.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/API.hs @@ -0,0 +1,10 @@ +module Control.Monad.Trans.API + ( APIT + , runAPIT ) where + +import Control.Monad.State.Strict + +type APIT s m = StateT s m + +runAPIT :: s -> APIT s m a -> m (a, s) +runAPIT = flip runStateT diff --git a/src/Data/JSON/Schema.hs b/src/Data/JSON/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON/Schema.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE FlexibleInstances, + OverloadedStrings, + ScopedTypeVariables, + TemplateHaskell #-} + +module Data.JSON.Schema + ( Const(..) + , ConstSchema + , HasSchema(..) + , Properties(..) + , Schema(..) + , jsonSchema ) where + +import Control.Monad (mzero) + +import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), + (.:), (.=), object) +import Data.HashMap.Strict (toList) +import Data.Text (Text, pack, unpack) +import qualified Data.Traversable as T + +import Language.Haskell.TH.Lift (deriveLift) + +data Schema + = SchemaObject Properties [String] + | SchemaArray Schema + | SchemaString + | SchemaBool + | SchemaNumber + | SchemaInt + | SchemaNull + deriving (Read, Show, Eq) + +newtype Properties = + Properties [(String, Schema)] + deriving (Eq, Read, Show) + +instance FromJSON Properties where + parseJSON (Object json) = do + t <- (flip T.mapM) json $ \v -> parseJSON v + return . Properties $ map (\(k, v) -> (unpack k, v)) (toList t) + parseJSON _ = fail "Can't parse JSON object" + +instance ToJSON Properties where + toJSON (Properties props) = + object $ map (\(k, v) -> (pack k, toJSON v)) props + +instance FromJSON Schema where + parseJSON (Object json) = do + t :: Text <- json .: "type" + case t of + "object" -> do + p <- json .: "properties" + p' <- parseJSON p + r <- json .: "required" + r' <- parseJSON r + return $ SchemaObject p' r' + "array" -> do + i <- json .: "items" + a <- parseJSON i + return $ SchemaArray a + "string" -> return SchemaString + "boolean" -> return SchemaBool + "number" -> return SchemaNumber + "int" -> return SchemaInt + "null" -> return SchemaNull + _ -> mzero + parseJSON _ = mzero + +instance ToJSON Schema where + toJSON (SchemaObject props reqs) = + object [ "properties" .= props + , "required" .= reqs + , "type" .= ("object" :: String) ] + toJSON (SchemaArray item) = + object [ "items" .= item + , "type" .= ("array" :: String) ] + toJSON SchemaString = + object [ "type" .= ("string" :: String) ] + toJSON SchemaBool = + object [ "type" .= ("boolean" :: String) ] + toJSON SchemaNumber = + object [ "type" .= ("number" :: String) ] + toJSON SchemaInt = + object [ "type" .= ("int" :: String) ] + toJSON SchemaNull = + object [ "type" .= ("null" :: String) ] + +jsonSchema :: Value -> Schema +jsonSchema (Object o) = + let + t = fmap jsonSchema o + props = Properties $ map (\(k, v) -> (unpack k, v)) (toList t) + req = map (unpack . fst) (toList t) + in + SchemaObject props req + +newtype Const a b = + Const + { getValue :: b } + +type ConstSchema a = Const a Schema + +class HasSchema a where + toSchema :: ConstSchema a + +instance HasSchema String where + toSchema = Const SchemaString + +instance HasSchema Bool where + toSchema = Const SchemaBool + +instance HasSchema Double where + toSchema = Const SchemaNumber + +instance HasSchema Int where + toSchema = Const SchemaInt + +$(deriveLift ''Properties) +$(deriveLift ''Schema) diff --git a/src/Data/JSON/Void.hs b/src/Data/JSON/Void.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON/Void.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Data.JSON.Void where + +import Prelude +import Data.Aeson +import Data.Data + +data Void + = Void + deriving (Data, Eq, Read, Show, Typeable) + +instance FromJSON Void where + parseJSON Null = return Void + parseJSON _ = fail "void" + +instance ToJSON Void where + toJSON _ = Null diff --git a/src/Data/Settings/YQL.hs b/src/Data/Settings/YQL.hs new file mode 100644 --- /dev/null +++ b/src/Data/Settings/YQL.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Settings.YQL + ( YQLSettings(..) ) where + +import Control.Applicative (pure) +import Data.Aeson + +import Data.JSON.Schema + +data YQLSettings = + YQLSettings + deriving (Eq, Read, Show) + +instance FromJSON YQLSettings where + parseJSON _ = pure YQLSettings + +instance HasSchema YQLSettings where + toSchema = Const $ SchemaObject (Properties []) [] diff --git a/src/Data/State/YQL.hs b/src/Data/State/YQL.hs new file mode 100644 --- /dev/null +++ b/src/Data/State/YQL.hs @@ -0,0 +1,7 @@ +module Data.State.YQL + ( YQLState(..) ) where + +import Network.HTTP.Conduit + +class YQLState a where + yqlStateGetHttpManager :: a -> Manager diff --git a/src/Data/TH/API.hs b/src/Data/TH/API.hs new file mode 100644 --- /dev/null +++ b/src/Data/TH/API.hs @@ -0,0 +1,27 @@ +module Data.TH.API (API(..), APIInput(..), APIOutput(..)) where + +import Language.Haskell.TH + +import Data.OpenDataTable +import Data.JSON.Schema + +data API = + API + { apiName :: String + , apiInput :: APIInput + , apiOutput :: APIOutput } + +data APIInput = + APIInput + { apiInputName :: Name + , apiInputType :: Type + , apiInputOpenDataTable :: (FilePath, OpenDataTable) + , apiInputDeclarations :: [Dec] } + + +data APIOutput = + APIOutput + { apiOutputName :: Name + , apiOutputType :: Type + , apiOutputSchema :: (FilePath, Schema) + , apiOutputDeclarations :: [Dec] } diff --git a/src/Data/TH/Convert.hs b/src/Data/TH/Convert.hs new file mode 100644 --- /dev/null +++ b/src/Data/TH/Convert.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleContexts, + FlexibleInstances, + UndecidableInstances #-} + +module Data.TH.Convert + ( Convert(..) ) where + +import Language.JavaScript.Interpret +import Language.JavaScript.SubType + +class Convert a where + convert :: a -> Primitive + +instance Convert Double where + convert = inj . Number + +instance Convert Int where + convert = inj . Number . fromIntegral + +instance Convert Null where + convert = inj + +instance Convert Undefined where + convert = inj + +instance Convert Number where + convert = inj + +instance Convert String where + convert = inj + +instance Convert Bool where + convert = inj diff --git a/src/Data/TH/FFI.hs b/src/Data/TH/FFI.hs new file mode 100644 --- /dev/null +++ b/src/Data/TH/FFI.hs @@ -0,0 +1,10 @@ +module Data.TH.FFI + ( FFI(..) ) where + +import Language.Haskell.TH + +data FFI = + FFI + { ffiSignature :: Dec + , ffiDeclaration :: Dec + , ffiExport :: Dec } diff --git a/src/Data/TH/Object.hs b/src/Data/TH/Object.hs new file mode 100644 --- /dev/null +++ b/src/Data/TH/Object.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Data.TH.Object + ( Object(..) ) where + +import Data.Map + +class Object a k v where + toObject :: a -> Map k v diff --git a/src/Data/TH/YQL.hs b/src/Data/TH/YQL.hs new file mode 100644 --- /dev/null +++ b/src/Data/TH/YQL.hs @@ -0,0 +1,17 @@ +module Data.TH.YQL + ( YQL(..) + , YQLPipe(..) ) where + +import Language.Haskell.TH + +data YQL = + YQL + { yqlInputType :: Type + , yqlOutputType :: Type + , yqlPipe :: YQLPipe } + +data YQLPipe = + YQLPipe + { yqlPipeName :: Name + , yqlPipeSignature :: Dec + , yqlPipeDeclaration :: Dec } diff --git a/src/Helper/File.hs b/src/Helper/File.hs new file mode 100644 --- /dev/null +++ b/src/Helper/File.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE BangPatterns #-} + +module Helper.File(findAPIs, loadAPI) where + +import Prelude + +import qualified Data.Aeson as Aeson +import Data.Maybe +import qualified Data.ByteString.Lazy.UTF8 as BSL (fromString) + +import Control.Applicative ((<$>)) +import Control.DeepSeq (rnf) +import Control.Monad (forM) + +import System.IO +import System.Directory +import System.FilePath +import System.FilePath.Find + +import Text.XML.HXT.Core (runX, readString, withRemoveWS, yes, (>>>)) + +import Data.OpenDataTable +import Data.JSON.Schema +import Data.OpenDataTable.Parser + +findAPIs :: FilePath -> IO [(FilePath, FilePath)] +findAPIs folder = do + files <- find always (extension ==? ".json") folder + catMaybes <$> (forM files $ \json -> do + let xml = replaceExtension json ".xml" + existsJSON <- doesFileExist json + existsXML <- doesFileExist xml + if (existsJSON && existsXML) + then return $ Just (xml, json) + else return Nothing) + +loadAPI :: (FilePath, FilePath) -> IO (Maybe (OpenDataTable, Schema)) +loadAPI (xml, json) = do + + jsonFile <- openFile json ReadMode + schema <- hGetContents jsonFile + rnf schema `seq` hClose jsonFile + + xmlFile <- openFile xml ReadMode + document <- hGetContents xmlFile + rnf document `seq` hClose xmlFile + + mOpenDataTable <- listToMaybe <$> runX (readString [withRemoveWS yes] document + >>> parseOpenDataTable) + + return $ do + !o <- mOpenDataTable + s <- Aeson.decode . BSL.fromString $ schema + return (o, s) diff --git a/src/Helper/Name.hs b/src/Helper/Name.hs new file mode 100644 --- /dev/null +++ b/src/Helper/Name.hs @@ -0,0 +1,20 @@ +module Helper.Name (snakeCase, camelCase) where + +import Prelude + +import Data.Char +import Data.List.Split + +snakeCase :: FilePath -> String +snakeCase fp = + foldr1 (\x a -> x ++ "_" ++ a) pieces + where + pieces = splitOn "." fp + +camelCase :: FilePath -> String +camelCase fp = + foldr (\x a -> upper x ++ a) [] pieces + where + pieces = splitOn "." fp + upper (x:xs) = (toUpper x : xs) + upper a = a diff --git a/src/Helper/YQL.hs b/src/Helper/YQL.hs new file mode 100644 --- /dev/null +++ b/src/Helper/YQL.hs @@ -0,0 +1,12 @@ +module Helper.YQL + ( yqlURI ) where + +import Prelude + +import Data.List.Split +import System.FilePath (takeFileName) + +yqlURI :: FilePath -> String -> String +yqlURI base url = url ++ path + where pieces = splitOneOf "." $ takeFileName base + path = foldl (\a x -> a ++ x ++ "/") "/" $ pieces diff --git a/src/TH/API.hs b/src/TH/API.hs new file mode 100644 --- /dev/null +++ b/src/TH/API.hs @@ -0,0 +1,33 @@ +module TH.API (generateAPIs) where + +import Prelude + +import Control.Monad (mzero, join, forM) +import Control.Applicative ((<$>)) + +import Language.Haskell.TH.Syntax (Q, qRunIO) + +import System.FilePath (takeBaseName) + +import Helper.File + +import Data.TH.API + +import TH.API.Input +import TH.API.Output + +generateAPIs :: FilePath -> Q [API] +generateAPIs folder = do + files <- qRunIO $ findAPIs folder + join <$> (forM (take 1000 files) $ \file@(xml, json) -> do + let fname = takeBaseName xml + mAPI <- qRunIO $ loadAPI file + case mAPI of + Just (opentable, schema) -> do + input <- generateInput xml opentable + output <- generateOutput json schema + let api = API fname input output + return [api] + _ -> do + qRunIO . print $ "Can't load " ++ fname + return mzero) diff --git a/src/TH/API/Input.hs b/src/TH/API/Input.hs new file mode 100644 --- /dev/null +++ b/src/TH/API/Input.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE RecordWildCards, + TemplateHaskell #-} + +module TH.API.Input + ( generateInput ) where + +import Data.Aeson ((.:), (.:?), (.=), FromJSON, parseJSON, ToJSON, toJSON) +import qualified Data.Aeson as Aeson (object, Value(..)) +import Data.Char +import Data.Data +import qualified Data.Map as Map (fromList) +import Data.Maybe (catMaybes) +import Data.Time.Calendar (Day) + +import Control.Monad +import Control.Applicative((<*>), (<|>), empty, pure) + +import Language.Haskell.TH + +import System.FilePath (takeBaseName) + +import Helper.Name + +import Data.OpenDataTable + +import Data.TH.API +import Data.TH.Convert +import Data.TH.Object + +import Language.JavaScript.Interpret (Primitive) + +generateInput :: FilePath -> OpenDataTable -> Q APIInput +generateInput xml opentable = do + let base = camelCase . takeBaseName $ xml + name = "Input" ++ base + tName = mkName name + selects = [s | (SelectBinding s) <- openDataTableBindings opentable] + + cons <- forM selects $ generateConstructor name + let dec = DataD [] tName [] cons [''Data, ''Eq, ''Read, ''Show, ''Typeable] + + ins <- generateInstances dec opentable + return $ APIInput tName (ConT tName) (xml, opentable) (dec:ins) + +generateConstructor :: String -> Select -> Q Con +generateConstructor name select = do + let infos = [info | (InputKey info) <- selectInputs select] + + fields <- forM infos $ \info -> do + let fieldBase = (toLower . head $ name):(tail name) + fieldHsName = toName $ inputInfoId info + fieldTail = (toUpper . head $ fieldHsName):(tail fieldHsName) + fieldName = fieldBase ++ fieldTail + fieldStrict = NotStrict + fieldType = haskellType info + return (mkName fieldName, fieldStrict, fieldType) + return $ RecC (mkName name) fields + where + toName = map replace + replace '-' = '_' + replace a = a + +generateInstances :: Dec -> OpenDataTable -> Q [Dec] +generateInstances dec opentable = do + toJSONI <- generateToJSONInstance dec opentable + fromJSONI <- generateFromJSONInstance dec opentable + objectI <- generateObjectInstance dec opentable + return [toJSONI, fromJSONI, objectI] + +generateFromJSONInstance :: Dec -> OpenDataTable -> Q Dec +generateFromJSONInstance dec opentable = do + let DataD _ name _ _ _ = dec + insName = ''FromJSON + insType = ConT insName + varType = ConT name + decType = AppT insType varType + ctx = [] + parseJSOND <- generateParseJSONFunction dec opentable + let decs = [parseJSOND] + + return $ InstanceD ctx decType decs + +generateParseJSONFunction :: Dec -> OpenDataTable -> Q Dec +generateParseJSONFunction dec opentable = do + let DataD _ _ _ cons _ = dec + + let selects = [s | (SelectBinding s) <- openDataTableBindings opentable] + + let v = mkName "v" + + alt <- [| (<|>) |] + alts <- mapM (uncurry $ generateParseJSONAlternative v) $ zip cons selects + + let parse = foldr (\a b -> AppE (AppE alt a) b) (VarE 'empty) alts + parseC = Clause [ConP 'Aeson.Object [VarP v]] (NormalB parse) [] + let failC = Clause [WildP] (NormalB (VarE 'mzero)) [] + + return $ FunD 'parseJSON [parseC, failC] + +generateParseJSONAlternative :: Name -> Con -> Select -> Q Exp +generateParseJSONAlternative v (RecC name _) select = do + let infos = [i | (InputKey i) <- selectInputs select] + + construct <- [| (.:) |] + mconstruct <- [| (.:?) |] + star <- [| (<*>) |] + + let con = AppE (VarE 'pure) (ConE name) + var = VarE v + stars = star:stars + ops = stars + app a (InputInfo {..}, op) = + AppE (AppE op a) (AppE (AppE (if inputInfoRequired then construct else mconstruct) var) (LitE $ StringL inputInfoId)) + body = foldl app con $ zip infos ops + + return body +generateParseJSONAlternative _ _ _ = error "Invalid constructor" + +generateToJSONInstance :: Dec -> OpenDataTable -> Q Dec +generateToJSONInstance dec opentable = do + let DataD _ name _ _ _ = dec + insName = ''ToJSON + insType = ConT insName + varType = ConT name + decType = AppT insType varType + ctx = [] + toJSOND <- generateToJSONFunction dec opentable + let decs = [toJSOND] + + return $ InstanceD ctx decType decs + +generateToJSONFunction :: Dec -> OpenDataTable -> Q Dec +generateToJSONFunction dec opentable = do + let DataD _ _ _ cons _ = dec + + let selects = [s | (SelectBinding s) <- openDataTableBindings opentable] + + clauses <- mapM (uncurry generateToJSONClause) $ zip cons selects + + return $ FunD 'toJSON clauses + +generateToJSONClause :: Con -> Select -> Q Clause +generateToJSONClause con select = do + let infos = [i | (InputKey i) <- selectInputs select] + RecC conName fields = con + + pair <- [| (.=) |] + + let arg = mkName "x" + var = VarE arg + pat = AsP arg (RecP conName []) + list = map + (\((fieldName, _, _), info) -> do + let isRequired = inputInfoRequired info + if isRequired + then + AppE + (ConE 'Just) + (AppE + (AppE pair (LitE . StringL $ inputInfoId info)) + (AppE (VarE fieldName) var)) + else + AppE + (AppE + (VarE 'fmap) + (AppE pair (LitE . StringL $ inputInfoId info))) + (AppE (VarE fieldName) var)) + $ zip fields infos + + return $ Clause [pat] + (NormalB $ AppE + (VarE 'Aeson.object) + (AppE + (VarE 'catMaybes) + $ ListE list)) [] + +generateObjectInstance :: Dec -> OpenDataTable -> Q Dec +generateObjectInstance dec opentable = do + let DataD _ name _ _ _ = dec + insName = ''Object + insType = ConT insName + varType = ConT name + decType = AppT (AppT (AppT insType varType) (ConT ''String)) (ConT ''Primitive) + ctx = [] + toObjectD <- generateToObjectFunction dec opentable + let decs = [toObjectD] + + return $ InstanceD ctx decType decs + +generateToObjectFunction :: Dec -> OpenDataTable -> Q Dec +generateToObjectFunction dec opentable = do + let DataD _ _ _ cons _ = dec + + let selects = [s | (SelectBinding s) <- openDataTableBindings opentable] + + clauses <- mapM (uncurry generateToObjectClause) $ zip cons selects + + return $ FunD 'toObject clauses + +generateToObjectClause :: Con -> Select -> Q Clause +generateToObjectClause con select = do + let infos = [i | (InputKey i) <- selectInputs select] + RecC conName fields = con + + pair <- [| \k v -> (k, convert v) |] + + let arg = mkName "x" + var = VarE arg + pat = AsP arg (RecP conName []) + list = map + (\((fieldName, _, _), info) -> do + let isRequired = inputInfoRequired info + if isRequired + then + AppE + (ConE 'Just) + (AppE + (AppE pair (LitE . StringL $ inputInfoId info)) + (AppE (VarE fieldName) var)) + else + AppE + (AppE + (VarE 'fmap) + (AppE pair (LitE . StringL $ inputInfoId info))) + (AppE (VarE fieldName) var)) + $ zip fields infos + + return $ Clause [pat] + (NormalB $ AppE + (VarE 'Map.fromList) + (AppE + (VarE 'catMaybes) + $ ListE list)) [] + +haskellType :: InputInfo -> Type +haskellType info = contextType dataType + where + dataType = + case (inputInfoType info) of + InputTypeBool -> ConT ''Bool + InputTypeDate -> ConT ''Day + InputTypeDouble -> ConT ''Double + InputTypeFloat -> ConT ''Float + InputTypeInt -> ConT ''Int + InputTypeString -> ConT ''String + contextType t = + case (inputInfoRequired info) of + True -> t + False -> AppT (ConT ''Maybe) t diff --git a/src/TH/API/Output.hs b/src/TH/API/Output.hs new file mode 100644 --- /dev/null +++ b/src/TH/API/Output.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE RecordWildCards, + TemplateHaskell #-} + +module TH.API.Output where + +import Control.Applicative ((<$>),(<*>), pure) +import Control.Monad + +import Data.Aeson ((.:), (.:?), (.=), FromJSON, parseJSON, ToJSON, toJSON) +import qualified Data.Aeson as Aeson (object, Value(..)) +import Data.Char +import Data.Data +import Data.Maybe + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import System.FilePath (takeBaseName) + +import Data.TH.API +import Data.JSON.Void +import Data.JSON.Schema + +import Helper.Name + +generateOutput :: FilePath -> Schema -> Q APIOutput +generateOutput json schema@(SchemaObject _ _) = do + let base = camelCase . takeBaseName $ json + name = "Output" ++ base + (t, ds) <- generateDataType name schema + return $ APIOutput (mkName name) t (json, schema) ds + +generateOutput json schema@(SchemaArray _) = do + let base = camelCase . takeBaseName $ json + name = "Output" ++ base + + (t, ds) <- generateDataType name schema + return $ APIOutput (mkName name) t (json, schema) ds + +generateOutput _ _ = + error "The JSON standard only allows objects or arrays at top-level" + +generateDataType :: String -> Schema -> Q (Type, [Dec]) +generateDataType _ SchemaString = return (ConT ''String, []) +generateDataType _ SchemaNumber = return (ConT ''Double, []) +generateDataType _ SchemaInt = return (ConT ''Int, []) +generateDataType _ SchemaBool = return (ConT ''Bool, []) +generateDataType _ SchemaNull = return (ConT ''Void, []) + +generateDataType base (SchemaArray item) = do + (t, ds) <- generateDataType base item + return $ (AppT ListT t, ds) + +generateDataType base (SchemaObject props@(Properties keyval) required) = do + let name = mkName base + fieldBase = (toLower . head $ base):(tail base) + + (fields, dss) <- unzip <$> (forM keyval $ \(fname, schema) -> do + let fieldTail = ((toUpper . head $ fname):(tail fname)) + (t, ds) <- generateDataType (base ++ fieldTail) schema + let isRequired = (elem fname) $ required + + fieldName = mkName (fieldBase ++ fieldTail) + fieldType = if isRequired + then t + else AppT (ConT ''Maybe) t + fieldStrict = NotStrict + return ((fieldName, fieldStrict, fieldType), ds)) + + toJSONID <- generateToJSONInstance name fields props required + fromJSONID <- generateFromJSONInstance name fields props required + + let dec = DataD [] name [] [RecC name fields] [''Data, ''Eq, ''Read, ''Show, ''Typeable] + ds = join dss + return $ (ConT name, dec:toJSONID:fromJSONID:ds) + +generateFromJSONInstance :: Name -> [VarStrictType] -> Properties -> [String] -> Q Dec +generateFromJSONInstance name fields object required = do + let insName = ''FromJSON + insType = ConT insName + varType = ConT name + decType = AppT insType varType + ctx = [] + parseJSOND <- generateParseJSONFunction name fields object required + let decs = [parseJSOND] + return $ InstanceD ctx decType decs + +generateParseJSONFunction :: Name -> [VarStrictType] -> Properties -> [String] -> Q Dec +generateParseJSONFunction name _ props@(Properties keyval) required = do + let construct = VarE '(.:) + mConstruct = VarE '(.:?) + star = VarE '(<*>) + mz = VarE 'mzero + + let fname = 'parseJSON + v = mkName "v" + mzp = AppE (VarE 'fail) (AppE (VarE 'show) (VarE v)) + con = AppE (VarE 'pure) (ConE name) + pat = VarP v + var = VarE v + stars = star:stars + ops = stars + objectP = ConP 'Aeson.Object [pat] + app a ((jname, _), op) = + AppE (AppE op a) + (if elem jname required + then (AppE (AppE construct var) (LitE $ StringL jname)) + else (AppE (AppE mConstruct var) (LitE $ StringL jname))) + body = foldl app con $ zip keyval ops + bodyC = Clause [objectP] (NormalB body) [] + failC = Clause [VarP v] (NormalB mzp) [] + return $ FunD fname [bodyC, failC] + +generateToJSONInstance :: Name -> [VarStrictType] -> Properties -> [String] -> Q Dec +generateToJSONInstance name fields props required = do + let insName = ''ToJSON + insType = ConT insName + varType = ConT name + decType = AppT insType varType + ctx = [] + toJSOND <- generateToJSONFunction name fields props required + let decs = [toJSOND] + return $ InstanceD ctx decType decs + +generateToJSONFunction :: Name -> [VarStrictType] -> Properties -> [String] -> Q Dec +generateToJSONFunction _ fields props@(Properties keyval) required = do + + let pair = VarE '(.=) + + let fname = 'toJSON + arg = mkName "x" + var = VarE arg + pat = VarP arg + list = map + (\((fieldName, _, _), (jname, _)) -> do + let isRequired = elem jname required + if isRequired + then + AppE + (ConE 'Just) + (AppE + (AppE pair (LitE . StringL $ jname)) + (AppE (VarE fieldName) var)) + else + AppE + (AppE + (VarE 'fmap) + (AppE pair (LitE . StringL $ jname))) + (AppE (VarE fieldName) var)) + $ zip fields keyval + + return $ FunD fname [Clause [pat] + (NormalB $ AppE + (VarE 'Aeson.object) + (AppE + (VarE 'catMaybes) + $ ListE list)) []] diff --git a/src/TH/APIs.hs b/src/TH/APIs.hs new file mode 100644 --- /dev/null +++ b/src/TH/APIs.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveDataTypeable, + FlexibleInstances, + MultiParamTypeClasses, + OverloadedStrings, + TemplateHaskell, + TypeSynonymInstances #-} + +module TH.APIs where + +import Language.Haskell.TH + +import qualified Data.TH.API as TH +import Data.TH.Convert () + +import TH.API + +$(do + runIO $ putStrLn "API generation" + apis <- generateAPIs "apis" + runIO . putStrLn $ "..Generated " ++ + (show . length $ apis) ++ + " apis" + runIO $ putStrLn "..Done" + return $ foldr + (\(TH.API _ + (TH.APIInput _ _ _ iDecs) + (TH.APIOutput _ _ _ oDecs)) a -> iDecs ++ oDecs ++ a) + [] apis + ) diff --git a/src/TH/YQL.hs b/src/TH/YQL.hs new file mode 100644 --- /dev/null +++ b/src/TH/YQL.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE RecordWildCards, + ScopedTypeVariables, + TemplateHaskell #-} + +module TH.YQL(generateYQLs, generateYQL) where + +import Control.Applicative ((<$>)) +import Control.Monad.Catch (MonadThrow) +import Control.Monad.IO.Class (MonadIO(liftIO)) + +import Data.Aeson +import Data.Char +import Data.Monoid ((<>)) + +import Language.Haskell.TH (Body(..), Dec(..), Pat(..), + Pred(..), Q, Type(..), TyVarBndr(..), + mkName) + +import System.Log.Logger + +import Control.Monad.Trans.API + +import Data.JSON.Void () +import Data.Settings.YQL +import Data.State.YQL +import Data.TH.API +import Data.TH.YQL +import Data.TH.Object + +import Helper.Name + +import YQL + +generateYQLs :: [API] -> Q [YQL] +generateYQLs apis = do + sequence $ generateYQL <$> apis + +generateYQL :: API -> Q YQL +generateYQL api = do + + let cc = camelCase . apiName $ api + name = (toLower . head $ cc):(tail cc) + inType = apiInputType . apiInput $ api + outType = apiOutputType . apiOutput $ api + + pipe <- generateYQLPipe name api + + return $ YQL inType outType pipe + +generateYQLPipe :: String -> API -> Q YQLPipe +generateYQLPipe base API {..} = do + let name = mkName base + opentable = snd $ apiInputOpenDataTable apiInput + inType = apiInputType $ apiInput + outType = apiOutputType $ apiOutput + + let r = mkName "r" + s = mkName "s" + m = mkName "m" + a = mkName "a" + t = AppT (AppT ArrowT (ConT ''YQLSettings)) (AppT (AppT ArrowT inType) (AppT (AppT (AppT (ConT ''APIT) (VarT s)) (VarT m)) (AppT (ConT ''Maybe) outType))) + t' = ForallT + [ PlainTV s, PlainTV m, PlainTV a ] + [ ClassP ''MonadIO [VarT m] + , ClassP ''MonadThrow [VarT m] + , ClassP ''YQLState [VarT s] ] + t + sig = SigD name t' + + body <- + [| \YQLSettings {..} input -> do + value <- liftIO $ runYQL opentable (toObject input) + case fromJSON value of + Success output -> do + return . Just $ output + Error _ -> do + liftIO $ + errorM + ("YQL." ++ apiName) + "Could not decode response body" + return Nothing |] + let dec = ValD (VarP name) (NormalB body) [] + + return $ YQLPipe name sig dec diff --git a/src/TH/YQLs.hs b/src/TH/YQLs.hs new file mode 100644 --- /dev/null +++ b/src/TH/YQLs.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings, + TemplateHaskell #-} + +module TH.YQLs where + +import Language.Haskell.TH + +import TH.API +import TH.APIs +import TH.YQL +import qualified Data.TH.YQL as TH + +$(do + runIO $ putStrLn "YQL generation" + apis <- generateAPIs "apis" + yqls <- generateYQLs apis + runIO . putStrLn $ "..Generated " ++ + (show . length $ yqls) ++ + " yqls" + runIO $ putStrLn "..Done" + return $ foldr + (\(TH.YQL _ _ + (TH.YQLPipe _ pSig pDec)) a -> + pSig:pDec:a) + [] yqls + )