rest-gen 0.13.1.2 → 0.14

raw patch · 17 files changed

+1004/−934 lines, 17 filesdep +haskell-src-extsdep +uniplatedep −attoparsecdep −bytestringdep −containersdep ~json-schemadep ~rest-corePVP ok

version bump matches the API change (PVP)

Dependencies added: haskell-src-exts, uniplate

Dependencies removed: attoparsec, bytestring, containers, generic-aeson, happstack-server, mtl, regular, rest-types, utf8-string

Dependency ranges changed: json-schema, rest-core

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• rest-gen.cabal +11/−19
• src/Rest/Gen.hs +7/−6
• src/Rest/Gen/Base/ActionInfo.hs +45/−30
• src/Rest/Gen/Base/ActionInfo/Ident.hs +3/−3
• src/Rest/Gen/Base/JSON.hs +19/−12
• src/Rest/Gen/Config.hs +15/−0
• src/Rest/Gen/Docs.hs +212/−0
• src/Rest/Gen/Docs/Generate.hs +0/−212
• src/Rest/Gen/Docs/Happstack.hs +0/−41
• src/Rest/Gen/Haskell.hs +374/−0
• src/Rest/Gen/Haskell/Generate.hs +0/−293
• src/Rest/Gen/JavaScript.hs +127/−0
• src/Rest/Gen/JavaScript/Generate.hs +0/−126
• src/Rest/Gen/Ruby.hs +144/−0
• src/Rest/Gen/Ruby/Generate.hs +0/−142
• src/Rest/Gen/Types.hs +37/−50

@@ -1,5 +1,15 @@ # Changelog +## 0.14++* Abstracted generated code into rest-client, you should regenerate haskell clients+* haskell code generation is now done using `haskell-src-exts`+* When using module name rewrites their qualification are now also rewritten.+* Add `hs-source-dirs` and `build-depends` when generating cabal files+* Moved `Rest.Gen.Docs.Happstack` to `rest-happstack:Rest.Driver.Happstack.Docs`+* Expose `Rest.Gen.Base`+* Flattened module hierarchy, `Rest.Gen.Haskell.Generate` is now `Rest.Gen.Haskell` etc.+ #### 0.13.1.2  * Use `json-schema 0.5.*` and add `showExample` cases for `Map` and `Any`

@@ -1,5 +1,5 @@ name:                rest-gen-version:             0.13.1.2+version:             0.14 description:         Documentation and client generation from rest definition. synopsis:            Documentation and client generation from rest definition. maintainer:          code@silk.co@@ -29,16 +29,15 @@   hs-source-dirs:    src   exposed-modules:     Rest.Gen+    Rest.Gen.Base     Rest.Gen.Config-    Rest.Gen.Docs.Generate-    Rest.Gen.Docs.Happstack-    Rest.Gen.Haskell.Generate-    Rest.Gen.JavaScript.Generate-    Rest.Gen.Ruby.Generate+    Rest.Gen.Docs+    Rest.Gen.Haskell+    Rest.Gen.JavaScript+    Rest.Gen.Ruby     Rest.Gen.Types   other-modules:     Paths_rest_gen-    Rest.Gen.Base     Rest.Gen.Base.ActionInfo     Rest.Gen.Base.ActionInfo.Ident     Rest.Gen.Base.ApiTree@@ -52,33 +51,26 @@     , Cabal >= 1.18 && < 1.22     , HStringTemplate >= 0.6 && < 0.8     , aeson >= 0.7 && < 0.8-    , attoparsec >= 0.10 && < 0.13     , blaze-html >= 0.5 && < 0.8-    , bytestring >= 0.9 && < 0.11     , code-builder == 0.1.*-    , containers >= 0.4 && < 0.6     , directory >= 1.1 && < 1.3     , fclabels >= 1.0.4 && < 2.1     , filepath >= 1.2 && < 1.4-    , generic-aeson == 0.1.*-    , happstack-server >= 7.0.5 && < 7.4     , hashable >= 1.1 && < 1.3+    , haskell-src-exts >= 1.15.0 && < 1.16.0     , hslogger >= 1.1 && < 1.3     , hxt >= 9.2 && < 9.4-    , json-schema == 0.5.*-    , mtl >= 2.0 && < 2.3+    , json-schema == 0.6.*     , pretty >= 1.0 && < 1.2     , process >= 1.0 && < 1.3-    , regular == 0.3.*-    , rest-core >= 0.29 && < 0.31-    , rest-types == 1.10.*+    , rest-core == 0.31.*     , safe >= 0.2 && < 0.4     , scientific >= 0.3.2 && < 0.4     , split >= 0.1 && < 0.3     , tagged >= 0.2 && < 0.8     , text >= 0.11 && < 1.2+    , uniplate >= 1.6.12 && < 1.7     , unordered-containers == 0.2.*-    , utf8-string == 0.3.*     , vector == 0.10.*  test-suite rest-gen-tests@@ -89,7 +81,7 @@   build-depends:       base >= 4.5 && < 4.8     , HUnit == 1.2.*-    , rest-core >= 0.29 && < 0.31+    , rest-core == 0.31.*     , rest-gen     , test-framework == 0.8.*     , test-framework-hunit == 0.3.*

@@ -9,18 +9,19 @@ import System.Directory import System.Exit import System.Process+import qualified Language.Haskell.Exts.Syntax as H  import Rest.Api (Api, Some1 (..), withVersion)  import Rest.Gen.Config-import Rest.Gen.Docs.Generate (DocsContext (DocsContext), writeDocs)-import Rest.Gen.Haskell.Generate (HaskellContext (HaskellContext), mkHsApi)-import Rest.Gen.JavaScript.Generate (mkJsApi)-import Rest.Gen.Ruby.Generate (mkRbApi)+import Rest.Gen.Docs (DocsContext (DocsContext), writeDocs)+import Rest.Gen.Haskell (HaskellContext (HaskellContext), mkHsApi)+import Rest.Gen.JavaScript (mkJsApi)+import Rest.Gen.Ruby (mkRbApi) import Rest.Gen.Types import Rest.Gen.Utils -generate :: Config -> String -> Api m -> [ModuleName] -> [Import] -> [(ModuleName, ModuleName)] -> IO ()+generate :: Config -> String -> Api m -> [H.ModuleName] -> [H.ImportDecl] -> [(H.ModuleName, H.ModuleName)] -> IO () generate config name api sources imports rewrites =   withVersion (get apiVersion config) api (putStrLn "Could not find api version" >> exitFailure) $ \ver (Some1 r) ->      case get action config of@@ -41,7 +42,7 @@        Nothing              -> return ()   where     packageName = map toLower name-    moduleName  = ModuleName $ upFirst packageName+    moduleName  = H.ModuleName $ upFirst packageName  getTargetDir :: Config -> String -> IO String getTargetDir config str =

@@ -39,6 +39,8 @@ #endif import qualified Data.JSON.Schema as J import qualified Data.Label.Total as L+import qualified Language.Haskell.Exts.Parser as H+import qualified Language.Haskell.Exts.Syntax as H  import Rest.Dictionary (Error (..), Input (..), Output (..), Param (..)) import Rest.Driver.Routing (mkListHandler, mkMultiHandler)@@ -48,10 +50,10 @@ import Rest.Schema import qualified Rest.Dictionary as Dict import qualified Rest.Resource   as Rest+import Rest.Gen.Types  import Rest.Gen.Base.ActionInfo.Ident (Ident (Ident)) import Rest.Gen.Base.Link-import Rest.Gen.Types import qualified Rest.Gen.Base.ActionInfo.Ident as Ident import qualified Rest.Gen.Base.JSON             as J import qualified Rest.Gen.Base.XML              as X@@ -92,16 +94,16 @@  -- | Description of input/output data data DataDescription = DataDescription-  { dataType      :: DataType-  , dataTypeDesc  :: String-  , dataSchema    :: String-  , dataExample   :: String-  , haskellType   :: String-  , haskellModule :: [String]+  { dataType       :: DataType+  , dataTypeDesc   :: String+  , dataSchema     :: String+  , dataExample    :: String+  , haskellType    :: Maybe H.Type+  , haskellModules :: [H.ModuleName]   } deriving (Show, Eq)  defaultDescription :: DataDescription-defaultDescription = DataDescription Other "" "" "" "" []+defaultDescription = DataDescription Other "" "" "" Nothing []  chooseType :: [DataDescription] -> Maybe DataDescription chooseType []         = Nothing@@ -292,22 +294,22 @@                                                      , dataTypeDesc = "XML"                                                      , dataSchema   = X.showSchema  . X.getXmlSchema $ d                                                      , dataExample  = X.showExample . X.getXmlSchema $ d-                                                     , haskellType  = typeString d-                                                     , haskellModule = modString d+                                                     , haskellType  = Just $ toHaskellType d+                                                     , haskellModules = modString d                                                      }         handlerInput _ XmlTextI = defaultDescription { dataType     = XML                                                      , dataTypeDesc = "XML"-                                                     , haskellType  = "String"+                                                     , haskellType  = Just haskellStringType                                                      }         handlerInput _ RawXmlI  = defaultDescription { dataType     = XML                                                      , dataTypeDesc = "XML"-                                                     , haskellType  = "String"+                                                     , haskellType  = Just haskellStringType                                                      }         handlerInput d JsonI    = defaultDescription { dataType     = JSON                                                      , dataTypeDesc = "JSON"                                                      , dataExample  = J.showExample . J.schema $ d-                                                     , haskellType  = typeString d-                                                     , haskellModule = modString d+                                                     , haskellType  = Just $ toHaskellType d+                                                     , haskellModules = modString d                                                      }         handlerInput _ FileI    = defaultDescription { dataType     = File                                                      , dataTypeDesc = "File"@@ -324,18 +326,18 @@                                                       , dataTypeDesc  = "XML"                                                       , dataSchema    = X.showSchema  . X.getXmlSchema $ d                                                       , dataExample   = X.showExample . X.getXmlSchema $ d-                                                      , haskellType   = typeString d-                                                      , haskellModule = modString d+                                                      , haskellType   = Just $ toHaskellType d+                                                      , haskellModules = modString d                                                       }         handlerOutput _ RawXmlO  = defaultDescription { dataType     = XML                                                       , dataTypeDesc = "XML"-                                                      , haskellType  = "String"+                                                      , haskellType  = Just haskellStringType                                                       }         handlerOutput d JsonO    = defaultDescription { dataType      = JSON                                                       , dataTypeDesc  = "JSON"                                                       , dataExample   = J.showExample . J.schema $ d-                                                      , haskellType   = typeString d-                                                      , haskellModule = modString d+                                                      , haskellType   = Just $ toHaskellType d+                                                      , haskellModules = modString d                                                       }         handlerOutput _ FileO    = defaultDescription { dataType      = File                                                       , dataTypeDesc  = "File"@@ -349,15 +351,16 @@                                                     , dataTypeDesc  = "XML"                                                     , dataSchema    = X.showSchema  . X.getXmlSchema $ d                                                     , dataExample   = X.showExample . X.getXmlSchema $ d-                                                    , haskellType   = typeString d-                                                    , haskellModule = modString d+                                                    , haskellType   = Just $ toHaskellType d+                                                    , haskellModules = modString d                                                     }         handleError d JsonE    = defaultDescription { dataType      = JSON                                                     , dataTypeDesc  = "JSON"                                                     , dataExample   = J.showExample . J.schema $ d-                                                    , haskellType   = typeString d-                                                    , haskellModule = modString d+                                                    , haskellType   = Just $ toHaskellType d+                                                    , haskellModules = modString d                                                     }+ #if __GLASGOW_HASKELL__ >= 704 typeString :: forall a. Typeable a => Proxy a -> String typeString _ = typeString' . typeOf $ (undefined :: a)@@ -371,20 +374,32 @@                         (tyConName tyCon)                         (concatMap (\t -> " (" ++ typeString' t ++ ")") subs) -modString :: forall a. Typeable a => Proxy a -> [String]-modString _ = filter (\v -> v /= "" && take 4 v /= "GHC.") . modString' . typeOf $ (undefined :: a)+modString :: forall a. Typeable a => Proxy a -> [H.ModuleName]+modString _ = map H.ModuleName . filter (\v -> v /= "" && take 4 v /= "GHC.") . modString' . typeOf $ (undefined :: a)   where modString' tr =           let (tyCon, subs) = splitTyConApp tr           in  tyConModule tyCon : concatMap modString' subs++toHaskellType :: forall a. Typeable a => Proxy a -> H.Type+toHaskellType ty =+  case H.parseType (typeString ty) of+    H.ParseOk parsedType -> parsedType+    H.ParseFailed _loc msg -> error msg #else typeString :: Typeable a => a -> String typeString = show . typeOf -modString :: Typeable a => a -> [String]-modString = filter (/= "") . modString' . typeOf+modString :: Typeable a => a -> [ModuleName]+modString = map ModuleName . filter (/= "") . modString' . typeOf   where modString' tr =           let (tyCon, subs) = splitTyConApp tr           in (intercalate "." . init . splitOn "." . tyConString $ tyCon) : concatMap modString' subs++toHaskellType :: Typeable a => a -> H.Type+toHaskellType ty =+  case H.parseType (typeString ty) of+    H.ParseOk parsedType -> parsedType+    H.ParseFailed _loc msg -> error msg #endif  idIdent :: Id id -> Ident@@ -394,14 +409,14 @@ actionIdent Dict.StringId   = Ident     { Ident.description    = "string"-    , Ident.haskellType    = "String"+    , Ident.haskellType    = haskellStringType     , Ident.haskellModules = []     } actionIdent Dict.ReadId   = Ident     { Ident.description    = describe proxy_-    , Ident.haskellType    =  typeString proxy_-    , Ident.haskellModules = map ModuleName $ modString proxy_+    , Ident.haskellType    = toHaskellType proxy_+    , Ident.haskellModules = modString proxy_     }   where     proxy_ :: Proxy a

