diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/rest-gen.cabal b/rest-gen.cabal --- a/rest-gen.cabal +++ b/rest-gen.cabal @@ -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.* diff --git a/src/Rest/Gen.hs b/src/Rest/Gen.hs --- a/src/Rest/Gen.hs +++ b/src/Rest/Gen.hs @@ -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 = diff --git a/src/Rest/Gen/Base/ActionInfo.hs b/src/Rest/Gen/Base/ActionInfo.hs --- a/src/Rest/Gen/Base/ActionInfo.hs +++ b/src/Rest/Gen/Base/ActionInfo.hs @@ -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 diff --git a/src/Rest/Gen/Base/ActionInfo/Ident.hs b/src/Rest/Gen/Base/ActionInfo/Ident.hs --- a/src/Rest/Gen/Base/ActionInfo/Ident.hs +++ b/src/Rest/Gen/Base/ActionInfo/Ident.hs @@ -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) diff --git a/src/Rest/Gen/Base/JSON.hs b/src/Rest/Gen/Base/JSON.hs --- a/src/Rest/Gen/Base/JSON.hs +++ b/src/Rest/Gen/Base/JSON.hs @@ -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 ["" .= 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 "" + 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 ["" .= 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 "" + 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)) diff --git a/src/Rest/Gen/Config.hs b/src/Rest/Gen/Config.hs --- a/src/Rest/Gen/Config.hs +++ b/src/Rest/Gen/Config.hs @@ -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 diff --git a/src/Rest/Gen/Docs.hs b/src/Rest/Gen/Docs.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Gen/Docs.hs @@ -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) diff --git a/src/Rest/Gen/Docs/Generate.hs b/src/Rest/Gen/Docs/Generate.hs deleted file mode 100644 --- a/src/Rest/Gen/Docs/Generate.hs +++ /dev/null @@ -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) diff --git a/src/Rest/Gen/Docs/Happstack.hs b/src/Rest/Gen/Docs/Happstack.hs deleted file mode 100644 --- a/src/Rest/Gen/Docs/Happstack.hs +++ /dev/null @@ -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 diff --git a/src/Rest/Gen/Haskell.hs b/src/Rest/Gen/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Gen/Haskell.hs @@ -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" diff --git a/src/Rest/Gen/Haskell/Generate.hs b/src/Rest/Gen/Haskell/Generate.hs deleted file mode 100644 --- a/src/Rest/Gen/Haskell/Generate.hs +++ /dev/null @@ -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") diff --git a/src/Rest/Gen/JavaScript.hs b/src/Rest/Gen/JavaScript.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Gen/JavaScript.hs @@ -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) diff --git a/src/Rest/Gen/JavaScript/Generate.hs b/src/Rest/Gen/JavaScript/Generate.hs deleted file mode 100644 --- a/src/Rest/Gen/JavaScript/Generate.hs +++ /dev/null @@ -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) diff --git a/src/Rest/Gen/Ruby.hs b/src/Rest/Gen/Ruby.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Gen/Ruby.hs @@ -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) diff --git a/src/Rest/Gen/Ruby/Generate.hs b/src/Rest/Gen/Ruby/Generate.hs deleted file mode 100644 --- a/src/Rest/Gen/Ruby/Generate.hs +++ /dev/null @@ -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) diff --git a/src/Rest/Gen/Types.hs b/src/Rest/Gen/Types.hs --- a/src/Rest/Gen/Types.hs +++ b/src/Rest/Gen/Types.hs @@ -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)