rest-gen 0.19.0.3 → 0.20.0.3
raw patch · 17 files changed
Files
- CHANGELOG.md +11/−0
- rest-gen.cabal +13/−12
- src/Rest/Gen.hs +3/−2
- src/Rest/Gen/Base.hs +5/−10
- src/Rest/Gen/Base/ActionInfo.hs +19/−17
- src/Rest/Gen/Base/ActionInfo/Ident.hs +3/−3
- src/Rest/Gen/Base/JSON.hs +3/−2
- src/Rest/Gen/Base/JSON/Pretty.hs +5/−1
- src/Rest/Gen/Base/Link.hs +6/−6
- src/Rest/Gen/Base/XML.hs +3/−3
- src/Rest/Gen/Docs.hs +15/−14
- src/Rest/Gen/Haskell.hs +263/−166
- src/Rest/Gen/JavaScript.hs +12/−13
- src/Rest/Gen/NoAnnotation.hs +42/−0
- src/Rest/Gen/Ruby.hs +9/−9
- src/Rest/Gen/Types.hs +18/−18
- tests/Runner.hs +6/−4
CHANGELOG.md view
@@ -1,5 +1,16 @@ # Changelog +## 0.20.0.0++* Upgrade to `haskell-src-exts 1.18.*`++#### 0.19.0.4++* Fix encoding issue with String inputs in generated clients.+ Non-ASCII characters would be mangled. Regenerate your client code+ to fix this. Newly generated code with String inputs needs to depend+ on rest-client >= 0.5.2, or it will fail to build.+ #### 0.19.0.3 * Allow rest-core-0.39.
rest-gen.cabal view
@@ -1,5 +1,5 @@ name: rest-gen-version: 0.19.0.3+version: 0.20.0.3 description: Documentation and client generation from rest definition. synopsis: Documentation and client generation from rest definition. maintainer: code@silk.co@@ -46,24 +46,25 @@ Rest.Gen.Base.JSON.Pretty Rest.Gen.Base.Link Rest.Gen.Base.XML+ Rest.Gen.NoAnnotation Rest.Gen.Utils build-depends:- base >= 4.5 && < 4.10- , Cabal >= 1.16 && < 1.26+ base >= 4.5 && < 4.12+ , Cabal >= 1.16 && < 2.2 , HStringTemplate >= 0.6 && < 0.9- , aeson >= 0.7 && < 0.12+ , aeson >= 0.7 && < 1.4 , base-compat >= 0.8 && < 0.10- , blaze-html >= 0.5 && < 0.9+ , blaze-html >= 0.5 && < 0.10 , code-builder == 0.1.*- , directory >= 1.1 && < 1.3+ , directory >= 1.1 && < 1.4 , fclabels >= 1.0.4 && < 2.1 , filepath >= 1.2 && < 1.5 , hashable >= 1.1 && < 1.3- , haskell-src-exts >= 1.15.0 && < 1.18+ , haskell-src-exts >= 1.20 && < 1.21 , hxt >= 9.2 && < 9.4 , json-schema >= 0.6 && < 0.8 , pretty >= 1.0 && < 1.2- , process >= 1.0 && < 1.5+ , process >= 1.0 && < 1.7 , rest-core >= 0.38 && < 0.40 , safe >= 0.2 && < 0.4 , semigroups >= 0.5 && < 0.19@@ -72,7 +73,7 @@ , text >= 0.11 && < 1.3 , uniplate >= 1.6.12 && < 1.7 , unordered-containers == 0.2.*- , vector >= 0.10 && < 0.12+ , vector >= 0.10 && < 0.13 if impl(ghc < 7.8) build-depends: tagged >= 0.2 && < 0.9 @@ -82,10 +83,10 @@ type: exitcode-stdio-1.0 ghc-options: -Wall build-depends:- base >= 4.5 && < 4.10- , HUnit >= 1.2 && < 1.4+ base >= 4.5 && < 4.12+ , HUnit >= 1.2 && < 1.7 , fclabels >= 1.0.4 && < 2.1- , haskell-src-exts >= 1.15.0 && < 1.18+ , haskell-src-exts >= 1.15.0 && < 1.21 , rest-core >= 0.38 && < 0.40 , rest-gen , test-framework == 0.8.*
src/Rest/Gen.hs view
@@ -20,8 +20,9 @@ import Rest.Gen.Ruby (mkRbApi) import Rest.Gen.Types import Rest.Gen.Utils+import qualified Rest.Gen.NoAnnotation as N -generate :: Config -> String -> Api m -> [H.ModuleName] -> [H.ImportDecl] -> [(H.ModuleName, H.ModuleName)] -> IO ()+generate :: Config -> String -> Api m -> [N.ModuleName] -> [N.ImportDecl] -> [(N.ModuleName, N.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@@ -42,7 +43,7 @@ Nothing -> return () where packageName = map toLower name- moduleName = H.ModuleName $ upFirst packageName+ moduleName = H.ModuleName () $ upFirst packageName getTargetDir :: Config -> String -> IO String getTargetDir config str =
src/Rest/Gen/Base.hs view
@@ -1,11 +1,6 @@-module Rest.Gen.Base- ( module Rest.Gen.Base.ActionInfo- , module Rest.Gen.Base.ActionInfo.Ident- , module Rest.Gen.Base.ApiTree- , module Rest.Gen.Base.Link- ) where+module Rest.Gen.Base (module X) where -import Rest.Gen.Base.ActionInfo-import Rest.Gen.Base.ActionInfo.Ident (Ident (Ident, description))-import Rest.Gen.Base.ApiTree-import Rest.Gen.Base.Link+import Rest.Gen.Base.ActionInfo as X+import Rest.Gen.Base.ActionInfo.Ident as X (Ident (Ident, description))+import Rest.Gen.Base.ApiTree as X+import Rest.Gen.Base.Link as X
src/Rest/Gen/Base/ActionInfo.hs view
@@ -1,10 +1,14 @@ {-# LANGUAGE- GADTs+ CPP+ , GADTs , LambdaCase , NoImplicitPrelude , ScopedTypeVariables , TemplateHaskell #-}+#if MIN_VERSION_base(4,9,0)+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif module Rest.Gen.Base.ActionInfo ( Accessor , ActionInfo (..)@@ -79,6 +83,7 @@ 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+import qualified Rest.Gen.NoAnnotation as N -------------------- -- * The types describing a resource's actions.@@ -99,8 +104,8 @@ -- | Core information about the type of the input/output data DataDesc = DataDesc { _dataType :: DataType- , _haskellType :: H.Type- , _haskellModules :: [H.ModuleName]+ , _haskellType :: N.Type+ , _haskellModules :: [N.ModuleName] } deriving (Show, Eq) mkLabel ''DataDesc@@ -140,7 +145,7 @@ isAccessor :: ActionInfo -> Bool isAccessor ai = actionType ai == Retrieve && actionTarget ai == Self -defaultDescription :: DataType -> String -> H.Type -> DataDescription+defaultDescription :: DataType -> String -> N.Type -> DataDescription defaultDescription typ typeDesc htype = DataDescription { _desc = DataDesc@@ -178,9 +183,7 @@ dataTypesToAcceptHeader def = \case [] -> dataTypeToAcceptHeader def xs -> intercalate "," . map dataTypeToAcceptHeader . (xs ++) $- if null (intersect xs [XML,JSON])- then [def]- else []+ [def | null (xs `intersect` [XML, JSON])] dataTypeToAcceptHeader :: DataType -> String dataTypeToAcceptHeader = \case@@ -218,7 +221,7 @@ intersection :: NonEmpty DataDescription -> NonEmpty DataDescription -> ResponseType intersection o e = -- Try to find a response type that can be used for both output and error.- case intersect (f o) (f e) of+ case f o `intersect` f e of -- If the response types are disjoint we need to specify both. [] -> ResponseType@@ -237,7 +240,7 @@ -- Prioritize formats . sortBy (comparing cmp) -- Pick only the data types in the intersection of outputs and errors- . filter ((`elem` dts) . (L.get (dataType . desc)))+ . filter ((`elem` dts) . L.get (dataType . desc)) . NList.toList -- When we have an intersection with multiple possible -- types, we prefer JSON over XML, and XML over the rest.@@ -345,7 +348,7 @@ <$> mkMultiHandler id_ (const id) h removeActionInfo :: Link -> Handler m -> ActionInfo-removeActionInfo lnk = handlerActionInfo Nothing True Delete Self "" DELETE lnk+removeActionInfo = handlerActionInfo Nothing True Delete Self "" DELETE multiRemoveActionInfo :: Monad m => Id sid -> String -> Handler m -> Maybe ActionInfo multiRemoveActionInfo id_ pth h = handlerActionInfo Nothing False DeleteMany Any pth DELETE []@@ -395,9 +398,7 @@ makeLink | postAct = ac ++ dirPart ++ identPart | otherwise = dirPart ++ identPart- where dirPart = if pth /= ""- then [LAction pth]- else []+ where dirPart = [LAction pth | pth /= ""] identPart = maybe [] ((:[]) . LParam . Ident.description) id_ @@ -464,6 +465,7 @@ -- so we stick with the convention of preferring JSON. RawJsonAndXmlO -> defaultDescription File "File" haskellStringType FileO -> defaultDescription File "File" haskellByteStringType+ -- TODO: MultiPartO -- | Extract input description from handlers handlerErrors :: Handler m -> [DataDescription]@@ -491,16 +493,16 @@ (tyConName tyCon) (concatMap (\t -> " (" ++ typeString' t ++ ")") subs) -modString :: forall a. Typeable a => Proxy a -> [H.ModuleName]-modString _ = map H.ModuleName . filter (\v -> v /= "" && take 4 v /= "GHC.") . modString' . typeOf $ (undefined :: a)+modString :: forall a. Typeable a => Proxy a -> [N.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 :: forall a. Typeable a => Proxy a -> N.Type toHaskellType ty = case H.parseType (typeString ty) of- H.ParseOk parsedType -> parsedType+ H.ParseOk parsedType -> void parsedType H.ParseFailed _loc msg -> error msg idIdent :: Id id -> Ident
src/Rest/Gen/Base/ActionInfo/Ident.hs view
@@ -1,9 +1,9 @@ module Rest.Gen.Base.ActionInfo.Ident (Ident (..)) where -import qualified Language.Haskell.Exts.Syntax as H+import qualified Rest.Gen.NoAnnotation as N data Ident = Ident { description :: String- , haskellType :: H.Type- , haskellModules :: [H.ModuleName]+ , haskellType :: N.Type+ , haskellModules :: [N.ModuleName] } deriving (Show, Eq)
src/Rest/Gen/Base/JSON.hs view
@@ -7,6 +7,7 @@ , showExamples ) where +import Control.Applicative ((<|>)) import Data.Aeson ((.=)) import Data.JSON.Schema import Data.List (transpose)@@ -104,7 +105,7 @@ boundExample :: Num a => Bound -> a-boundExample b = fromIntegral $ fromMaybe 0 (maybe (lower b) Just (upper b))+boundExample b = fromIntegral . fromMaybe 0 $ upper b <|> lower b lengthBoundExample :: Num a => LengthBound -> a-lengthBoundExample b = fromIntegral $ fromMaybe 0 (maybe (lowerLength b) Just (upperLength b))+lengthBoundExample b = fromIntegral $ fromMaybe 0 (upperLength b <|> lowerLength b)
src/Rest/Gen/Base/JSON/Pretty.hs view
@@ -1,5 +1,7 @@ module Rest.Gen.Base.JSON.Pretty (pp_value) where +import Prelude hiding ((<>))+ import Control.Arrow (first) import Data.Aeson.Types import Data.Char@@ -11,6 +13,8 @@ import qualified Data.HashMap.Strict as H import qualified Data.Vector as V +{-# ANN module "Hlint: ignore Use camelCase" #-}+ pp_value :: Value -> Doc pp_value v = case v of Null -> pp_null@@ -55,7 +59,7 @@ where pp_field (k,v) = pp_string k <> colon <+> pp_value v pp_js_string :: String -> Doc-pp_js_string x = pp_string x+pp_js_string = pp_string pp_js_object :: HashMap Text Value -> Doc pp_js_object = pp_object . map (first unpack) . H.toList
src/Rest/Gen/Base/Link.hs view
@@ -69,16 +69,16 @@ getLinkIds :: Link -> [(String, [(String, String)])] getLinkIds l = case l of- [] -> []- (q: (LParam p) : rs) -> (itemString q, [(itemString q, p)]) : getLinkIds rs- (q: (LAccess ls) : rs) -> (itemString q, concatMap snd $ concatMap (getLinkIds . (q : )) ls) : getLinkIds rs- (_: rs) -> getLinkIds rs+ [] -> []+ (q: LParam p : rs) -> (itemString q, [(itemString q, p)]) : getLinkIds rs+ (q: LAccess ls : rs) -> (itemString q, concatMap snd $ concatMap (getLinkIds . (q : )) ls) : getLinkIds rs+ (_: rs) -> getLinkIds rs setLinkIds :: Link -> [String] -> String setLinkIds _ [] = error "Error in setLinkIds, not enough parameters" setLinkIds l (p : ps) = case l of [] -> ""- (_: (LParam _) : rs) -> "/" ++ p ++ setLinkIds rs ps- (_: (LAccess _) : rs) -> "/" ++ p ++ setLinkIds rs ps+ (_: LParam _ : rs) -> "/" ++ p ++ setLinkIds rs ps+ (_: LAccess _ : rs) -> "/" ++ p ++ setLinkIds rs ps (s: rs) -> "/" ++ itemString s ++ setLinkIds rs (p: ps)
src/Rest/Gen/Base/XML.hs view
@@ -41,9 +41,9 @@ ++ indent (concatMap (showSchema' "") ss) ++ ["</xs:choice>"] - showSchema' ats (Rep l u s) = showSchema' (ats ++ concatMap (' ':) (mn ++ mx)) s- where mn = if l >= 0 then ["minOccurs=" ++ show l] else []- mx = if u >= 0 then ["maxOccurs=" ++ show u] else []+ showSchema' ats (Rep _ u s) = showSchema' (unwords $ ats : mn ++ mx) s+ where mn = ["minOccurs=" ++ show u | u >= 0]+ mx = ["maxOccurs=" ++ show u | u >= 0] showSchema' ats (Element n (CharData dty)) = ["<xs:element name='" ++ n ++ "' type='" ++ dataToString dty ++ "'" ++ ats ++ "/>"] showSchema' ats (Element n (Seq [])) = ["<xs:element name='" ++ n ++ "'" ++ ats ++ "/>"]
src/Rest/Gen/Docs.hs view
@@ -11,7 +11,7 @@ , writeDocs ) where -import Prelude hiding (div, head, id, id, span, (.))+import Prelude hiding (div, head, span, (.)) import qualified Prelude as P import Control.Category ((.))@@ -24,10 +24,11 @@ import System.FilePath import Text.Blaze.Html import Text.Blaze.Html5 hiding (map, meta, style)-import Text.Blaze.Html5.Attributes hiding (method, span, title)+import Text.Blaze.Html5.Attributes hiding (id, method, span, title) import Text.Blaze.Html.Renderer.String import Text.StringTemplate-import qualified Data.Label.Total as L+import qualified Data.Label.Total as L+import qualified Text.Blaze.Html5.Attributes as A import Rest.Api (Router, Version) import Rest.Gen.Base@@ -101,10 +102,10 @@ -- | Recursively generate information for a resource structure resourcesInfo :: DocsContext -> ApiResource -> Html-resourcesInfo ctx = foldTree $ (\it -> sequence_ . (resourceInfo ctx it :) )+resourcesInfo ctx = foldTree $ \it -> sequence_ . (resourceInfo ctx it :) subResourcesInfo :: DocsContext -> ApiResource -> Html-subResourcesInfo ctx = foldTreeChildren sequence_ $ (\it -> sequence_ . (resourceInfo ctx it :) )+subResourcesInfo ctx = foldTreeChildren sequence_ $ \it -> sequence_ . (resourceInfo ctx it :) -- | Generate information for one resource resourceInfo :: DocsContext -> ApiResource -> Html@@ -125,16 +126,16 @@ resourceIdentifiers lnk lnks = case lnks of [] -> [toHtml "No identifiers"]- ls -> map (linkHtml . (lnk ++)) $ ls+ 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+ tbody $ forM_ (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@@ -142,8 +143,8 @@ , 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 $+ forM_ (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@@ -172,13 +173,13 @@ 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) $+ in do div ! cls "modal hide fade code" ! A.id (toValue eid) $ do cdiv "modal-header" $ do a ! href (toValue "#") ! cls "close" $ toHtml "x" h3 $ toHtml cap cdiv "modal-body" $ div ! style (toValue "overflow:auto; max-height:600px") $- pre ! cls ("prettyprint lang-" ++ lng) $ toHtml $ cd+ 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")@@ -204,5 +205,5 @@ 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+ $ map linkHtml $ sortBy (flip compare `on` length) lnks linkItem x = toHtml ("/" ++ itemString x)
src/Rest/Gen/Haskell.hs view
@@ -42,6 +42,7 @@ import Rest.Gen.Base import Rest.Gen.Types import Rest.Gen.Utils+import qualified Rest.Gen.NoAnnotation as N import qualified Rest.Gen.Base.ActionInfo.Ident as Ident mkLabelsNamed ("_" ++) [''Cabal.GenericPackageDescription, ''Cabal.CondTree, ''Cabal.Library]@@ -52,9 +53,9 @@ , targetPath :: String , wrapperName :: String , includePrivate :: Bool- , sources :: [H.ModuleName]- , imports :: [H.ImportDecl]- , rewrites :: [(H.ModuleName, H.ModuleName)]+ , sources :: [N.ModuleName]+ , imports :: [N.ImportDecl]+ , rewrites :: [(N.ModuleName, N.ModuleName)] , namespace :: [String] } @@ -85,32 +86,58 @@ 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)) [] [] []+mkGenericPackageDescription name modules =+#if MIN_VERSION_Cabal(2,0,0)+ Cabal.GenericPackageDescription pkg [] (Just (mkCondLibrary modules)) [] [] [] [] []+#else+ Cabal.GenericPackageDescription pkg [] (Just (mkCondLibrary modules)) [] [] []+#endif where pkg = Cabal.emptyPackageDescription- { Cabal.package = Cabal.PackageIdentifier (Cabal.PackageName name) (Cabal.Version [0, 1] [])+ { Cabal.package = Cabal.PackageIdentifier (cabalPackageName name) (cabalVersion [0, 1]) , Cabal.buildType = Just Cabal.Simple- , Cabal.specVersionRaw = Right (Cabal.orLaterVersion (Cabal.Version [1, 8] []))+ , Cabal.specVersionRaw = Right (Cabal.orLaterVersion (cabalVersion [1, 8])) } mkCondLibrary :: [Cabal.ModuleName] -> Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.Library mkCondLibrary modules = Cabal.CondNode { Cabal.condTreeData = cabalLibrary modules , 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.Dependency (cabalPackageName "base") (Cabal.withinVersion $ cabalVersion [4] )+ , Cabal.Dependency (cabalPackageName "rest-types") (Cabal.withinVersion $ cabalVersion [1, 10] )+ , Cabal.Dependency (cabalPackageName "rest-client") (Cabal.withinVersion $ cabalVersion [0, 5, 2]) ] , Cabal.condTreeComponents = [] } cabalLibrary :: [Cabal.ModuleName] -> Cabal.Library+#if MIN_VERSION_Cabal(2,0,0)+cabalLibrary mods = Cabal.emptyLibrary+ { Cabal.exposedModules = mods+ , Cabal.libBuildInfo = (Cabal.libBuildInfo Cabal.emptyLibrary) { Cabal.hsSourceDirs = ["src"] }+ }+#else #if MIN_VERSION_Cabal(1,22,0) cabalLibrary mods = Cabal.Library mods [] [] [] True Cabal.emptyBuildInfo { Cabal.hsSourceDirs = ["src"] } #else cabalLibrary mods = Cabal.Library mods True Cabal.emptyBuildInfo { Cabal.hsSourceDirs = ["src"] } #endif+#endif +cabalVersion :: [Int] -> Cabal.Version+#if MIN_VERSION_Cabal(2,0,0)+cabalVersion = Cabal.mkVersion+#else+cabalVersion v = Cabal.Version v []+#endif++cabalPackageName :: String -> Cabal.PackageName+#if MIN_VERSION_Cabal(2,0,0)+cabalPackageName = Cabal.mkPackageName+#else+cabalPackageName = Cabal.PackageName+#endif+ writeRes :: HaskellContext -> ApiResource -> IO () writeRes ctx node = do createDirectoryIfMissing True (targetPath ctx </> "src" </> modPath (namespace ctx ++ resParents node))@@ -119,228 +146,296 @@ 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"]+ pragmas :: [N.ModulePragma]+ pragmas = [ H.LanguagePragma () [H.Ident () "OverloadedStrings"]+ , H.OptionsPragma () (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+ [N.ModulePragma] -> Maybe N.WarningText ->+ N.Module buildHaskellModule ctx node pragmas warningText = rewriteModuleNames (rewrites ctx) $- H.Module noLoc name pragmas warningText exportSpecs importDecls decls+ H.Module () (Just $ H.ModuleHead () name warningText exportSpecs) pragmas importDecls decls where- name = H.ModuleName $ qualModName $ namespace ctx ++ resId node+ name :: N.ModuleName+ name = H.ModuleName () $ qualModName $ namespace ctx ++ resId node+ exportSpecs :: Maybe N.ExportSpecList exportSpecs = Nothing+ importDecls :: [N.ImportDecl] importDecls = nub $ namedImport "Rest.Client.Internal" : extraImports ++ parentImports ++ dataImports ++ idImports+ decls :: [N.Decl] decls = idData node ++ concat funcs + extraImports :: [N.ImportDecl] extraImports = imports ctx+ parentImports :: [N.ImportDecl] parentImports = map mkImport . tail . inits . resParents $ node+ dataImports :: [N.ImportDecl] dataImports = map (qualImport . unModuleName) datImp+ idImports :: [N.ImportDecl] idImports = concat . mapMaybe (return . map (qualImport . unModuleName) . Ident.haskellModules <=< snd) . resAccessors $ node + funcs :: [[N.Decl]]+ datImp :: [N.ModuleName] (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+ mkImport :: [String] -> N.ImportDecl+ mkImport p = (namedImport importName)+ { H.importQualified = True+ , H.importAs = importAs'+ }+ where+ importName :: String+ importName = qualModName $ namespace ctx ++ p+ importAs' :: Maybe N.ModuleName+ importAs' = fmap (H.ModuleName () . modName) . lastMay $ p -rewriteModuleNames :: [(H.ModuleName, H.ModuleName)] -> H.Module -> H.Module+rewriteModuleNames :: [(N.ModuleName, N.ModuleName)] -> N.Module -> N.Module rewriteModuleNames rews = U.transformBi $ \m -> lookupJustDef m m rews -#if MIN_VERSION_haskell_src_exts(1,17,0)-noBinds :: Maybe H.Binds+noBinds :: Maybe N.Binds noBinds = Nothing-#else-noBinds :: H.Binds-noBinds = H.BDecls []-#endif -use :: H.Name -> H.Exp-use = H.Var . H.UnQual+use :: N.Name -> N.Exp+use = H.Var () . H.UnQual () -useMQual :: (Maybe H.ModuleName) -> H.Name -> H.Exp+useMQual :: Maybe N.ModuleName -> N.Name -> N.Exp useMQual Nothing = use-useMQual (Just qual) = H.Var . (H.Qual $ qual)+useMQual (Just qual) = H.Var () . H.Qual () qual -mkFunction :: Version -> String -> ApiAction -> ([H.Decl], [H.ModuleName])+mkFunction :: Version -> String -> ApiAction -> ([N.Decl], [N.ModuleName]) mkFunction ver res (ApiAction _ lnk ai) =- ([H.TypeSig noLoc [funName] fType,- H.FunBind [H.Match noLoc funName fParams Nothing rhs noBinds]],+ ([H.TypeSig () [funName] fType,+ H.FunBind () [H.Match () funName fParams rhs noBinds]], responseModules errorI ++ responseModules output ++ maybe [] inputModules mInp) where+ funName :: N.Name funName = mkHsName ai- fParams = map H.PVar $ lPars+ fParams :: [N.Pat]+ fParams = map (H.PVar ()) $ lPars ++ maybe [] ((:[]) . hsName . cleanName . description) (ident ai) ++ maybe [] (const [input]) mInp ++ (if null (params ai) then [] else [pList])+ lUrl :: N.Exp+ lPars :: [N.Name] (lUrl, lPars) = linkToURL res lnk mInp :: Maybe InputInfo- mInp = fmap (inputInfo . L.get desc . chooseType) . NList.nonEmpty . 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"))- (responseHaskellType errorI))- (responseHaskellType output))]- qualIdent (H.Ident s)- | s == cleanHsName 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- , i' <- inputHaskellType 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)-#if !MIN_VERSION_haskell_src_exts(1,16,0)- Nothing-#endif- (H.UnGuardedRhs $ H.List [H.Tuple H.Boxed [use hAccept , H.Lit $ H.String $ dataTypesToAcceptHeader JSON $ responseAcceptType responseType],- H.Tuple H.Boxed [use hContentType, H.Lit $ H.String $ maybe "text/plain" inputContentType mInp]])- noBinds+ mInp = fmap (inputInfo . L.get desc . chooseType) . NList.nonEmpty . inputs $ ai+ fType :: N.Type+ fType = H.TyForall () Nothing (Just ctx) $ fTypify tyParts+ where+ ctx :: N.Context+ ctx = H.CxSingle () $ H.ClassA () (H.UnQual () cls) [m]+ cls :: N.Name+ cls = H.Ident () "ApiStateC"+ m :: N.Type+ m = H.TyVar () $ H.Ident () "m"+ fTypify :: [N.Type] -> N.Type+ fTypify = \case+ [] -> error "Rest.Gen.Haskell.mkFunction.fTypify - expects at least one type"+ [ty1] -> ty1+ [ty1, ty2] -> H.TyFun () ty1 ty2+ (ty1 : tys) -> H.TyFun () ty1 (fTypify tys)+ tyParts :: [N.Type]+ 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"))+ (responseHaskellType errorI))+ (responseHaskellType output))]+ qualIdent :: N.Name -> N.Type+ qualIdent = \case+ (H.Ident _ s)+ | s == cleanHsName res -> H.TyCon () $ H.UnQual () tyIdent+ | otherwise -> H.TyCon () $ H.Qual () (H.ModuleName () $ modName s) tyIdent+ H.Symbol{} -> error "Rest.Gen.Haskell.mkFunction.qualIdent - not expecting a Symbol"+ inp :: [N.Type]+ inp | Just i <- mInp+ , i' <- inputHaskellType i = [i']+ | otherwise = []+ input :: N.Name+ input = H.Ident () "input"+ pList :: N.Name+ pList = H.Ident () "pList"+ rhs :: N.Rhs+ rhs = H.UnGuardedRhs () $ H.Let () binds expr+ where+ binds :: N.Binds+ binds = H.BDecls () [rHeadersBind, requestBind]+ rHeadersBind :: N.Decl+ rHeadersBind =+ H.PatBind () (H.PVar () rHeaders)+ (H.UnGuardedRhs () $+ H.List ()+ [ H.Tuple () H.Boxed+ [ use hAccept+ , stringLit $ dataTypesToAcceptHeader JSON $ responseAcceptType responseType+ ]+ , H.Tuple () H.Boxed+ [ use hContentType+ , stringLit $ maybe "text/plain" inputContentType mInp+ ]])+ noBinds - rHeaders = H.Ident "rHeaders"- hAccept = H.Ident "hAccept"- hContentType = H.Ident "hContentType"- doRequest = H.Ident "doRequest"+ rHeaders :: N.Name+ rHeaders = H.Ident () "rHeaders"+ hAccept :: N.Name+ hAccept = H.Ident () "hAccept"+ hContentType :: N.Name+ hContentType = H.Ident () "hContentType"+ doRequest :: N.Name+ doRequest = H.Ident () "doRequest" - requestBind =- H.PatBind noLoc (H.PVar request)-#if !MIN_VERSION_haskell_src_exts(1,16,0)- Nothing-#endif- (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 $ inputFunc i) (use input))- | otherwise = H.App e (H.Lit $ H.String "")- makeReq = H.Ident "makeReq"- request = H.Ident "request"+ requestBind :: N.Decl+ requestBind =+ H.PatBind () (H.PVar () request)+ (H.UnGuardedRhs () $+ appLast+ (H.App ()+ (H.App ()+ (H.App ()+ (H.App () (H.App () (use makeReq) (stringLit str)) (stringLit ve))+ url)+ (if null (params ai) then H.List () [] else use pList))+ (use rHeaders))) noBinds+ where+ str = show $ method ai+ appLast :: N.Exp -> N.Exp+ appLast e+ | Just i <- mInp = H.App () e (H.App () (use $ H.Ident () $ inputFunc i) (use input))+ | otherwise = H.App () e (stringLit "")+ makeReq :: N.Name+ makeReq = H.Ident () "makeReq"+ request :: N.Name+ request = H.Ident () "request" - expr = H.App (H.App (H.App (use doRequest)- (use $ H.Ident $ responseFunc errorI))- (use $ H.Ident $ responseFunc output)) (use request)+ expr :: N.Exp+ expr = H.App () (H.App () (H.App () (use doRequest)+ (use . H.Ident () $ responseFunc errorI))+ (use . H.Ident () $ responseFunc output))+ (use request) + ve :: String+ url :: N.Exp (ve, url) = ("v" ++ show ver, lUrl) errorI :: ResponseInfo errorI = errorInfo responseType output :: ResponseInfo output = outputInfo responseType+ responseType :: ResponseType responseType = chooseResponseType ai -linkToURL :: String -> Link -> (H.Exp, [H.Name])-linkToURL res lnk = first H.List $ urlParts res lnk ([], [])+linkToURL :: String -> Link -> (N.Exp, [N.Name])+linkToURL res lnk = first (H.List ()) $ urlParts res lnk ([], []) -urlParts :: String -> Link -> ([H.Exp], [H.Name]) -> ([H.Exp], [H.Name])+urlParts :: String -> Link -> ([N.Exp], [N.Name]) -> ([N.Exp], [N.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 . cleanHsName $ 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")+ | not (hasParam a) -> urlParts res xs (rlnk ++ [H.List () [stringLit r]], pars)+ | otherwise -> urlParts res xs (rlnk', pars ++ [H.Ident () . cleanHsName $ r])+ where+ rlnk' = rlnk ++ (H.List () [stringLit r] : tailed)+ tailed = [H.App () (useMQual qual $ H.Ident () "readId")+ (use . hsName $ cleanName r)]+ where+ qual :: Maybe N.ModuleName+ 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)+ (i : xs) -> urlParts res xs (rlnk ++ [H.List () [stringLit $ itemString i]], pars) -idData :: ApiResource -> [H.Decl]+idData :: ApiResource -> [N.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] ]+ | otherwise = stringLit pth : xs+ in [ H.TypeDecl () (H.DHead () tyIdent) (Ident.haskellType i),+ H.TypeSig () [funName] fType,+ H.FunBind () [ H.Match () funName [H.PVar () x]+ (H.UnGuardedRhs () $ H.List () $ pp [showURLx])+ noBinds+ ]+ ] ls ->- let ctor (pth,mi) =- H.QualConDecl noLoc [] [] (H.ConDecl (H.Ident (dataName pth)) $ maybe [] f mi)-#if MIN_VERSION_haskell_src_exts(1,16,0)- where f ty = [Ident.haskellType ty]-#else- where f ty = [H.UnBangedTy $ Ident.haskellType ty]-#endif- 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+ let ctor :: (String, Maybe Ident) -> N.QualConDecl+ ctor (pth,mi) =+ H.QualConDecl () Nothing Nothing (H.ConDecl () (H.Ident () (dataName pth)) $ maybe [] f mi)+ where+ f ty = [Ident.haskellType ty]+ fun :: (String, Maybe Ident) -> [N.Decl]+ fun (pth, mi) = [H.FunBind () [H.Match () funName fparams rhs noBinds]]+ where+ (fparams, rhs) =+ case mi of+ Nothing ->+ ( [H.PVar () . H.Ident () $ dataName pth]+ , H.UnGuardedRhs () $ H.List () [stringLit pth]+ )+ Just{} -> -- Pattern match with data constructor+ ([H.PParen () $ H.PApp () (H.UnQual () $ H.Ident () (dataName pth)) [H.PVar () x]],+ H.UnGuardedRhs () $ H.List () [stringLit pth, showURLx])+ in [ H.DataDecl () (H.DataType ()) Nothing (H.DHead () tyIdent) (map ctor ls) []+ , H.TypeSig () [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)+ x :: N.Name+ x = H.Ident () "x"+ fType :: N.Type+ fType = H.TyFun () (H.TyCon () $ H.UnQual () tyIdent) (H.TyList () haskellStringType)+ funName :: N.Name+ funName = H.Ident () "readId"+ showURLx :: N.Exp+ showURLx = H.App () (H.Var () $ H.UnQual () $ H.Ident () "showUrl") (H.Var () $ H.UnQual () x) -tyIdent :: H.Name-tyIdent = H.Ident "Identifier"+tyIdent :: N.Name+tyIdent = H.Ident () "Identifier" -mkHsName :: ActionInfo -> H.Name+mkHsName :: ActionInfo -> N.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]+ Retrieve -> case nm of+ [] -> ["access"]+ _ -> nm+ where+ nm = get ++ by ++ target+ 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"]+ by = ["by" | target /= [] && (isJust (ident ai) || actionType ai == UpdateMany)]+ get = ["get" | not (isAccessor ai)] -hsName :: [String] -> H.Name-hsName [] = H.Ident ""-hsName (x : xs) = H.Ident $ cleanHsName $ downFirst x ++ concatMap upFirst xs+hsName :: [String] -> N.Name+hsName [] = H.Ident () ""+hsName (x : xs) = H.Ident () $ cleanHsName $ downFirst x ++ concatMap upFirst xs cleanHsName :: String -> String cleanHsName s =@@ -366,8 +461,8 @@ modName = concatMap upFirst . cleanName data InputInfo = InputInfo- { inputModules :: [H.ModuleName]- , inputHaskellType :: H.Type+ { inputModules :: [N.ModuleName]+ , inputHaskellType :: N.Type , inputContentType :: String , inputFunc :: String } deriving (Eq, Show)@@ -375,16 +470,15 @@ inputInfo :: DataDesc -> InputInfo inputInfo dsc = case L.get dataType dsc of- String -> InputInfo [] (haskellStringType) "text/plain" "fromString"- -- TODO fromJusts+ String -> InputInfo [] haskellStringType "text/plain" "toLbs" XML -> InputInfo (L.get haskellModules dsc) (L.get haskellType dsc) "text/xml" "toXML" JSON -> InputInfo (L.get haskellModules dsc) (L.get haskellType dsc) "text/json" "toJSON" File -> InputInfo [] haskellByteStringType "application/octet-stream" "id" Other -> InputInfo [] haskellByteStringType "text/plain" "id" data ResponseInfo = ResponseInfo- { responseModules :: [H.ModuleName]- , responseHaskellType :: H.Type+ { responseModules :: [N.ModuleName]+ , responseHaskellType :: N.Type , responseFunc :: String } deriving (Eq, Show) @@ -429,5 +523,8 @@ DataDesc { _dataType = dt , _haskellType = haskellVoidType- , _haskellModules = [ModuleName "Rest.Types.Void"]+ , _haskellModules = [ModuleName () "Rest.Types.Void"] }++stringLit :: String -> N.Exp+stringLit s = H.Lit () $ H.String () s s
src/Rest/Gen/JavaScript.hs view
@@ -4,12 +4,10 @@ import Prelude hiding ((.)) import Control.Category ((.))-import Control.Monad import Data.Maybe import Text.StringTemplate-import qualified Data.Label.Total as L-import qualified Data.List.NonEmpty as NList-import qualified Language.Haskell.Exts.Syntax as H+import qualified Data.Label.Total as L+import qualified Data.List.NonEmpty as NList import Code.Build import Code.Build.JavaScript@@ -17,11 +15,12 @@ import Rest.Gen.Base import Rest.Gen.Types import Rest.Gen.Utils+import qualified Rest.Gen.NoAnnotation as N -mkJsApi :: H.ModuleName -> Bool -> Version -> Router m s -> IO String+mkJsApi :: N.ModuleName -> Bool -> Version -> Router m s -> IO String mkJsApi ns priv ver r =- do prelude <- liftM (render . setManyAttrib attrs . newSTMP) (readContent "Javascript/prelude.js")- epilogue <- liftM (render . setManyAttrib attrs . newSTMP) (readContent "Javascript/epilogue.js")+ do prelude <- render . setManyAttrib attrs . newSTMP <$> readContent "Javascript/prelude.js"+ epilogue <- render . setManyAttrib attrs . newSTMP <$> readContent "Javascript/epilogue.js" let cod = showCode $ mkStack [ unModuleName ns ++ ".prototype.version" .=. string (show ver) , mkJsCode (unModuleName ns) priv r@@ -39,7 +38,7 @@ mkJs ns = foldTreeChildren mkStack (\i ls -> mkStack $ mkRes ns i : ls) mkRes :: String -> ApiResource -> Code-mkRes ns node = mkStack $+mkRes ns node = mkStack [ if hasAccessor node then resourceLoc ns node .=. mkAccessorConstructor ns node else resourceLoc ns node .=. jsObject []@@ -80,8 +79,8 @@ 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 $+ mIdent = jsId . cleanName . description <$> ident ai+ in function fParams [ var "postfix" $ "'" ++ urlPart ++ "'" , var "accessor" $ new "this" . code $ "this.contextUrl + postfix, " ++ "this.secureContextUrl + postfix, "@@ -100,16 +99,16 @@ 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+ mIdent = (if isAccessor ai then const Nothing else id) $ jsId . cleanName . description <$> ident ai in function fParams $ ret $ call (ns ++ "." ++ "ajaxCall") [ string (method ai)- , code $ (if (https ai) then "this.secureContextUrl" else "this.contextUrl") ++ " + '" ++ urlPart ++ "'"+ , code $ (if https ai then "this.secureContextUrl" else "this.contextUrl") ++ " + '" ++ urlPart ++ "'" , code "params" , code "success" , code "error" , string $ maybe "text/plain" snd3 mInp- , string $ mOut+ , string mOut , maybe (code "undefined") (\(p, _, f) -> f (code p)) mInp , code "callOpts" , code "this.modifyRequest"
+ src/Rest/Gen/NoAnnotation.hs view
@@ -0,0 +1,42 @@+module Rest.Gen.NoAnnotation where++import qualified Language.Haskell.Exts as A++type Alt = A.Alt ()+type BangType = A.BangType ()+type Binds = A.Binds ()+type ClassDecl = A.ClassDecl ()+type Context = A.Context ()+type Decl = A.Decl ()+type DeclHead = A.DeclHead ()+type Exp = A.Exp ()+type ExportSpec = A.ExportSpec ()+type ExportSpecList = A.ExportSpecList ()+type FieldDecl = A.FieldDecl ()+type FieldUpdate = A.FieldUpdate ()+type GadtDecl = A.GadtDecl ()+type GuardedRhs = A.GuardedRhs ()+type ImportDecl = A.ImportDecl ()+type ImportSpec = A.ImportSpec ()+type Literal = A.Literal ()+type Match = A.Match ()+type Module = A.Module ()+type ModuleName = A.ModuleName ()+type ModulePragma = A.ModulePragma ()+type Name = A.Name ()+type Pat = A.Pat ()+type PatField = A.PatField ()+type QName = A.QName ()+type QOp = A.QOp ()+type QualConDecl = A.QualConDecl ()+type QualStmt = A.QualStmt ()+type Rhs = A.Rhs ()+type Sign = A.Sign ()+type SpecialCon = A.SpecialCon ()+type SrcLoc = A.SrcLoc+type SrcSpan = A.SrcSpan+type SrcSpanInfo = A.SrcSpanInfo+type Stmt = A.Stmt ()+type TyVarBind = A.TyVarBind ()+type Type = A.Type ()+type WarningText = A.WarningText ()
src/Rest/Gen/Ruby.hs view
@@ -10,7 +10,6 @@ import Data.Maybe import qualified Data.Label.Total as L import qualified Data.List.NonEmpty as NList-import qualified Language.Haskell.Exts.Syntax as H import Code.Build import Code.Build.Ruby@@ -18,8 +17,9 @@ import Rest.Gen.Base import Rest.Gen.Types import Rest.Gen.Utils+import qualified Rest.Gen.NoAnnotation as N -mkRbApi :: H.ModuleName -> Bool -> Version -> Router m s -> IO String+mkRbApi :: N.ModuleName -> Bool -> Version -> Router m s -> IO String mkRbApi ns priv ver r = do rawPrelude <- readContent "Ruby/base.rb" let prelude = replace "SilkApi" (unModuleName ns) rawPrelude@@ -39,8 +39,8 @@ apiConstructor :: Version -> ApiResource -> Code apiConstructor ver node =- rbClass "BaseApi" $- [ function "initialize" ["resUrl"] $ mkStack $+ rbClass "BaseApi"+ [ function "initialize" ["resUrl"] $ mkStack [ "@url" .=. ("resUrl + '/v" ++ show ver ++ "/'") , "@api" .=. "self" ]@@ -68,11 +68,11 @@ ] mkPostFuncs :: ApiResource -> Code-mkPostFuncs node = mkStack . map mkFunction . filter (postAction . itemInfo) . resItems $ node+mkPostFuncs = mkStack . map mkFunction . filter (postAction . itemInfo) . resItems mkPreFuncs :: ApiResource -> Code mkPreFuncs node =- let (acs, funcs) = partition (isAccessor . itemInfo) . filter ((\i -> not $ postAction i) . itemInfo) $ resItems node+ let (acs, funcs) = partition (isAccessor . itemInfo) . filter (not . postAction . itemInfo) $ resItems node in mkStack (map mkAccessor acs) <-> mkStack (map mkFunction funcs) mkAccessor :: ApiAction -> Code@@ -82,7 +82,7 @@ ++ maybe "" (\i -> "' + " ++ i ++ " + '/") mIdent datType = maybe ":data" ((':':) . fst3 . mkType . L.get (dataType . desc) . chooseType) . NList.nonEmpty . outputs $ ai- mIdent = fmap (rbName . cleanName . description) $ ident ai+ mIdent = rbName . cleanName . description <$> ident ai in function (rbName $ mkFuncParts node) fParams $ ret $ new (className rid) ["@url + '" ++ urlPart ++ "'", "@api", datType] @@ -96,9 +96,9 @@ mOut = fmap (mkType . L.get (dataType . desc) . chooseType) . NList.nonEmpty . outputs $ ai urlPart = (if resDir ai == "" then "" else resDir ai ++ "/") ++ maybe "" (\i -> "' + " ++ i ++ " + '/") mIdent- mIdent = fmap (rbName . cleanName . description) $ ident ai+ mIdent = rbName . cleanName . description <$> ident ai in function (rbName $ mkFuncParts node) fParams $- call ("internalSilkRequest")+ call "internalSilkRequest" [ code "@api" , code $ ':' : map toLower (show $ method ai) , code $ "@url + '" ++ urlPart ++ "'"
src/Rest/Gen/Types.hs view
@@ -17,43 +17,43 @@ import Language.Haskell.Exts.SrcLoc (noLoc) import Language.Haskell.Exts.Syntax (ImportDecl (..), ModuleName (..), Name (..), QName (..), SpecialCon (..), Type (..)) -unModuleName :: ModuleName -> String-unModuleName (ModuleName name) = name+import qualified Rest.Gen.NoAnnotation as N -overModuleName :: (String -> String) -> ModuleName -> ModuleName-overModuleName f = ModuleName . f . unModuleName+unModuleName :: N.ModuleName -> String+unModuleName (ModuleName _ name) = name +overModuleName :: (String -> String) -> N.ModuleName -> N.ModuleName+overModuleName f = ModuleName () . f . unModuleName+ -- | Create a simple named basic import, to be updated with other fields -- as needed.-namedImport :: String -> ImportDecl+namedImport :: String -> N.ImportDecl namedImport name = ImportDecl- { importLoc = noLoc+ { importAnn = () , importQualified = False- , importModule = ModuleName name+ , importModule = ModuleName () name , importSrc = False-#if MIN_VERSION_haskell_src_exts(1,16,0) , importSafe = False-#endif , importPkg = Nothing , importAs = Nothing , importSpecs = Nothing } -- | Qualified import with given name-qualImport :: String -> ImportDecl+qualImport :: String -> N.ImportDecl qualImport name = (namedImport name) { importQualified = True } -haskellStringType :: Type+haskellStringType :: N.Type haskellStringType = haskellSimpleType "String" -haskellByteStringType :: Type+haskellByteStringType :: N.Type haskellByteStringType = haskellSimpleType "ByteString" -haskellSimpleType :: String -> Type-haskellSimpleType = TyCon . UnQual . Ident+haskellSimpleType :: String -> N.Type+haskellSimpleType = TyCon () . UnQual () . Ident () -haskellUnitType :: Type-haskellUnitType = TyCon (Special UnitCon)+haskellUnitType :: N.Type+haskellUnitType = TyCon () (Special () (UnitCon ())) -haskellVoidType :: Type-haskellVoidType = TyCon (Qual (ModuleName "Rest.Types.Void") (Ident "Void"))+haskellVoidType :: N.Type+haskellVoidType = TyCon () (Qual () (ModuleName () "Rest.Types.Void") (Ident () "Void"))
tests/Runner.hs view
@@ -1,12 +1,14 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE- OverloadedStrings+ FlexibleInstances+ , OverloadedStrings , ScopedTypeVariables #-} import Prelude hiding ((.)) import Control.Category ((.))+import Control.Monad (void) import Data.String import Test.Framework (defaultMain) import Test.Framework.Providers.HUnit (testCase)@@ -24,7 +26,7 @@ import Rest.Schema main :: IO ()-main = do+main = defaultMain [ testCase "Listing has right parameters." testListingParams , testCase "Selects should show up only once." testSingleSelect , testCase "Removes should show up only once." testSingleRemove@@ -88,5 +90,5 @@ resource = mkResourceId { name = "resource", schema = Schema (Just (Many ())) (Named []), list = listHandler } listHandler () = mkListing xmlJsonO $ \_ -> return [()] -instance IsString H.Type where- fromString = H.fromParseResult . H.parse+instance IsString (H.Type ()) where+ fromString = void . H.fromParseResult . H.parseType