@@ -1,9 +1,9 @@ module Rest.Gen.Base.ActionInfo.Ident (Ident (..)) where -import Rest.Gen.Types+import qualified Language.Haskell.Exts.Syntax as H  data Ident = Ident   { description    :: String-  , haskellType    :: String-  , haskellModules :: [ModuleName]+  , haskellType    :: H.Type+  , haskellModules :: [H.ModuleName]   } deriving (Show, Eq)

@@ -3,7 +3,7 @@  import Data.Aeson ((.=)) import Data.JSON.Schema-import Data.Text (pack)+import Data.Maybe import Text.PrettyPrint.HughesPJ import qualified Data.Aeson  as A import qualified Data.Vector as V@@ -14,14 +14,21 @@ showExample = render . pp_value . showExample'   where     showExample' s = case s of-      Choice []     -> A.Null -- Cannot create zero value-      Choice (x:_)  -> showExample' x-      Object fs     -> A.object $ map (\f -> pack (key f) .= showExample' (content f)) fs-      Map v         -> A.object ["<key>" .= showExample' v]-      Tuple vs      -> A.Array $ V.fromList $ map showExample' vs-      Array l _ _ v -> A.Array $ V.fromList $ replicate (l `max` 1) (showExample' v)-      Value _ _     -> A.String "value"-      Boolean       -> A.Bool True-      Number l _    -> A.Number (fromIntegral l)-      Null          -> A.Null-      Any           -> A.String "<value>"+      Choice []    -> A.Null -- Cannot create zero value+      Choice (x:_) -> showExample' x+      Object fs    -> A.object $ map (\f -> key f .= showExample' (content f)) fs+      Map v        -> A.object ["<key>" .= showExample' v]+      Tuple vs     -> A.Array $ V.fromList $ map showExample' vs+      Array l _ v  -> A.Array $ V.fromList $ replicate (lengthBoundExample l `max` 1) (showExample' v)+      Value _      -> A.String "value"+      Boolean      -> A.Bool True+      Number b     -> A.Number . boundExample $ b+      Null         -> A.Null+      Any          -> A.String "<value>"+      Constant v   -> v++boundExample :: Num a => Bound -> a+boundExample b = fromIntegral $ fromMaybe 0 (maybe (lower b) Just (upper b))++lengthBoundExample :: Num a => LengthBound -> a+lengthBoundExample b = fromIntegral $ fromMaybe 0 (maybe (lowerLength b) Just (upperLength b))

@@ -16,13 +16,16 @@   , defaultConfig   , parseLocation   , options+  , configFromArgs   ) where  import Prelude hiding (id, (.)) +import Control.Applicative import Control.Category import Data.Label import System.Console.GetOpt+import System.Environment (getArgs)  data Action   = MakeDocs String | MakeJS | MakeRb | MakeHS data Location = Default | Stream | Location String@@ -61,3 +64,15 @@   , Option ['v'] ["version"]       (ReqArg (set (apiVersion . parent)) "VERSION") "The version of the API under generation. Default latest."   , Option ['p'] ["hide-private"]  (NoArg  (set (apiPrivate . parent) False)) "Generate API for the public, hiding private resources. Not default."   ]++configFromArgs :: String -> IO Config+configFromArgs name = do+  let header = "Usage: " ++ name ++ " [OPTIONS...], with the following options:"+  args <- getArgs+  fst <$> processArgs defaultConfig (options id) header args++processArgs :: a -> [OptDescr (a -> a)] -> String -> [String] -> IO (a, [String])+processArgs defConfig opts header args =+    case getOpt Permute opts args of+        (oargs, nonopts, []    ) -> return (foldl (flip ($)) defConfig oargs, nonopts)+        (_    , _      , errors) -> ioError $ userError $ concat errors ++ usageInfo header opts

