apis (empty) → 0.0.0

raw patch · 26 files changed

+1238/−0 lines, 26 filesdep +aesondep +basedep +containerssetup-changed

Dependencies added: aeson, base, containers, deepseq, directory, ecma262, exceptions, filemanip, filepath, hslogger, http-conduit, hxt, mtl, opendatatable, split, template-haskell, text, th-lift, time, transformers, unordered-containers, utf8-string, yql

Files

• LICENSE +23/−0
• Setup.hs +2/−0
• apis.cabal +77/−0
• apis/krisinformation/krisinformation.feed.json +65/−0
• apis/krisinformation/krisinformation.feed.xml +17/−0
• apis/smhi/smhi.pmp.json +94/−0
• apis/smhi/smhi.pmp.xml +26/−0
• src/Control/Monad/Trans/API.hs +10/−0
• src/Data/JSON/Schema.hs +120/−0
• src/Data/JSON/Void.hs +18/−0
• src/Data/Settings/YQL.hs +19/−0
• src/Data/State/YQL.hs +7/−0
• src/Data/TH/API.hs +27/−0
• src/Data/TH/Convert.hs +33/−0
• src/Data/TH/FFI.hs +10/−0
• src/Data/TH/Object.hs +9/−0
• src/Data/TH/YQL.hs +17/−0
• src/Helper/File.hs +54/−0
• src/Helper/Name.hs +20/−0
• src/Helper/YQL.hs +12/−0
• src/TH/API.hs +33/−0
• src/TH/API/Input.hs +249/−0
• src/TH/API/Output.hs +157/−0
• src/TH/APIs.hs +29/−0
• src/TH/YQL.hs +84/−0
• src/TH/YQLs.hs +26/−0

@@ -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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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.*++

@@ -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"+}

@@ -0,0 +1,17 @@+<?xml version="1.0" encoding="UTF-8" ?>+<table xmlns="http://query.yahooapis.com/v1/schema/table.xsd">+  <meta>+    <author>Fabian Bergmark</author>+    <documentationURL>http://www.krisinformation.se/web/Pages/Page____73795.aspx</documentationURL>+    <sampleQuery>select * from {table}</sampleQuery>+  </meta>+  <bindings>+    <select produces="JSON">+      <urls>+        <url>http://api.krisinformation.se/v1/feed?format=json</url>+      </urls>+      <inputs>+      </inputs>+    </select>+  </bindings>+</table>

@@ -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"+}

@@ -0,0 +1,26 @@+<?xml version="1.0" encoding="UTF-8" ?>+<table xmlns="http://query.yahooapis.com/v1/schema/table.xsd">+  <meta>+    <author>Fabian Bergmark</author>+    <documentationURL>http://www.smhi.se/klimatdata/Oppna-data/Meteorologiska-data/api-for-vaderprognosdata-1.34233</documentationURL>+    <sampleQuery>select * from {table} where lat="58.59" and lon="16.18"</sampleQuery>+  </meta>+  <bindings>+    <select produces="JSON">+      <urls>+        <url>http://opendata-download-metfcst.smhi.se/api/category/pmp1.5g/version/1/geopoint/lat/{lat}/lon/{lon}/data.json</url>+      </urls>+      <inputs>+        <key id="lat" type="xs:string" paramType="path" required="true" />+        <key id="lon" type="xs:string" paramType="path" required="true" />+      </inputs>+      <execute><![CDATA[+      console.log(request.url);+      var data = request.get().response;+      //console.log(data);+      response.object = data;+      ]]>+      </execute>+    </select>+  </bindings>+</table>

@@ -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

@@ -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)

@@ -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

@@ -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 []) []

@@ -0,0 +1,7 @@+module Data.State.YQL+       ( YQLState(..) ) where++import Network.HTTP.Conduit++class YQLState a where+  yqlStateGetHttpManager :: a -> Manager

@@ -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] }

@@ -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

@@ -0,0 +1,10 @@+module Data.TH.FFI+       ( FFI(..) ) where++import Language.Haskell.TH++data FFI =+  FFI+  { ffiSignature   :: Dec+  , ffiDeclaration :: Dec+  , ffiExport      :: Dec }

@@ -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

@@ -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 }

@@ -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)

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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)) []]

@@ -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+ )

@@ -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

@@ -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+ )