@@ -0,0 +1,212 @@+{-# LANGUAGE+    EmptyDataDecls+  , GADTs+  , MultiParamTypeClasses+  , OverlappingInstances+  , ScopedTypeVariables+  , TemplateHaskell+  , TupleSections+  , TypeFamilies+  #-}+module Rest.Gen.Docs+  ( DocsContext (..)+  , cdiv+  , cls+  , mkAllResources+  , mkSingleResource+  , resourcesInfo+  , row+  , subResourcesInfo+  , writeDocs+  ) where++import Prelude hiding (div, head, id, span)+import qualified Prelude as P++import Control.Monad hiding (forM_)+import Data.Function (on)+import Data.Hashable (hash)+import Data.List hiding (head, span)+import Data.String+import System.Directory+import System.FilePath+import System.Log.Logger+import Text.Blaze.Html+import Text.Blaze.Html5 hiding (map)+import Text.Blaze.Html5.Attributes hiding (method, span, title)+import Text.Blaze.Html.Renderer.String+import Text.StringTemplate++import Rest.Api (Router, Version)+import Rest.Gen.Base+import Rest.Gen.Utils++-- | Information about the context in which a resource is contained+data DocsContext = DocsContext+  { rootUrl        :: String+  , contextVersion :: Version+  , templates      :: String+  } deriving (Eq, Show)++writeDocs :: DocsContext -> Router m s -> String -> IO ()+writeDocs context router loc =+  do createDirectoryIfMissing True loc+     let tree = apiSubtrees router+     mkAllResources context tree >>= writeFile (loc </> "index.html")+     mapM_ (writeSingleResource context loc) $ allSubResources tree++writeSingleResource :: DocsContext -> String -> ApiResource -> IO ()+writeSingleResource ctx loc r =+  do let dr = loc </> intercalate "/" (resId r)+     createDirectoryIfMissing True dr+     mkSingleResource ctx r >>= writeFile (dr </> "index.html")++mkAllResources :: DocsContext -> ApiResource -> IO String+mkAllResources ctx tree =+  do tmpls <- directoryGroup (templates ctx)+     tmpl  <- maybe (errorM "Doc generation" "Couldn't find template api-docs-all" >> return (newSTMP "")) return $+                     getStringTemplate "api-docs-all" tmpls+     return $ render+            $ setManyAttrib+                   [ ("listing"  , map (renderHtml . (\v -> resourceLinkAnchor v (resourceDisp v))) . sort . allSubResourceIds $ tree) ]+            $ setManyAttrib+                   [ ("resources", renderHtml $ subResourcesInfo ctx tree )+                   , ("version",   show $ contextVersion ctx  )+                   ]+                   tmpl++mkSingleResource :: DocsContext -> ApiResource -> IO String+mkSingleResource ctx tree =+  do tmpls <- directoryGroup (templates ctx)+     tmpl  <- maybe (errorM "Doc Generation" "Couldn't find template api-docs-resource" >> return (newSTMP "")) return $+                     getStringTemplate "api-docs-resource" tmpls+     return $ render+            $ setManyAttrib+                   [ ("subresources", map (renderHtml . (\v -> resourceLinkRemote (rootUrl ctx) v (resourceDisp v))) $ allResourceIds tree)+                   , ("resource"    , resId tree)+                   , ("parents"     , map (renderHtml . (\v -> resourceLinkRemote (rootUrl ctx) v (toHtml $ last v))) $ tail $ inits (resId tree))+                   , ("identifiers" , map renderHtml $ resourceIdentifiers (resLink tree) (resIdents tree))+                   ]+            $ setManyAttrib+                   [ ("name"        , resName tree)+                   , ("urls"        , renderHtml $ resourceTable tree)+                   , ("description" , resDescription tree)+                   , ("version"     , show $ contextVersion ctx)+                   ]+                   tmpl++-- | Helper functions for generating HTML+cls :: String -> Attribute+cls = class_ . toValue++cdiv :: String -> Html -> Html+cdiv s = div ! cls s++row :: Html -> Html+row = cdiv "row"++-- | Recursively generate information for a resource structure+resourcesInfo :: DocsContext -> ApiResource -> Html+resourcesInfo ctx = foldTree $ (\it -> sequence_ . (resourceInfo ctx it :) )++subResourcesInfo :: DocsContext -> ApiResource -> Html+subResourcesInfo ctx = foldTreeChildren sequence_ $ (\it -> sequence_ . (resourceInfo ctx it :) )++-- | Generate information for one resource+resourceInfo :: DocsContext -> ApiResource -> Html+resourceInfo ctx it = section $+  do resourceAnchor (resId it)+     row $ cdiv "span16 page-header resource-title" $ h1 $ resourceLinkRemote (rootUrl ctx) (resId it) $ resourceDisp (resId it)+     row $+      do cdiv "span10" $+           do h2 $ toHtml "Description"+              p $ toHtml $ resDescription it+         cdiv "span6" $+           do h2 $ toHtml "Identifiers"+              p $ sequence_ $ intersperse br $ resourceIdentifiers (resLink it) (resIdents it)+     br+     resourceTable it++resourceIdentifiers :: Link -> [Link] -> [Html]+resourceIdentifiers lnk lnks =+  case lnks of+    [] -> [toHtml "No identifiers"]+    ls -> map (linkHtml . (lnk ++)) $ ls++resourceTable :: ApiResource -> Html+resourceTable it =+  let urlInfo = groupByFirst . concatMap (\ai -> map (,itemInfo ai) $ flattenLast $ itemLink ai) $ resItems it+  in table ! cls "bordered-table resource-table" $+      do thead $ mapM_ (\v -> th ! cls v $ toHtml v) ["URL", "Method", "Description", "Input", "Output", "Errors", "Parameters"]+         tbody $ flip mapM_ (zip [(1 :: Int)..] urlInfo) $ \(n, (url, ais)) ->+          do tr ! cls ("stripe-" ++ show (n `mod` 2) ++ " url-main-row") $ mapM_ td $+                     [ linkHtml $ url+                     , toHtml $ show $ method $ P.head ais+                     , toHtml $ mkActionDescription (resName it) $ P.head ais+                     , dataDescriptions "None"  $ inputs $ P.head ais+                     , dataDescriptions "None" $ outputs $ P.head ais+                     , dataDescriptions "None" $ errors $ P.head ais+                     , toHtml $ if null (params (P.head ais)) then "None" else intercalate ", " $ params $ P.head ais+                     ]+             flip mapM_ (tail ais) $ \ai ->+                tr ! cls ("stripe-" ++ show (n `mod` 2) ++ " url-data-row") $ mapM_ td $+                     [ return ()+                     , toHtml $ show $ method ai+                     , toHtml $ mkActionDescription (resName it) ai+                     , dataDescriptions "None"  (inputs ai)+                     , dataDescriptions "None" (outputs ai)+                     , dataDescriptions "None" (errors ai)+                     , toHtml $ if null (params ai) then "None" else intercalate ", " $ params ai+                     ]++-- | Generate information for input/output data structure+dataDescriptions :: String -> [DataDescription] -> Html+dataDescriptions s []    = toHtml s+dataDescriptions _ descs =+  table ! cls "data-description" $+    do tr $ flip mapM_ descs $ \desc -> td $ toHtml $ dataTypeDesc desc+       tr $ flip mapM_ descs $ \desc -> td $+        do when (dataSchema desc /= "") $ mkCode (typeLang (dataType desc)) "Schema" $ dataSchema desc+           when (dataExample desc /= "") $ mkCode (typeLang (dataType desc)) "Example" $ dataExample desc+  where typeLang XML  = "xml"+        typeLang JSON = "js"+        typeLang _    = ""++-- | Helper function for setting the right attributes to make something collapsible.+-- The javascript prt can be found in docs.js++mkCode :: String -> String -> String -> Html+mkCode lng cap cd =+  let eid = "idv" ++ show (hash cd)+  in do div ! cls "modal hide fade code" ! id (toValue eid) $+          do cdiv "modal-header" $+              do a ! href (toValue "#") ! cls "close" $ toHtml "x"+                 h3 $ toHtml cap+             cdiv "modal-body" $ pre ! cls ("prettyprint lang-" ++ lng) $ toHtml $ cd+        button ! cls "btn open-modal"+               ! customAttribute (fromString "data-controls-modal") (toValue eid)+               ! customAttribute (fromString "data-backdrop") (toValue "true")+               ! customAttribute (fromString "data-keyboard") (toValue "true")+               $ toHtml cap++resourceId :: ResourceId -> String+resourceId = intercalate "."++resourceDisp :: ResourceId -> Html+resourceDisp = toHtml . intercalate "/"++resourceLinkAnchor :: ResourceId -> Html -> Html+resourceLinkAnchor rid = a ! cls "resource-link" ! href (toValue $ "#" ++ resourceId rid)++resourceLinkRemote :: String -> ResourceId -> Html -> Html+resourceLinkRemote rUrl rid = a ! cls "resource-link" ! href (toValue $ rUrl ++ intercalate "/" rid)++resourceAnchor :: ResourceId -> Html+resourceAnchor rid = a ! name (toValue $ resourceId rid) $ return ()++linkHtml :: Link -> Html+linkHtml =  mapM_ linkItem+  where linkItem (LParam idf)   = toHtml ("/<" ++ idf ++ ">")+        linkItem (LAccess lnks) = span ! class_ (toValue "link-block") $ sequence_ $ intersperse br+                                   $ map linkHtml $ reverse $ sortBy (compare `on` length) lnks+        linkItem x              = toHtml ("/" ++ itemString x)

@@ -1,212 +0,0 @@-{-# LANGUAGE-    EmptyDataDecls-  , GADTs-  , MultiParamTypeClasses-  , OverlappingInstances-  , ScopedTypeVariables-  , TemplateHaskell-  , TupleSections-  , TypeFamilies-  #-}-module Rest.Gen.Docs.Generate-  ( DocsContext (..)-  , cdiv-  , cls-  , mkAllResources-  , mkSingleResource-  , resourcesInfo-  , row-  , subResourcesInfo-  , writeDocs-  ) where--import Prelude hiding (div, head, id, span)-import qualified Prelude as P--import Control.Monad hiding (forM_)-import Data.Function (on)-import Data.Hashable (hash)-import Data.List hiding (head, span)-import Data.String-import System.Directory-import System.FilePath-import System.Log.Logger-import Text.Blaze.Html-import Text.Blaze.Html5 hiding (map)-import Text.Blaze.Html5.Attributes hiding (method, span, title)-import Text.Blaze.Html.Renderer.String-import Text.StringTemplate--import Rest.Api (Router, Version)-import Rest.Gen.Base-import Rest.Gen.Utils---- | Information about the context in which a resource is contained-data DocsContext = DocsContext-  { rootUrl        :: String-  , contextVersion :: Version-  , templates      :: String-  } deriving (Eq, Show)--writeDocs :: DocsContext -> Router m s -> String -> IO ()-writeDocs context router loc =-  do createDirectoryIfMissing True loc-     let tree = apiSubtrees router-     mkAllResources context tree >>= writeFile (loc </> "index.html")-     mapM_ (writeSingleResource context loc) $ allSubResources tree--writeSingleResource :: DocsContext -> String -> ApiResource -> IO ()-writeSingleResource ctx loc r =-  do let dr = loc </> intercalate "/" (resId r)-     createDirectoryIfMissing True dr-     mkSingleResource ctx r >>= writeFile (dr </> "index.html")--mkAllResources :: DocsContext -> ApiResource -> IO String-mkAllResources ctx tree =-  do tmpls <- directoryGroup (templates ctx)-     tmpl  <- maybe (errorM "Doc generation" "Couldn't find template api-docs-all" >> return (newSTMP "")) return $-                     getStringTemplate "api-docs-all" tmpls-     return $ render-            $ setManyAttrib-                   [ ("listing"  , map (renderHtml . (\v -> resourceLinkAnchor v (resourceDisp v))) . sort . allSubResourceIds $ tree) ]-            $ setManyAttrib-                   [ ("resources", renderHtml $ subResourcesInfo ctx tree )-                   , ("version",   show $ contextVersion ctx  )-                   ]-                   tmpl--mkSingleResource :: DocsContext -> ApiResource -> IO String-mkSingleResource ctx tree =-  do tmpls <- directoryGroup (templates ctx)-     tmpl  <- maybe (errorM "Doc Generation" "Couldn't find template api-docs-resource" >> return (newSTMP "")) return $-                     getStringTemplate "api-docs-resource" tmpls-     return $ render-            $ setManyAttrib-                   [ ("subresources", map (renderHtml . (\v -> resourceLinkRemote (rootUrl ctx) v (resourceDisp v))) $ allResourceIds tree)-                   , ("resource"    , resId tree)-                   , ("parents"     , map (renderHtml . (\v -> resourceLinkRemote (rootUrl ctx) v (toHtml $ last v))) $ tail $ inits (resId tree))-                   , ("identifiers" , map renderHtml $ resourceIdentifiers (resLink tree) (resIdents tree))-                   ]-            $ setManyAttrib-                   [ ("name"        , resName tree)-                   , ("urls"        , renderHtml $ resourceTable tree)-                   , ("description" , resDescription tree)-                   , ("version"     , show $ contextVersion ctx)-                   ]-                   tmpl---- | Helper functions for generating HTML-cls :: String -> Attribute-cls = class_ . toValue--cdiv :: String -> Html -> Html-cdiv s = div ! cls s--row :: Html -> Html-row = cdiv "row"---- | Recursively generate information for a resource structure-resourcesInfo :: DocsContext -> ApiResource -> Html-resourcesInfo ctx = foldTree $ (\it -> sequence_ . (resourceInfo ctx it :) )--subResourcesInfo :: DocsContext -> ApiResource -> Html-subResourcesInfo ctx = foldTreeChildren sequence_ $ (\it -> sequence_ . (resourceInfo ctx it :) )---- | Generate information for one resource-resourceInfo :: DocsContext -> ApiResource -> Html-resourceInfo ctx it = section $-  do resourceAnchor (resId it)-     row $ cdiv "span16 page-header resource-title" $ h1 $ resourceLinkRemote (rootUrl ctx) (resId it) $ resourceDisp (resId it)-     row $-      do cdiv "span10" $-           do h2 $ toHtml "Description"-              p $ toHtml $ resDescription it-         cdiv "span6" $-           do h2 $ toHtml "Identifiers"-              p $ sequence_ $ intersperse br $ resourceIdentifiers (resLink it) (resIdents it)-     br-     resourceTable it--resourceIdentifiers :: Link -> [Link] -> [Html]-resourceIdentifiers lnk lnks =-  case lnks of-    [] -> [toHtml "No identifiers"]-    ls -> map (linkHtml . (lnk ++)) $ ls--resourceTable :: ApiResource -> Html-resourceTable it =-  let urlInfo = groupByFirst . concatMap (\ai -> map (,itemInfo ai) $ flattenLast $ itemLink ai) $ resItems it-  in table ! cls "bordered-table resource-table" $-      do thead $ mapM_ (\v -> th ! cls v $ toHtml v) ["URL", "Method", "Description", "Input", "Output", "Errors", "Parameters"]-         tbody $ flip mapM_ (zip [(1 :: Int)..] urlInfo) $ \(n, (url, ais)) ->-          do tr ! cls ("stripe-" ++ show (n `mod` 2) ++ " url-main-row") $ mapM_ td $-                     [ linkHtml $ url-                     , toHtml $ show $ method $ P.head ais-                     , toHtml $ mkActionDescription (resName it) $ P.head ais-                     , dataDescriptions "None"  $ inputs $ P.head ais-                     , dataDescriptions "None" $ outputs $ P.head ais-                     , dataDescriptions "None" $ errors $ P.head ais-                     , toHtml $ if null (params (P.head ais)) then "None" else intercalate ", " $ params $ P.head ais-                     ]-             flip mapM_ (tail ais) $ \ai ->-                tr ! cls ("stripe-" ++ show (n `mod` 2) ++ " url-data-row") $ mapM_ td $-                     [ return ()-                     , toHtml $ show $ method ai-                     , toHtml $ mkActionDescription (resName it) ai-                     , dataDescriptions "None"  (inputs ai)-                     , dataDescriptions "None" (outputs ai)-                     , dataDescriptions "None" (errors ai)-                     , toHtml $ if null (params ai) then "None" else intercalate ", " $ params ai-                     ]---- | Generate information for input/output data structure-dataDescriptions :: String -> [DataDescription] -> Html-dataDescriptions s []    = toHtml s-dataDescriptions _ descs =-  table ! cls "data-description" $-    do tr $ flip mapM_ descs $ \desc -> td $ toHtml $ dataTypeDesc desc-       tr $ flip mapM_ descs $ \desc -> td $-        do when (dataSchema desc /= "") $ mkCode (typeLang (dataType desc)) "Schema" $ dataSchema desc-           when (dataExample desc /= "") $ mkCode (typeLang (dataType desc)) "Example" $ dataExample desc-  where typeLang XML  = "xml"-        typeLang JSON = "js"-        typeLang _    = ""---- | Helper function for setting the right attributes to make something collapsible.--- The javascript prt can be found in docs.js--mkCode :: String -> String -> String -> Html-mkCode lng cap cd =-  let eid = "idv" ++ show (hash cd)-  in do div ! cls "modal hide fade code" ! id (toValue eid) $-          do cdiv "modal-header" $-              do a ! href (toValue "#") ! cls "close" $ toHtml "x"-                 h3 $ toHtml cap-             cdiv "modal-body" $ pre ! cls ("prettyprint lang-" ++ lng) $ toHtml $ cd-        button ! cls "btn open-modal"-               ! customAttribute (fromString "data-controls-modal") (toValue eid)-               ! customAttribute (fromString "data-backdrop") (toValue "true")-               ! customAttribute (fromString "data-keyboard") (toValue "true")-               $ toHtml cap--resourceId :: ResourceId -> String-resourceId = intercalate "."--resourceDisp :: ResourceId -> Html-resourceDisp = toHtml . intercalate "/"--resourceLinkAnchor :: ResourceId -> Html -> Html-resourceLinkAnchor rid = a ! cls "resource-link" ! href (toValue $ "#" ++ resourceId rid)--resourceLinkRemote :: String -> ResourceId -> Html -> Html-resourceLinkRemote rUrl rid = a ! cls "resource-link" ! href (toValue $ rUrl ++ intercalate "/" rid)--resourceAnchor :: ResourceId -> Html-resourceAnchor rid = a ! name (toValue $ resourceId rid) $ return ()--linkHtml :: Link -> Html-linkHtml =  mapM_ linkItem-  where linkItem (LParam idf)   = toHtml ("/<" ++ idf ++ ">")-        linkItem (LAccess lnks) = span ! class_ (toValue "link-block") $ sequence_ $ intersperse br-                                   $ map linkHtml $ reverse $ sortBy (compare `on` length) lnks-        linkItem x              = toHtml ("/" ++ itemString x)

@@ -1,41 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Rest.Gen.Docs.Happstack-  ( apiDocsHandler-  ) where--import Control.Monad-import Control.Monad.Trans-import Happstack.Server-import Rest.Api-import Rest.Gen.Base-import Rest.Gen.Docs.Generate---- | Web interface for documentation-apiDocsHandler :: (ServerMonad m, MonadPlus m, FilterMonad Response m, MonadIO m) => String -> String -> Api a -> m Response-apiDocsHandler rootURL tmpls api =-  let mkCtx v ct = DocsContext (rootURL ++ ct ++ "/") v tmpls-      serve ctx = serveDocs ctx . sortTree . noPrivate . (\(Some1 r) -> apiSubtrees r)-  in path $ \i -> withVersion i api mzero $ \v -> serve (mkCtx v i)--serveDocs :: (ServerMonad m, MonadPlus m, FilterMonad Response m, MonadIO m) => DocsContext -> ApiResource -> m Response-serveDocs ctx tree =-  msum $-    [ nullDir >> allDocsHandler ctx tree-    , docHandlers ctx tree-    ]---allDocsHandler :: (ServerMonad m, MonadPlus m, FilterMonad Response m, MonadIO m) => DocsContext -> ApiResource -> m Response-allDocsHandler ctx tree =-  do pg <- liftIO $ mkAllResources ctx tree-     setHeaderM "Content-Type" "text/html"-     return $ toResponse pg--docHandlers :: (ServerMonad m, MonadPlus m, FilterMonad Response m, MonadIO m) => DocsContext -> ApiResource -> m Response-docHandlers ctx = foldTreeChildren msum $ \it subs ->-  dir (resName it) $ msum $-       [ nullDir >> do pg <- liftIO $ mkSingleResource ctx it-                       setHeaderM "Content-Type" "text/html"-                       return $ toResponse pg-       ]-    ++ subs

@@ -0,0 +1,374 @@+{-# LANGUAGE+    DoAndIfThenElse+  , PatternGuards+  , TemplateHaskell+  #-}+module Rest.Gen.Haskell+  ( HaskellContext (..)+  , mkHsApi+  ) where++import Control.Applicative+import Control.Arrow (first, second)+import Control.Category+import Control.Monad+import Data.Label (modify, set)+import Data.Label.Derive (mkLabelsNamed)+import Data.List+import Data.Maybe+import Prelude hiding (id, (.))+import Safe+import System.Directory+import System.FilePath+import qualified Data.Generics.Uniplate.Data                 as U+import qualified Distribution.ModuleName                     as Cabal+import qualified Distribution.Package                        as Cabal+import qualified Distribution.PackageDescription             as Cabal+import qualified Distribution.PackageDescription.Parse       as Cabal+import qualified Distribution.PackageDescription.PrettyPrint as Cabal+import qualified Distribution.Simple.Utils                   as Cabal+import qualified Distribution.Verbosity                      as Cabal+import qualified Distribution.Version                        as Cabal+import qualified Language.Haskell.Exts.Pretty                as H+import qualified Language.Haskell.Exts.Syntax                as H++import Rest.Api (Router, Version)++import Rest.Gen.Base+import Rest.Gen.Types+import Rest.Gen.Utils+import qualified Rest.Gen.Base.ActionInfo.Ident as Ident++mkLabelsNamed ("_" ++) [''Cabal.GenericPackageDescription, ''Cabal.CondTree, ''Cabal.Library]++data HaskellContext =+  HaskellContext+    { apiVersion     :: Version+    , targetPath     :: String+    , wrapperName    :: String+    , includePrivate :: Bool+    , sources        :: [H.ModuleName]+    , imports        :: [H.ImportDecl]+    , rewrites       :: [(H.ModuleName, H.ModuleName)]+    , namespace      :: [String]+    }++mkHsApi :: HaskellContext -> Router m s -> IO ()+mkHsApi ctx r =+  do let tree = sortTree . (if includePrivate ctx then id else noPrivate) . apiSubtrees $ r+     mkCabalFile ctx tree+     mapM_ (writeRes ctx) $ allSubTrees tree++mkCabalFile :: HaskellContext -> ApiResource -> IO ()+mkCabalFile ctx tree =+  do cabalExists <- doesFileExist cabalFile+     gpkg <-+       if cabalExists+       then updateExposedModules modules <$> Cabal.readPackageDescription Cabal.normal cabalFile+       else return (mkGenericPackageDescription (wrapperName ctx) modules)+     writeCabalFile cabalFile gpkg+  where+    cabalFile = targetPath ctx </> wrapperName ctx ++ ".cabal"+    modules   = map (Cabal.fromString . unModuleName) (sources ctx)+             ++ map (Cabal.fromString . qualModName . (namespace ctx ++)) (allSubResourceIds tree)++writeCabalFile :: FilePath -> Cabal.GenericPackageDescription -> IO ()+writeCabalFile path = Cabal.writeUTF8File path . unlines . filter emptyField . lines . Cabal.showGenericPackageDescription+  where emptyField = (/= "\"\" ") . takeWhile (/= ':') . reverse++updateExposedModules :: [Cabal.ModuleName] -> Cabal.GenericPackageDescription -> Cabal.GenericPackageDescription+updateExposedModules modules = modify _condLibrary (Just . maybe (mkCondLibrary modules) (set (_exposedModules . _condTreeData) modules))++mkGenericPackageDescription :: String -> [Cabal.ModuleName] -> Cabal.GenericPackageDescription+mkGenericPackageDescription name modules = Cabal.GenericPackageDescription pkg [] (Just (mkCondLibrary modules)) [] [] []+  where+    pkg = Cabal.emptyPackageDescription+      { Cabal.package        = Cabal.PackageIdentifier (Cabal.PackageName name) (Cabal.Version [0, 1] [])+      , Cabal.buildType      = Just Cabal.Simple+      , Cabal.specVersionRaw = Right (Cabal.orLaterVersion (Cabal.Version [1, 8] []))+      }++mkCondLibrary :: [Cabal.ModuleName] -> Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.Library+mkCondLibrary modules = Cabal.CondNode+  { Cabal.condTreeData        = Cabal.Library modules True Cabal.emptyBuildInfo { Cabal.hsSourceDirs = ["src"] }+  , Cabal.condTreeConstraints =+     [ Cabal.Dependency (Cabal.PackageName "base")        (Cabal.withinVersion $ Cabal.Version [4]     [])+     , Cabal.Dependency (Cabal.PackageName "rest-types")  (Cabal.withinVersion $ Cabal.Version [1, 10] [])+     , Cabal.Dependency (Cabal.PackageName "rest-client") (Cabal.withinVersion $ Cabal.Version [0,  4] [])+     ]+  , Cabal.condTreeComponents  = []+  }++writeRes :: HaskellContext -> ApiResource -> IO ()+writeRes ctx node =+  do createDirectoryIfMissing True (targetPath ctx </> "src" </> modPath (namespace ctx ++ resParents node))+     writeFile (targetPath ctx </> "src" </> modPath (namespace ctx ++ resId node) ++ ".hs") (mkRes ctx node)++mkRes :: HaskellContext -> ApiResource -> String+mkRes ctx node = H.prettyPrint $ buildHaskellModule ctx node pragmas Nothing+  where+    pragmas = [ H.LanguagePragma noLoc [H.Ident "OverloadedStrings"],+                H.OptionsPragma noLoc (Just H.GHC) "-fno-warn-unused-imports"]+    _warningText = "Warning!! This is automatically generated code, do not modify!"++buildHaskellModule :: HaskellContext -> ApiResource ->+                      [H.ModulePragma] -> Maybe H.WarningText ->+                      H.Module+buildHaskellModule ctx node pragmas warningText =+  rewriteModuleNames (rewrites ctx) $+     H.Module noLoc name pragmas warningText exportSpecs importDecls decls+  where+    name = H.ModuleName $ qualModName $ namespace ctx ++ resId node+    exportSpecs = Nothing+    importDecls = nub $ namedImport "Rest.Client.Internal"+                      : extraImports+                     ++ parentImports+                     ++ dataImports+                     ++ idImports+    decls = idData node ++ concat funcs++    extraImports = imports ctx+    parentImports = map mkImport . tail . inits . resParents $ node+    dataImports = map (qualImport . unModuleName) datImp+    idImports = concat . mapMaybe (return . map (qualImport . unModuleName) . Ident.haskellModules <=< snd) . resAccessors $ node++    (funcs, datImp) = second (nub . concat) . unzip . map (mkFunction (apiVersion ctx) . resName $ node) $ resItems node+    mkImport p = (namedImport importName) { H.importQualified = True,+                                            H.importAs = importAs' }+      where importName = qualModName $ namespace ctx ++ p+            importAs' = fmap (H.ModuleName . modName) . lastMay $ p++rewriteModuleNames :: [(H.ModuleName, H.ModuleName)] -> H.Module -> H.Module+rewriteModuleNames rews = U.transformBi $ \m -> lookupJustDef m m rews++noBinds :: H.Binds+noBinds = H.BDecls []++use :: H.Name -> H.Exp+use = H.Var . H.UnQual++useMQual :: (Maybe H.ModuleName) -> H.Name -> H.Exp+useMQual Nothing = use+useMQual (Just qual) = H.Var . (H.Qual $ qual)++mkFunction :: Version -> String -> ApiAction -> ([H.Decl], [H.ModuleName])+mkFunction ver res (ApiAction _ lnk ai) =+  ([H.TypeSig noLoc [funName] fType,+    H.FunBind [H.Match noLoc funName fParams Nothing rhs noBinds]],+   errorInfoModules errorI ++ infoModules output ++ maybe [] infoModules mInp)+     where+       funName = mkHsName ai+       fParams = map H.PVar $ lPars+                           ++ maybe [] ((:[]) . hsName . cleanName . description) (ident ai)+                           ++ maybe [] (const [input]) mInp+                           ++ (if null (params ai) then [] else [pList])+       (lUrl, lPars) = linkToURL res lnk+       mInp    = fmap inputInfo . chooseType . inputs $ ai+       fType   = H.TyForall Nothing [H.ClassA (H.UnQual cls) [m]] $ fTypify tyParts+         where cls = H.Ident "ApiStateC"+               m = H.TyVar $ H.Ident "m"+               fTypify :: [H.Type] -> H.Type+               fTypify [] = error "Rest.Gen.Haskell.mkFunction.fTypify - expects at least one type"+               fTypify [ty1] = ty1+               fTypify [ty1, ty2] = H.TyFun ty1 ty2+               fTypify (ty1 : tys) = H.TyFun ty1 (fTypify tys)+               tyParts = map qualIdent lPars+                         ++ maybe [] (return . Ident.haskellType) (ident ai)+                         ++ inp+                         ++ (if null (params ai) then []+                             else [H.TyList (H.TyTuple H.Boxed [haskellStringType,+                                                                haskellStringType])])+                         ++ [H.TyApp m (H.TyApp+                                         (H.TyApp+                                           (H.TyCon $ H.UnQual (H.Ident "ApiResponse"))+                                           (maybe haskellUnitType id (errorInfoType errorI)))+                                         (maybe haskellUnitType id (infoType output)))]+               qualIdent (H.Ident s)+                 | s == res = H.TyCon $ H.UnQual tyIdent+                 | otherwise = H.TyCon $ H.Qual (H.ModuleName $ modName s) tyIdent+               qualIdent H.Symbol{} = error "Rest.Gen.Haskell.mkFunction.qualIdent - not expecting a Symbol"+               inp | Just i <- mInp,+                     Just i' <- infoType i = [i']+                   | otherwise = []+       input = H.Ident "input"+       pList = H.Ident "pList"+       rhs = H.UnGuardedRhs $ H.Let binds expr+         where binds = H.BDecls [rHeadersBind, requestBind]+               rHeadersBind =+                 H.PatBind noLoc (H.PVar rHeaders) Nothing+                    (H.UnGuardedRhs $ H.List [H.Tuple H.Boxed [use hAccept, H.Lit $ H.String $ infoContentType output],+                                              H.Tuple H.Boxed [use hContentType, H.Lit $ H.String $ maybe "text/plain" infoContentType mInp]])+                              noBinds++               rHeaders     = H.Ident "rHeaders"+               hAccept      = H.Ident "hAccept"+               hContentType = H.Ident "hContentType"+               doRequest    = H.Ident "doRequest"++               requestBind =+                 H.PatBind noLoc (H.PVar request) Nothing+                    (H.UnGuardedRhs $+                      appLast+                        (H.App+                          (H.App+                            (H.App+                              (H.App (H.App (use makeReq) (H.Lit $ H.String $ show $ method ai))+                                     (H.Lit $ H.String ve))+                              url)+                            (if null (params ai) then (H.List []) else (use pList)))+                          (use rHeaders))) noBinds+               appLast e+                 | Just i <- mInp = H.App e (H.App (use $ H.Ident $ infoFunc i) (use input))+                 | otherwise = H.App e (H.Lit $ H.String "")+               makeReq = H.Ident "makeReq"+               request = H.Ident "request"++               expr = H.App (H.App (H.App (use doRequest)+                                          (use $ H.Ident $ errorInfoFunc errorI))+                                          (use $ H.Ident $ infoFunc output)) (use request)++       (ve, url) = ("v" ++ show ver, lUrl)+       errorI = headDef (ErrorInfo [] (Just haskellUnitType) defaultErrorConversion)+                . map errorInfo+                . mapMaybe (\v -> find ((v ==) . dataType) $ errors ai)+                $ maybeToList (dataType <$> chooseType (outputs ai)) ++ [XML, JSON]+       output = maybe (Info [] (Just haskellUnitType) "text/plain" "(const ())") outputInfo . chooseType . outputs $ ai+       defaultErrorConversion = if fmap dataType (chooseType (outputs ai)) == Just JSON then "fromJSON" else "fromXML"++linkToURL :: String -> Link -> (H.Exp, [H.Name])+linkToURL res lnk = first H.List $ urlParts res lnk ([], [])++urlParts :: String -> Link -> ([H.Exp], [H.Name]) -> ([H.Exp], [H.Name])+urlParts res lnk ac@(rlnk, pars) =+  case lnk of+    [] -> ac+    (LResource r : a@(LAccess _) : xs)+      | not (hasParam a) -> urlParts res xs (rlnk ++ [H.List [H.Lit $ H.String r]], pars)+      | otherwise -> urlParts res xs (rlnk', pars ++ [H.Ident r])+           where rlnk' = rlnk ++ (H.List [H.Lit $ H.String $ r] : tailed)+                 tailed = [H.App (useMQual qual $ H.Ident "readId")+                                 (use $ hsName (cleanName r))]+                   where qual | r == res = Nothing+                              | otherwise = Just $ H.ModuleName $ modName r+    (LParam p : xs) -> urlParts res xs (rlnk ++ [H.List [H.App (use $ H.Ident "showUrl")+                                                          (use $ hsName (cleanName p))]], pars)+    (i : xs) -> urlParts res xs (rlnk ++ [H.List [H.Lit $ H.String $ itemString i]], pars)++idData :: ApiResource -> [H.Decl]+idData node =+  case resAccessors node of+    [] -> []+    [(_pth, Nothing)] -> []+    [(pth, Just i)] ->+      let pp xs | null pth = xs+                | otherwise = H.Lit (H.String pth) : xs+      in [ H.TypeDecl noLoc tyIdent [] (Ident.haskellType i),+           H.TypeSig noLoc [funName] fType,+           H.FunBind [ H.Match noLoc funName [H.PVar x] Nothing+                       (H.UnGuardedRhs $ H.List $ pp [ showURLx ]) noBinds] ]+    ls ->+      let ctor (pth,mi) =+            H.QualConDecl noLoc [] [] (H.ConDecl (H.Ident (dataName pth)) $ maybe [] f mi)+              where f ty = [H.UnBangedTy $ Ident.haskellType ty]+          fun (pth, mi) = [+                           H.FunBind [H.Match noLoc funName fparams Nothing rhs noBinds]]+            where (fparams, rhs) =+                    case mi of+                      Nothing ->+                        ([H.PVar $ H.Ident (dataName pth)],+                         (H.UnGuardedRhs $ H.List [H.Lit (H.String pth)]))+                      Just{}  ->  -- Pattern match with data constructor+                        ([H.PParen $ H.PApp (H.UnQual $ H.Ident (dataName pth)) [H.PVar x]],+                         (H.UnGuardedRhs $ H.List [H.Lit $ H.String pth, showURLx]))+      in [ H.DataDecl noLoc H.DataType [] tyIdent [] (map ctor ls) []+         , H.TypeSig noLoc [funName] fType+         ] ++ concatMap fun ls+    where+      x        = H.Ident "x"+      fType    = H.TyFun (H.TyCon $ H.UnQual tyIdent) (H.TyList haskellStringType)+      funName  = H.Ident "readId"+      showURLx = H.App (H.Var $ H.UnQual $ H.Ident "showUrl") (H.Var $ H.UnQual $ x)++tyIdent :: H.Name+tyIdent = H.Ident "Identifier"++mkHsName :: ActionInfo -> H.Name+mkHsName ai = hsName $ concatMap cleanName parts+  where+      parts = case actionType ai of+                Retrieve   -> let nm = get ++ by ++ target+                              in if null nm then ["access"] else nm+                Create     -> ["create"] ++ by ++ target+                -- Should be delete, but delete is a JS keyword and causes problems in collect.+                Delete     -> ["remove"] ++ by ++ target+                DeleteMany -> ["removeMany"] ++ by ++ target+                List       -> ["list"]   ++ by ++ target+                Update     -> ["save"]   ++ by ++ target+                UpdateMany -> ["saveMany"] ++ by ++ target+                Modify   -> if resDir ai == "" then ["do"] else [resDir ai]++      target = if resDir ai == "" then maybe [] ((:[]) . description) (ident ai) else [resDir ai]+      by     = if target /= [] && (isJust (ident ai) || actionType ai == UpdateMany) then ["by"] else []+      get    = if isAccessor ai then [] else ["get"]++hsName :: [String] -> H.Name+hsName []       = H.Ident ""+hsName (x : xs) = H.Ident $ clean $ downFirst x ++ concatMap upFirst xs+  where+    clean s = if s `elem` reservedNames then s ++ "_" else s+    reservedNames =+      ["as","case","class","data","instance","default","deriving","do"+      ,"foreign","if","then","else","import","infix","infixl","infixr","let"+      ,"in","module","newtype","of","qualified","type","where"]++qualModName :: ResourceId -> String+qualModName = intercalate "." . map modName++modPath :: ResourceId -> String+modPath = intercalate "/" . map modName++dataName :: String -> String+dataName = modName++modName :: String -> String+modName = concatMap upFirst . cleanName++data Info = Info+  { infoModules     :: [H.ModuleName]+  , infoType        :: Maybe H.Type+  , infoContentType :: String+  , infoFunc        :: String+  } deriving (Eq, Show)++inputInfo :: DataDescription -> Info+inputInfo ds =+  case dataType ds of+    String -> Info []                  (Just haskellStringType)     "text/plain"               "fromString"+    XML    -> Info (haskellModules ds) (haskellType ds)             "text/xml"                 "toXML"+    JSON   -> Info (haskellModules ds) (haskellType ds)             "text/json"                "toJSON"+    File   -> Info []                  (Just haskellByteStringType) "application/octet-stream" "id"+    Other  -> Info []                  (Just haskellByteStringType) "text/plain"               "id"++outputInfo :: DataDescription -> Info+outputInfo ds =+  case dataType ds of+    String -> Info []                  (Just haskellStringType)     "text/plain" "toString"+    XML    -> Info (haskellModules ds) (haskellType ds)             "text/xml"   "fromXML"+    JSON   -> Info (haskellModules ds) (haskellType ds)             "text/json"  "fromJSON"+    File   -> Info []                  (Just haskellByteStringType) "*"          "id"+    Other  -> Info []                  (Just haskellByteStringType)"text/plain" "id"++data ErrorInfo = ErrorInfo+  { errorInfoModules :: [H.ModuleName]+  , errorInfoType    :: (Maybe H.Type)+  , errorInfoFunc    :: String+  } deriving (Eq, Show)++errorInfo :: DataDescription -> ErrorInfo+errorInfo ds =+  case dataType ds of+    String -> ErrorInfo (haskellModules ds) (haskellType ds) "fromXML"+    XML    -> ErrorInfo (haskellModules ds) (haskellType ds) "fromXML"+    JSON   -> ErrorInfo (haskellModules ds) (haskellType ds) "fromJSON"+    File   -> ErrorInfo (haskellModules ds) (haskellType ds) "fromXML"+    Other  -> ErrorInfo (haskellModules ds) (haskellType ds) "fromXML"

@@ -1,293 +0,0 @@-{-# LANGUAGE-    DoAndIfThenElse-  , TemplateHaskell-  #-}-module Rest.Gen.Haskell.Generate-  ( HaskellContext (..)-  , mkHsApi-  ) where--import Control.Applicative-import Control.Arrow (first, second)-import Control.Category-import Control.Monad-import Data.Label (modify, set)-import Data.Label.Derive (mkLabelsNamed)-import Data.List-import Data.Maybe-import Prelude hiding (id, (.))-import Safe-import System.Directory-import System.FilePath-import qualified Distribution.ModuleName                     as Cabal-import qualified Distribution.Package                        as Cabal-import qualified Distribution.PackageDescription             as Cabal-import qualified Distribution.PackageDescription.Parse       as Cabal-import qualified Distribution.PackageDescription.PrettyPrint as Cabal-import qualified Distribution.Simple.Utils                   as Cabal-import qualified Distribution.Verbosity                      as Cabal-import qualified Distribution.Version                        as Cabal--import Code.Build-import Code.Build.Haskell-import Rest.Api (Router, Version)--import Rest.Gen.Base-import Rest.Gen.Types-import Rest.Gen.Utils-import qualified Rest.Gen.Base.ActionInfo.Ident as Ident--mkLabelsNamed ("_" ++) [''Cabal.GenericPackageDescription, ''Cabal.CondTree, ''Cabal.Library]--data HaskellContext =-  HaskellContext-    { apiVersion     :: Version-    , targetPath     :: String-    , wrapperName    :: String-    , includePrivate :: Bool-    , sources        :: [ModuleName]-    , imports        :: [Import]-    , rewrites       :: [(ModuleName, ModuleName)]-    , namespace      :: [String]-    }--mkHsApi :: HaskellContext -> Router m s -> IO ()-mkHsApi ctx r =-  do let tree = sortTree . (if includePrivate ctx then id else noPrivate) . apiSubtrees $ r-     mkCabalFile ctx tree-     mapM_ (writeRes ctx) $ allSubTrees tree--mkCabalFile :: HaskellContext -> ApiResource -> IO ()-mkCabalFile ctx tree =-  do cabalExists <- doesFileExist cabalFile-     gpkg <--       if cabalExists-       then updateExposedModules modules <$> Cabal.readPackageDescription Cabal.normal cabalFile-       else return (mkGenericPackageDescription (wrapperName ctx) modules)-     writeCabalFile cabalFile gpkg-  where-    cabalFile = targetPath ctx </> wrapperName ctx ++ ".cabal"-    modules   = map (Cabal.fromString . unModuleName) (sources ctx)-             ++ map (Cabal.fromString . qualModName . (namespace ctx ++)) (allSubResourceIds tree)--writeCabalFile :: FilePath -> Cabal.GenericPackageDescription -> IO ()-writeCabalFile path = Cabal.writeUTF8File path . unlines . filter emptyField . lines . Cabal.showGenericPackageDescription-  where emptyField = (/= "\"\" ") . takeWhile (/= ':') . reverse--updateExposedModules :: [Cabal.ModuleName] -> Cabal.GenericPackageDescription -> Cabal.GenericPackageDescription-updateExposedModules modules = modify _condLibrary (Just . maybe (mkCondLibrary modules) (set (_exposedModules . _condTreeData) modules))--mkGenericPackageDescription :: String -> [Cabal.ModuleName] -> Cabal.GenericPackageDescription-mkGenericPackageDescription name modules = Cabal.GenericPackageDescription pkg [] (Just (mkCondLibrary modules)) [] [] []-  where-    pkg = Cabal.emptyPackageDescription-      { Cabal.package        = Cabal.PackageIdentifier (Cabal.PackageName name) (Cabal.Version [0, 1] [])-      , Cabal.buildType      = Just Cabal.Simple-      , Cabal.specVersionRaw = Right (Cabal.orLaterVersion (Cabal.Version [1, 8] []))-      }--mkCondLibrary :: [Cabal.ModuleName] -> Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.Library-mkCondLibrary modules = Cabal.CondNode-  { Cabal.condTreeData        = Cabal.Library modules True Cabal.emptyBuildInfo-  , Cabal.condTreeConstraints = []-  , Cabal.condTreeComponents  = []-  }--writeRes :: HaskellContext -> ApiResource -> IO ()-writeRes ctx node =-  do createDirectoryIfMissing True (targetPath ctx </> "src" </> modPath (namespace ctx ++ resParents node))-     writeFile (targetPath ctx </> "src" </> modPath (namespace ctx ++ resId node) ++ ".hs") (mkRes ctx node)--mkRes :: HaskellContext -> ApiResource -> String-mkRes ctx node =-  showCode $-      "{-# LANGUAGE OverloadedStrings #-}\n{-# OPTIONS_GHC -fno-warn-unused-imports #-}\n{- Warning!! This is automatically generated code, do not modify! -}"-  <-> hsModule (qualModName $ namespace ctx ++ resId node)-       [ mkImports ctx node mods-       , idData node-       , mkStack funcs-       ]-  where-    (funcs, mods) = second (nub . concat) . unzip . map (mkFunction (apiVersion ctx) . resName $ node) $ resItems node--mkImports :: HaskellContext -> ApiResource -> [ModuleName] -> Code-mkImports ctx node datImp-  = mkStack . nub . map (rewriteImport $ rewrites ctx)-  $    [Import UnQualified (ModuleName "Rest.Client.Internal") Nothing Nothing]-    ++ extraImports-    ++ parentImports-    ++ dataImports-    ++ idImports-  where-    extraImports  = imports ctx-    parentImports = map mkImport . tail . inits . resParents $ node-    dataImports   = map qualImp datImp-    idImports     = concat . mapMaybe (return . map qualImp . Ident.haskellModules <=< snd) . resAccessors $ node-    -- We need the `as' name to be explicit here even though it's the same, see comment below.-    qualImp v     = Import Qualified v (Just v) Nothing-    mkImport p    = Import Qualified (ModuleName . qualModName $ namespace ctx ++ p) (Just . ModuleName . modName . last $ p) Nothing-    rewriteImport :: [(ModuleName, ModuleName)] -> Import -> Import-    rewriteImport rws i = case i of-      -- We don't rewrite the `as` part of the import so if you have a-      -- rewrite ("Data.Text.Internal.Lazy", "Data.Text.Lazy") the-      -- import will become `import qualified Data.Text as-      -- Data.Text.Internal.Lazy', this is because mkFunction produces-      -- types through strings and doesn't take rewrites into-      -- account. mkFunction should be changed to do this.-      Import q m mas l -> Import q (look m) mas l-      where-       look m = lookupJustDef m m rws--mkFunction :: Version -> String -> ApiAction -> (Code, [ModuleName])-mkFunction ver res (ApiAction _ lnk ai) =-  let mInp     = fmap inputInfo $ chooseType $ inputs ai-      defaultErrorConversion = if fmap dataType (chooseType (outputs ai)) == Just JSON then "fromJSON" else "fromXML"-      (oMod, oType, oCType, oFunc) = maybe ([], "()", "text/plain", "(const ())") outputInfo $ chooseType $ outputs ai-      (eMod, eType, eFunc) = headDef (([], "()", defaultErrorConversion))-                           . map errorInfo-                           . catMaybes-                           . map (\v -> find ((v ==) . dataType) $ errors ai)-                           $ maybeToList (fmap dataType $ chooseType (outputs ai)) ++ [XML, JSON]-      (lUrl, lPars) = linkToURL res lnk-      url      = string ("v" <+> show ver <+> "/") <++> "++" <++> lUrl-      fParams  = map (hsName . cleanName) lPars-              ++ maybe [] ((:[]) . hsName . cleanName . description) (ident ai)-              ++ maybe [] (const ["input"]) mInp-              ++ (if null (params ai) then [] else ["pList"])-      fType    = "ApiStateC m => "-              ++ (hsType $ map (\p -> (if p == res then "" else modName p ++ ".") ++ "Identifier") lPars-                       ++ maybe [] (return . Ident.haskellType) (ident ai)-                       ++ maybe [] (\(_,v,_,_) -> [v]) mInp-                       ++ (if null (params ai) then [] else ["[(String, String)]"])-                       ++ ["m (ApiResponse (" ++ eType ++ ") (" ++ oType ++ "))"])-  in ( mkStack $-        [ function (mkHsName ai) fType-        , hsDecl (mkHsName ai) fParams $-           hsLet-              [ "rHeaders" .=. hsArray [ hsTuple [code "hAccept", string oCType]-                                       , hsTuple [code "hContentType", string (maybe "text/plain" (\(_,_,v,_) -> v) mInp)]-                                       ]-              , "request" .=. "ApiRequest"-                                  <++> string (show (method ai))-                                  <++> parenthesis url-                                  <++> (if null (params ai) then "[]" else "pList")-                                  <++> "rHeaders"-                                  <++> "$"-                                  <++> maybe "\"\"" ((++ " input") . (\(_,_,_,v) -> v)) mInp-              ]-              $ "liftM (parseResult" <++> eFunc <++> oFunc <+> ") . doRequest $ request"-        ]-     , map ModuleName $ eMod ++ oMod ++ maybe [] (\(m,_,_,_) -> m) mInp-     )--linkToURL :: String -> Link -> (Code, [String])-linkToURL res lnk = first (\v -> "intercalate" <++> string "/" <++> parenthesis ("map encode $ concat" <++> hsArray v)) $ urlParts res lnk ([], [])--urlParts :: String -> Link -> ([Code], [String]) -> ([Code], [String])-urlParts res lnk ac@(rlnk, pars) =-  case lnk of-    [] -> ac-    (LResource r : a@(LAccess _) : xs) | not (hasParam a) -> urlParts res xs (rlnk ++ [hsArray [string r]], pars)-                                       | otherwise ->-      urlParts res xs-            ( rlnk ++ [ hsArray [string r]-                      , (if r == res then noCode else modName r <+> ".") <+> "readId" <++> hsName (cleanName r)-                      ]-            , pars ++ [r]-            )-    (LParam p : xs) -> urlParts res xs (rlnk ++ [hsArray ["showUrl" <++> hsName (cleanName p)]], pars)-    (i : xs) -> urlParts res xs (rlnk ++ [hsArray [string $ itemString i]], pars)--idData :: ApiResource -> Code-idData node =-  case resAccessors node of-    []  -> noCode-    [(pth,mi)] -> maybe noCode-           (\i -> mkStack-            [ code "type Identifier = " <++> Ident.haskellType i-            , function "readId" "Identifier -> [String]"-            , hsDecl "readId" ["x"] (hsArray $ if pth /= ""-                                               then [string pth, code "showUrl x"]-                                               else [code "showUrl x"]-                                    )-            ]-           )-           mi-    ls  -> mkStack $-            [ hsData "Identifier" $ map (\(pth,mi) -> dataName pth ++ maybe "" (\x -> " (" ++ Ident.haskellType x ++ ")") mi) ls-            , function "readId" "Identifier -> [String]"-            , mkStack $-                map (\(pth,mi) ->-                        if isJust mi-                          then hsDecl "readId" ["(" ++ dataName pth ++ " x" ++ ")"] $ hsArray [string pth, code "showUrl x"]-                          else hsDecl "readId" [dataName pth] $ hsArray [string pth]-                    ) ls-            ]--mkHsName :: ActionInfo -> String-mkHsName ai = hsName $ concatMap cleanName parts-  where-      parts = case actionType ai of-                Retrieve   -> let nm = get ++ by ++ target-                              in if null nm then ["access"] else nm-                Create     -> ["create"] ++ by ++ target-                -- Should be delete, but delete is a JS keyword and causes problems in collect.-                Delete     -> ["remove"] ++ by ++ target-                DeleteMany -> ["removeMany"] ++ by ++ target-                List       -> ["list"]   ++ by ++ target-                Update     -> ["save"]   ++ by ++ target-                UpdateMany -> ["saveMany"] ++ by ++ target-                Modify   -> if resDir ai == "" then ["do"] else [resDir ai]--      target = if resDir ai == "" then maybe [] ((:[]) . description) (ident ai) else [resDir ai]-      by     = if target /= [] && (isJust (ident ai) || actionType ai == UpdateMany) then ["by"] else []-      get    = if isAccessor ai then [] else ["get"]--hsName :: [String] -> String-hsName []       = ""-hsName (x : xs) = clean $ downFirst x ++ concatMap upFirst xs-  where-    clean s = if s `elem` reservedNames then s ++ "_" else s-    reservedNames =-      ["as","case","class","data","instance","default","deriving","do"-      ,"foreign","if","then","else","import","infix","infixl","infixr","let"-      ,"in","module","newtype","of","qualified","type","where"]--qualModName :: ResourceId -> String-qualModName = intercalate "." . map modName--modPath :: ResourceId -> String-modPath = intercalate "/" . map modName--modName :: String -> String-modName = concatMap upFirst . cleanName--dataName :: String -> String-dataName = modName--inputInfo :: DataDescription -> ([String], String, String, String)-inputInfo ds =-  case dataType ds of-    String -> ([], "String", "text/plain", "fromString")-    XML    -> (haskellModule ds, haskellType ds, "text/xml", "toXML")-    JSON   -> (haskellModule ds, haskellType ds, "text/json", "toJSON")-    File   -> ([], "ByteString", "application/octet-stream", "id")-    Other  -> ([], "ByteString", "text/plain", "id")--outputInfo :: DataDescription -> ([String], String, String, String)-outputInfo ds =-  case dataType ds of-    String -> ([], "String", "text/plain", "toString")-    XML    -> (haskellModule ds, haskellType ds, "text/xml", "fromXML")-    JSON   -> (haskellModule ds, haskellType ds, "text/json", "fromJSON")-    File   -> ([], "ByteString", "*", "id")-    Other  -> ([], "ByteString", "text/plain", "id")--errorInfo :: DataDescription -> ([String], String, String)-errorInfo ds =-  case dataType ds of-    String -> (haskellModule ds, haskellType ds, "fromXML")-    XML    -> (haskellModule ds, haskellType ds, "fromXML")-    JSON   -> (haskellModule ds, haskellType ds, "fromJSON")-    File   -> (haskellModule ds, haskellType ds, "fromXML")-    Other  -> (haskellModule ds, haskellType ds, "fromXML")

@@ -0,0 +1,127 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Rest.Gen.JavaScript (mkJsApi) where++import Code.Build+import Code.Build.JavaScript++import Control.Monad+import Data.Maybe+import Text.StringTemplate+import qualified Language.Haskell.Exts.Syntax as H++import Rest.Api (Router, Version)+import Rest.Gen.Base+import Rest.Gen.Types+import Rest.Gen.Utils++mkJsApi :: H.ModuleName -> Bool -> Version -> Router m s -> IO String+mkJsApi ns priv ver r =+  do prelude <- liftM (render . setManyAttrib attrs . newSTMP) (readContent "Javascript/base.js")+     let cod = showCode $ mkStack+                [ unModuleName ns ++ ".prototype.version" .=. string (show ver)+                , mkJsCode (unModuleName ns) priv r+                ]+     return $ prelude ++ cod+  where attrs = [("apinamespace", unModuleName ns), ("dollar", "$")]++mkJsCode :: String -> Bool -> Router m s -> Code+mkJsCode ns priv = mkJs ns . sortTree . (if priv then id else noPrivate) . apiSubtrees++mkJs :: String -> ApiResource -> Code+mkJs ns = foldTreeChildren mkStack (\i ls -> mkStack $ mkRes ns i : ls)++mkRes :: String -> ApiResource -> Code+mkRes ns node = mkStack $+  [ if hasAccessor node+      then resourceLoc ns node .=. ns ++ ".makeSilkConstructor()"+      else resourceLoc ns node .=. jsObject []+  , resourceLoc ns node ++ ".apiObjectType" .=. string "resourceDir"+  , mkAccessFuncs ns node+  , mkPreFuncs ns node+  , mkPostFuncs ns node+  ]++mkPreFuncs :: String -> ApiResource -> Code+mkPreFuncs ns node =+  let items = filter ((\i -> not $ postAction i || isAccessor i) . itemInfo) $ resItems node+  in mkFunctions (resourceLoc ns node ++ ".") (mkFunction ns) items++mkAccessFuncs :: String -> ApiResource -> Code+mkAccessFuncs ns node =+  let items = filter ((\i -> not (postAction i) && isAccessor i) . itemInfo) $ resItems node+  in mkFunctions (resourceLoc ns node ++ ".") (mkAccessor ns) items++mkPostFuncs :: String -> ApiResource -> Code+mkPostFuncs ns node =+  let items = filter (postAction . itemInfo) $ resItems node+  in mkFunctions (resourceLoc ns node ++ ".prototype.") (mkFunction ns) items++mkFunctions :: String -> (ApiAction -> Code) -> [ApiAction] -> Code+mkFunctions loc maker = mkStack . map (\item -> loc ++ mkJsName item .=. maker item)++mkAccessor :: String -> ApiAction -> Code+mkAccessor ns node@(ApiAction _ _ ai) =+  let fParams  = maybeToList mIdent+      urlPart  = (if resDir ai == "" then "" else resDir ai ++ "/")+              ++ maybe "" (\i -> "' + encodeURIComponent(" ++ i ++ ") + '/") mIdent+      mIdent   = fmap (jsId . cleanName . description) $ ident ai+  in function fParams $+      [ var "accessor" $ new "this" . code $ "this.contextUrl + '" ++ urlPart ++ "'"+      , "accessor.get" .=. mkFunction ns node+      , ret "accessor"+      ]++mkFunction :: String -> ApiAction -> Code+mkFunction ns (ApiAction _ _ ai) =+  let fParams  = maybeToList mIdent+              ++ maybeToList (fmap fst3 mInp)+              ++ ["success", "error", "params", "callOpts"]+      mInp     = fmap mkType . chooseType $ inputs ai+      mOut     = fmap mkType . chooseType $ outputs ai+      urlPart  = (if isAccessor ai then const "" else id) $+                 (if resDir ai == "" then "" else resDir ai ++ "/")+              ++ maybe "" (\i -> "' + encodeURIComponent(" ++ i ++ ") + '/") mIdent+      mIdent   = (if isAccessor ai then const Nothing else id) $ fmap (jsId . cleanName . description) $ ident ai+  in function fParams $ ret $+        proc (ns ++ "." ++ "ajaxCall")+          [ string (method ai)+          , code $ (if (https ai) then "this.secureContextUrl" else "this.contextUrl") ++ " + '" ++ urlPart ++ "'"+          , code "params"+          , code "success"+          , code "error"+          , string $ maybe "text/plain" snd3 mInp+          , string $ maybe "text" fst3 mOut+          , maybe (code "undefined") (\(p, _, f) -> f (code p)) mInp+          , code "callOpts"+          ]++resourceLoc :: String -> ApiResource -> String+resourceLoc ns = ((ns ++ ".prototype.") ++) . locFromLink . resLink+  where locFromLink (LResource i1 : LAccess [] : LResource i2 : xs) = jsDir (cleanName i1) ++ "." ++ locFromLink (LResource i2 : xs)+        locFromLink (LResource i : xs) = case locFromLink xs of+                                          [] -> jsDir $ cleanName i+                                          ls -> jsDir (cleanName i) ++ ".prototype." ++ ls+        locFromLink (_ : xs) = locFromLink xs+        locFromLink [] = ""++mkJsName :: ApiAction -> String+mkJsName item =+  case mkFuncParts item of+    []       -> ""+    (x : xs) -> x ++ concatMap upFirst xs++jsDir :: [String] -> String+jsDir = concatMap upFirst++jsId :: [String] -> String+jsId []       = ""+jsId (x : xs) = x ++ concatMap upFirst xs++mkType :: DataDescription -> (String, String, Code -> Code)+mkType ds =+  case dataType ds of+    String -> ("text", "text/plain", id)+    XML    -> ("xml" , "text/xml", id)+    JSON   -> ("json", "text/json", call "JSON.stringify")+    File   -> ("file", "application/octet-stream", id)+    Other  -> ("text", "text/plain", id)

@@ -1,126 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Rest.Gen.JavaScript.Generate (mkJsApi) where--import Code.Build-import Code.Build.JavaScript--import Control.Monad-import Data.Maybe-import Text.StringTemplate--import Rest.Api (Router, Version)-import Rest.Gen.Base-import Rest.Gen.Types-import Rest.Gen.Utils--mkJsApi :: ModuleName -> Bool -> Version -> Router m s -> IO String-mkJsApi ns priv ver r =-  do prelude <- liftM (render . setManyAttrib attrs . newSTMP) (readContent "Javascript/base.js")-     let cod = showCode $ mkStack-                [ unModuleName ns ++ ".prototype.version" .=. string (show ver)-                , mkJsCode (unModuleName ns) priv r-                ]-     return $ prelude ++ cod-  where attrs = [("apinamespace", unModuleName ns), ("dollar", "$")]--mkJsCode :: String -> Bool -> Router m s -> Code-mkJsCode ns priv = mkJs ns . sortTree . (if priv then id else noPrivate) . apiSubtrees--mkJs :: String -> ApiResource -> Code-mkJs ns = foldTreeChildren mkStack (\i ls -> mkStack $ mkRes ns i : ls)--mkRes :: String -> ApiResource -> Code-mkRes ns node = mkStack $-  [ if hasAccessor node-      then resourceLoc ns node .=. ns ++ ".makeSilkConstructor()"-      else resourceLoc ns node .=. jsObject []-  , resourceLoc ns node ++ ".apiObjectType" .=. string "resourceDir"-  , mkAccessFuncs ns node-  , mkPreFuncs ns node-  , mkPostFuncs ns node-  ]--mkPreFuncs :: String -> ApiResource -> Code-mkPreFuncs ns node =-  let items = filter ((\i -> not $ postAction i || isAccessor i) . itemInfo) $ resItems node-  in mkFunctions (resourceLoc ns node ++ ".") (mkFunction ns) items--mkAccessFuncs :: String -> ApiResource -> Code-mkAccessFuncs ns node =-  let items = filter ((\i -> not (postAction i) && isAccessor i) . itemInfo) $ resItems node-  in mkFunctions (resourceLoc ns node ++ ".") (mkAccessor ns) items--mkPostFuncs :: String -> ApiResource -> Code-mkPostFuncs ns node =-  let items = filter (postAction . itemInfo) $ resItems node-  in mkFunctions (resourceLoc ns node ++ ".prototype.") (mkFunction ns) items--mkFunctions :: String -> (ApiAction -> Code) -> [ApiAction] -> Code-mkFunctions loc maker = mkStack . map (\item -> loc ++ mkJsName item .=. maker item)--mkAccessor :: String -> ApiAction -> Code-mkAccessor ns node@(ApiAction _ _ ai) =-  let fParams  = maybeToList mIdent-      urlPart  = (if resDir ai == "" then "" else resDir ai ++ "/")-              ++ maybe "" (\i -> "' + encodeURIComponent(" ++ i ++ ") + '/") mIdent-      mIdent   = fmap (jsId . cleanName . description) $ ident ai-  in function fParams $-      [ var "accessor" $ new "this" . code $ "this.contextUrl + '" ++ urlPart ++ "'"-      , "accessor.get" .=. mkFunction ns node-      , ret "accessor"-      ]--mkFunction :: String -> ApiAction -> Code-mkFunction ns (ApiAction _ _ ai) =-  let fParams  = maybeToList mIdent-              ++ maybeToList (fmap fst3 mInp)-              ++ ["success", "error", "params", "callOpts"]-      mInp     = fmap mkType . chooseType $ inputs ai-      mOut     = fmap mkType . chooseType $ outputs ai-      urlPart  = (if isAccessor ai then const "" else id) $-                 (if resDir ai == "" then "" else resDir ai ++ "/")-              ++ maybe "" (\i -> "' + encodeURIComponent(" ++ i ++ ") + '/") mIdent-      mIdent   = (if isAccessor ai then const Nothing else id) $ fmap (jsId . cleanName . description) $ ident ai-  in function fParams $ ret $-        proc (ns ++ "." ++ "ajaxCall")-          [ string (method ai)-          , code $ (if (https ai) then "this.secureContextUrl" else "this.contextUrl") ++ " + '" ++ urlPart ++ "'"-          , code "params"-          , code "success"-          , code "error"-          , string $ maybe "text/plain" snd3 mInp-          , string $ maybe "text" fst3 mOut-          , maybe (code "undefined") (\(p, _, f) -> f (code p)) mInp-          , code "callOpts"-          ]--resourceLoc :: String -> ApiResource -> String-resourceLoc ns = ((ns ++ ".prototype.") ++) . locFromLink . resLink-  where locFromLink (LResource i1 : LAccess [] : LResource i2 : xs) = jsDir (cleanName i1) ++ "." ++ locFromLink (LResource i2 : xs)-        locFromLink (LResource i : xs) = case locFromLink xs of-                                          [] -> jsDir $ cleanName i-                                          ls -> jsDir (cleanName i) ++ ".prototype." ++ ls-        locFromLink (_ : xs) = locFromLink xs-        locFromLink [] = ""--mkJsName :: ApiAction -> String-mkJsName item =-  case mkFuncParts item of-    []       -> ""-    (x : xs) -> x ++ concatMap upFirst xs--jsDir :: [String] -> String-jsDir = concatMap upFirst--jsId :: [String] -> String-jsId []       = ""-jsId (x : xs) = x ++ concatMap upFirst xs--mkType :: DataDescription -> (String, String, Code -> Code)-mkType ds =-  case dataType ds of-    String -> ("text", "text/plain", id)-    XML    -> ("xml" , "text/xml", id)-    JSON   -> ("json", "text/json", call "JSON.stringify")-    File   -> ("file", "application/octet-stream", id)-    Other  -> ("text", "text/plain", id)

@@ -0,0 +1,144 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Rest.Gen.Ruby (mkRbApi) where++import Data.Char+import Data.List+import Data.Maybe++import Code.Build+import Code.Build.Ruby++import qualified Language.Haskell.Exts.Syntax as H++import Rest.Api (Router, Version)+import Rest.Gen.Base+import Rest.Gen.Types+import Rest.Gen.Utils++mkRbApi :: H.ModuleName -> Bool -> Version -> Router m s -> IO String+mkRbApi ns priv ver r =+  do prelude <- readContent "Ruby/base.rb"+     let cod = showCode . mkRb (unModuleName ns) ver . sortTree . (if priv then id else noPrivate) . apiSubtrees $ r+     return $ cod ++ prelude++mkRb :: String -> Version -> ApiResource -> Code+mkRb ns ver node =+  rbModule ns $ mkStack+        [ "@version" .=. string (show ver)+        , apiConstructor ver node+        , foldTreeChildren mkStack (\i ls -> mkStack $ mkRes i : ls) node+        ]++apiConstructor :: Version -> ApiResource -> Code+apiConstructor ver node =+  rbClass "BaseApi" $+    [ function "initialize" ["resUrl"] $ mkStack $+        [ "@url" .=. ("resUrl + '/v" ++ show ver ++ "/'")+        , "@api" .=. "self"+        ]+    , mkStack . map resGetter . subResources $ node+    ]++mkRes :: ApiResource -> Code+mkRes node = mkResAcc node <-> mkResObj node++mkResAcc :: ApiResource -> Code+mkResAcc node =+  rbClass (accessorName $ resId node)+    [ accInitializer+    , mkPreFuncs node+    , mkStack . map resGetter . filter (not . hasAccessor) . subResources $ node+    ]++mkResObj :: ApiResource -> Code+mkResObj node =+  rbClass (className $ resId node)+    [ objInitializer+    , if hasAccessor node then get else noCode+    , mkPostFuncs node+    , mkStack . map resGetter . subResources $ node+    ]++mkPostFuncs :: ApiResource -> Code+mkPostFuncs node = mkStack . map mkFunction . filter (postAction . itemInfo) . resItems $ node++mkPreFuncs :: ApiResource -> Code+mkPreFuncs node =+  let (acs, funcs) = partition (isAccessor . itemInfo) . filter ((\i -> not $ postAction i) . itemInfo) $ resItems node+  in mkStack (map mkAccessor acs) <-> mkStack (map mkFunction funcs)++mkAccessor :: ApiAction -> Code+mkAccessor node@(ApiAction rid _ ai) =+  let fParams  = maybeToList mIdent+      urlPart  = (if resDir ai == "" then "" else resDir ai ++ "/")+              ++ maybe "" (\i -> "' + " ++ i ++ " + '/") mIdent+      datType  = maybe ":data" ((':':) . fst3 . mkType) $ chooseType $ outputs ai+      mIdent   = fmap (rbName . cleanName . description) $ ident ai+  in function (rbName $ mkFuncParts node) fParams $ ret $+        new (className rid) ["@url + '" ++ urlPart ++ "'", "@api", datType]++mkFunction :: ApiAction -> Code+mkFunction node@(ApiAction _ _ ai) =+  let fParams   = maybeToList mIdent+              ++ maybeToList (fmap fst3 mInp)+              ++ ["params = {}", "headers = {}"]+      mInp     = fmap mkType . chooseType $ inputs ai+      mOut     = fmap mkType . chooseType $ outputs ai+      urlPart  = (if resDir ai == "" then "" else resDir ai ++ "/")+              ++ maybe "" (\i -> "' + " ++ i ++ " + '/") mIdent+      mIdent   = fmap (rbName . cleanName . description) $ ident ai+  in function (rbName $ mkFuncParts node) fParams $+        call ("internalSilkRequest")+          [ code "@api"+          , code $ ':' : map toLower (show $ method ai)+          , code $ "@url + '" ++ urlPart ++ "'"+          , code "params"+          , string $ maybe "text/plain" snd3 mInp+          , code $ maybe ":data" ((':':) . fst3) mOut+          , maybe (code "nil") (\(p, _, f) -> f (code p)) mInp+          , code "headers"+          ]++accInitializer :: Code+accInitializer =+  function "initialize" ["resUrl", "myApi"]+     [ "@url"      .=. "resUrl"+     , "@api"      .=. "myApi"+     ]++objInitializer :: Code+objInitializer =+  function "initialize" ["resUrl", "myApi", "retData = :data"]+     [ "@url"      .=. "resUrl"+     , "@dataType" .=. "retData"+     , "@api"      .=. "myApi"+     ]++resGetter :: ApiResource -> Code+resGetter node =+  function (className [resName node]) [] $+    ret $ new (accessorName $ resId node) ["@url + '" ++ resName node ++ "/'", "@api"]++get :: Code+get =+  function "get" ["params = {}", "headers = {}"] $+    call "internalSilkRequest" ["@api", ":get", "@url", "params", "'text/plain'", "@dataType", "headers"]++rbName :: [String] -> String+rbName []       = ""+rbName (x : xs) = downFirst x ++ concatMap upFirst xs++className :: ResourceId -> String+className = concatMap upFirst . concatMap cleanName++accessorName :: ResourceId -> String+accessorName = concatMap upFirst . ("Access":) . concatMap cleanName++mkType :: DataDescription -> (String, String, Code -> Code)+mkType ds =+  case dataType ds of+    String -> ("data", "text/plain", id)+    XML    -> ("xml" , "text/xml", (<+> ".to_s"))+    JSON   -> ("json", "text/json", call "mkJson")+    File   -> ("file", "application/octet-stream", id)+    Other  -> ("data", "text/plain", id)

@@ -1,142 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Rest.Gen.Ruby.Generate (mkRbApi) where--import Data.Char-import Data.List-import Data.Maybe--import Code.Build-import Code.Build.Ruby--import Rest.Api (Router, Version)-import Rest.Gen.Base-import Rest.Gen.Types-import Rest.Gen.Utils--mkRbApi :: ModuleName -> Bool -> Version -> Router m s -> IO String-mkRbApi ns priv ver r =-  do prelude <- readContent "Ruby/base.rb"-     let cod = showCode . mkRb (unModuleName ns) ver . sortTree . (if priv then id else noPrivate) . apiSubtrees $ r-     return $ cod ++ prelude--mkRb :: String -> Version -> ApiResource -> Code-mkRb ns ver node =-  rbModule ns $ mkStack-        [ "@version" .=. string (show ver)-        , apiConstructor ver node-        , foldTreeChildren mkStack (\i ls -> mkStack $ mkRes i : ls) node-        ]--apiConstructor :: Version -> ApiResource -> Code-apiConstructor ver node =-  rbClass "BaseApi" $-    [ function "initialize" ["resUrl"] $ mkStack $-        [ "@url" .=. ("resUrl + '/v" ++ show ver ++ "/'")-        , "@api" .=. "self"-        ]-    , mkStack . map resGetter . subResources $ node-    ]--mkRes :: ApiResource -> Code-mkRes node = mkResAcc node <-> mkResObj node--mkResAcc :: ApiResource -> Code-mkResAcc node =-  rbClass (accessorName $ resId node)-    [ accInitializer-    , mkPreFuncs node-    , mkStack . map resGetter . filter (not . hasAccessor) . subResources $ node-    ]--mkResObj :: ApiResource -> Code-mkResObj node =-  rbClass (className $ resId node)-    [ objInitializer-    , if hasAccessor node then get else noCode-    , mkPostFuncs node-    , mkStack . map resGetter . subResources $ node-    ]--mkPostFuncs :: ApiResource -> Code-mkPostFuncs node = mkStack . map mkFunction . filter (postAction . itemInfo) . resItems $ node--mkPreFuncs :: ApiResource -> Code-mkPreFuncs node =-  let (acs, funcs) = partition (isAccessor . itemInfo) . filter ((\i -> not $ postAction i) . itemInfo) $ resItems node-  in mkStack (map mkAccessor acs) <-> mkStack (map mkFunction funcs)--mkAccessor :: ApiAction -> Code-mkAccessor node@(ApiAction rid _ ai) =-  let fParams  = maybeToList mIdent-      urlPart  = (if resDir ai == "" then "" else resDir ai ++ "/")-              ++ maybe "" (\i -> "' + " ++ i ++ " + '/") mIdent-      datType  = maybe ":data" ((':':) . fst3 . mkType) $ chooseType $ outputs ai-      mIdent   = fmap (rbName . cleanName . description) $ ident ai-  in function (rbName $ mkFuncParts node) fParams $ ret $-        new (className rid) ["@url + '" ++ urlPart ++ "'", "@api", datType]--mkFunction :: ApiAction -> Code-mkFunction node@(ApiAction _ _ ai) =-  let fParams   = maybeToList mIdent-              ++ maybeToList (fmap fst3 mInp)-              ++ ["params = {}", "headers = {}"]-      mInp     = fmap mkType . chooseType $ inputs ai-      mOut     = fmap mkType . chooseType $ outputs ai-      urlPart  = (if resDir ai == "" then "" else resDir ai ++ "/")-              ++ maybe "" (\i -> "' + " ++ i ++ " + '/") mIdent-      mIdent   = fmap (rbName . cleanName . description) $ ident ai-  in function (rbName $ mkFuncParts node) fParams $-        call ("internalSilkRequest")-          [ code "@api"-          , code $ ':' : map toLower (show $ method ai)-          , code $ "@url + '" ++ urlPart ++ "'"-          , code "params"-          , string $ maybe "text/plain" snd3 mInp-          , code $ maybe ":data" ((':':) . fst3) mOut-          , maybe (code "nil") (\(p, _, f) -> f (code p)) mInp-          , code "headers"-          ]--accInitializer :: Code-accInitializer =-  function "initialize" ["resUrl", "myApi"]-     [ "@url"      .=. "resUrl"-     , "@api"      .=. "myApi"-     ]--objInitializer :: Code-objInitializer =-  function "initialize" ["resUrl", "myApi", "retData = :data"]-     [ "@url"      .=. "resUrl"-     , "@dataType" .=. "retData"-     , "@api"      .=. "myApi"-     ]--resGetter :: ApiResource -> Code-resGetter node =-  function (className [resName node]) [] $-    ret $ new (accessorName $ resId node) ["@url + '" ++ resName node ++ "/'", "@api"]--get :: Code-get =-  function "get" ["params = {}", "headers = {}"] $-    call "internalSilkRequest" ["@api", ":get", "@url", "params", "'text/plain'", "@dataType", "headers"]--rbName :: [String] -> String-rbName []       = ""-rbName (x : xs) = downFirst x ++ concatMap upFirst xs--className :: ResourceId -> String-className = concatMap upFirst . concatMap cleanName--accessorName :: ResourceId -> String-accessorName = concatMap upFirst . ("Access":) . concatMap cleanName--mkType :: DataDescription -> (String, String, Code -> Code)-mkType ds =-  case dataType ds of-    String -> ("data", "text/plain", id)-    XML    -> ("xml" , "text/xml", (<+> ".to_s"))-    JSON   -> ("json", "text/json", call "mkJson")-    File   -> ("file", "application/octet-stream", id)-    Other  -> ("data", "text/plain", id)

@@ -1,64 +1,51 @@ module Rest.Gen.Types-  ( ModuleName (..)+  ( unModuleName   , overModuleName-  , Import (..)-  , Qualification (..)-  , QName (..)-  , Name (..)+  , namedImport+  , qualImport+  , haskellStringType+  , haskellByteStringType+  , haskellUnitType+  , haskellSimpleType+  , noLoc+  , ModuleName (..)+  , ImportDecl (..)   ) where -import Data.List--import Code.Build--newtype ModuleName = ModuleName { unModuleName :: String }-  deriving (Eq, Show)+import Language.Haskell.Exts.SrcLoc (noLoc)+import Language.Haskell.Exts.Syntax (ImportDecl (..), ModuleName (..), Name (..), QName (..), SpecialCon (..), Type (..)) -instance Codeable ModuleName where-  code = code . unModuleName+unModuleName :: ModuleName -> String+unModuleName (ModuleName name) = name  overModuleName :: (String -> String) -> ModuleName -> ModuleName overModuleName f = ModuleName . f . unModuleName -newtype Name = Name { unName :: String }-  deriving (Eq, Show)--instance Codeable Name where-  code = code . unName--data QName-  = Qual ModuleName Name-  | UnQual Name-  deriving (Eq, Show)+-- | Create a simple named basic import, to be updated with other fields+--   as needed.+namedImport :: String -> ImportDecl+namedImport name = ImportDecl+  { importLoc       = noLoc+  , importQualified = False+  , importModule    = ModuleName name+  , importSrc       = False+  , importPkg       = Nothing+  , importAs        = Nothing+  , importSpecs     = Nothing+  } -instance Codeable QName where-  code (UnQual n) = code n-  code (Qual m n) = code m <+> "." <+> code n+-- | Qualified import with given name+qualImport :: String -> ImportDecl+qualImport name = (namedImport name) { importQualified = True } -data Qualification = Qualified | UnQualified-  deriving (Eq, Show)+haskellStringType :: Type+haskellStringType = haskellSimpleType "String" -instance Codeable Qualification where-  code Qualified   = code "qualified"-  code UnQualified = code ""+haskellByteStringType :: Type+haskellByteStringType = haskellSimpleType "ByteString" -data Import-  = Import Qualification ModuleName (Maybe ModuleName) (Maybe [QName])-  deriving (Eq, Show)+haskellSimpleType :: String -> Type+haskellSimpleType = TyCon . UnQual . Ident -instance Codeable Import where-  code i = case i of-    Import q m mas ids-      -> "import"-      <++> q-      <++> m-      <++> qualAs-      <++> maybe (code "") (\v -> "(" <+> impList v <+> ")") ids-      where-        qualAs = case mas of-          Just as-            | as == m   -> code ""-            | otherwise -> "as" <++> as-          Nothing       -> code ""-        impList :: [QName] -> Code-        impList = foldl' (<++>) (code "") . intersperse (code ",") . map code+haskellUnitType :: Type+haskellUnitType = TyCon (Special UnitCon)