yesod-routes-flow 2.0 → 3.0.0.1
raw patch · 6 files changed
+415/−101 lines, 6 filesdep +hspecdep +hspec-expectationsdep +semigroupsdep ~attoparsecdep ~basedep ~containersnew-uploader
Dependencies added: hspec, hspec-expectations, semigroups, shakespeare, yesod-routes-flow
Dependency ranges changed: attoparsec, base, containers, system-fileio, text
Files
- Changelog.md +9/−0
- Yesod/Routes/Flow/Generator.hs +121/−58
- test/GeneratorSpec.hs +190/−0
- test/Spec.hs +1/−0
- test/TestImport.hs +20/−0
- yesod-routes-flow.cabal +74/−43
+ Changelog.md view
@@ -0,0 +1,9 @@+## [_Unreleased_](https://github.com/freckle/yesod-routes-flow/compare/v3.0.0.1...main)++None++## [v3.0.0.1](https://github.com/freckle/yesod-routes-flow/compare/2.0...v3.0.0.1)++- Setup CI/CD+- Starting in `yesod-core-1.6.2`, `yesod-core` started deriving `Show` for `ResourceTree` and `FlatResource`. To prevent duplicate instance errors, this package now only derives `Show` for `yesod-core < 1.6.2`.+- An implication of this is that building anything less than `yesod-routes-flow-3.0.0.1` with `yesod-core-1.6.2` will cause duplicate instance compiler errors.
Yesod/Routes/Flow/Generator.hs view
@@ -1,69 +1,104 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-} module Yesod.Routes.Flow.Generator- ( genFlowRoutesPrefix- , genFlowRoutes- ) where+ ( genFlowRoutes+ , genFlowRoutesPrefix+ , genFlowSource+ , genFlowClasses+ , classesToFlow+ , Class(..)+ , ClassMember(..)+ , RenderedPiece(..)+ , PieceType(..)+ ) where import ClassyPrelude hiding (FilePath)+import qualified Data.Char as C+import qualified Data.List as L+import qualified Data.Map as Map import Data.Text (dropWhileEnd)+import qualified Data.Text as T import Filesystem (createTree, writeTextFile) import Filesystem.Path (FilePath, directory) import Yesod.Routes.TH.Types-import qualified Data.Char as C-import qualified Data.Map as M-import qualified Data.Text as T +-- An override map from Haskell type name to Flow type name+type Overrides = Map.Map String PieceType genFlowRoutes :: [ResourceTree String] -> FilePath -> IO ()-genFlowRoutes ra fp = genFlowRoutesPrefix [] [] ra fp "''"+genFlowRoutes ra fp = genFlowRoutesPrefix Map.empty [] [] ra fp "''" -genFlowRoutesPrefix :: [String] -> [String] -> [ResourceTree String] -> FilePath -> Text -> IO ()-genFlowRoutesPrefix routePrefixes elidedPrefixes fullTree fp prefix = do+genFlowRoutesPrefix :: Overrides -> [String] -> [String] -> [ResourceTree String] -> FilePath -> Text -> IO ()+genFlowRoutesPrefix overrides routePrefixes elidedPrefixes fullTree fp prefix = do createTree $ directory fp- writeTextFile fp routesCs- where- routesCs =- let classes =- map disambiguateFields $- resourceTreeToClasses elidedPrefixes $- ResourceParent "paths" False [] hackedTree- in "/* @flow */\n\n"- <> classesToFlow classes- <> "\n\nvar PATHS: PATHS_TYPE_paths = new PATHS_TYPE_paths(" <> prefix <> ");\n"+ writeTextFile fp $ genFlowSource overrides routePrefixes elidedPrefixes prefix fullTree - -- Route hackery.- landingRoutes = flip filter fullTree $ \case- ResourceParent _ _ _ _ -> False- ResourceLeaf res -> not $ elem (resourceName res) ["AuthR", "StaticR"]- parents =- -- if routePrefixes is empty, include all routes- filter (\n -> null routePrefixes || any (parentName n) routePrefixes) fullTree- hackedTree = ResourceParent "staticPages" False [] landingRoutes : parents+genFlowSource :: Overrides -> [String] -> [String] -> Text -> [ResourceTree String] -> Text+genFlowSource overrides routePrefixes elidedPrefixes prefix fullTree =+ mconcat+ [ "/* @flow */\n\n"+ , classesToFlow $ genFlowClasses overrides routePrefixes elidedPrefixes fullTree+ , "\n\nvar PATHS: PATHS_TYPE_paths = new PATHS_TYPE_paths(" <> prefix <> ");\n"+ ] +genFlowClasses :: Overrides -> [String] -> [String] -> [ResourceTree String] -> [Class]+genFlowClasses overrides routePrefixes elidedPrefixes fullTree =+ map disambiguateFields $+ resourceTreeToClasses overrides elidedPrefixes $+ ResourceParent "paths" False [] hackedTree+ where+ -- Route hackery.+ landingRoutes = flip filter fullTree $ \case+ ResourceParent {} -> False+ ResourceLeaf res -> notElem (resourceName res) ["AuthR", "StaticR"]+ parents =+ -- if routePrefixes is empty, include all routes+ filter (\n -> null routePrefixes || any (parentName n) routePrefixes) fullTree+ hackedTree = ResourceParent "staticPages" False [] landingRoutes : parents++ parentName :: ResourceTree String -> String -> Bool parentName (ResourceParent n _ _ _) name = n == name-parentName _ _ = False+parentName _ _ = False ---------------------------------------------------------------------- -data RenderedPiece =- Path Text- | Number- | String+data RenderedPiece+ = Path Text+ | Dyn PieceType+ deriving (Eq, Show) +data PieceType+ = NumberT+ | StringT+ | NonEmptyT PieceType+ deriving (Eq, Show)+ isVariable :: RenderedPiece -> Bool isVariable (Path _) = False-isVariable _ = True+isVariable (Dyn _) = True -renderRoutePieces :: [Piece String] -> [RenderedPiece]-renderRoutePieces = map renderRoutePiece+renderRoutePieces :: Overrides -> [Piece String] -> [RenderedPiece]+renderRoutePieces overrides = map renderRoutePiece where renderRoutePiece (Static st) = Path $ T.dropAround (== '/') $ pack st- renderRoutePiece (Dynamic typ) = if isNumberType typ then Number else String+ renderRoutePiece (Dynamic typ) = Dyn $ parseType typ - isNumberType "Int" = True- isNumberType type_ = "Id" `isSuffixOf` type_ -- UserId, PageId, PostId, etc.+ parseType type_ =+ fromMaybe+ (maybe+ (parseSimpleType type_)+ (NonEmptyT . parseType)+ (L.stripPrefix "NonEmpty" type_)) -- NonEmptyUserId ~ NonEmpty UserId+ $ Map.lookup type_ overrides + parseSimpleType "Int" = NumberT+ parseSimpleType type_+ | "Id" `isSuffixOf` type_ = NumberT -- UserId, PageId, PostId, etc.+ | otherwise = StringT+ ---------------------------------------------------------------------- -- | A Flow class that will be generated.@@ -72,6 +107,7 @@ { className :: Text , classMembers :: [ClassMember] }+ deriving (Eq, Show) data ClassMember = -- | A 'ResourceParent' inside the 'ResourceParent'@@ -82,9 +118,10 @@ } -- | A callable method. | Method- { cmField :: Text -- ^ Field name used to refer to the method.- , cmPieces :: [RenderedPiece] -- ^ Pieces to render the route.+ { cmField :: Text -- ^ Field name used to refer to the method.+ , cmPieces :: [RenderedPiece] -- ^ Pieces to render the route. }+ deriving (Eq, Show) variableCount :: ClassMember -> Int variableCount ChildClass {} = 0@@ -96,8 +133,8 @@ ---------------------------------------------------------------------- -- | Create a list of 'Class'es from a 'ResourceTree'.-resourceTreeToClasses :: [String] -> ResourceTree String -> [Class]-resourceTreeToClasses elidedPrefixes = finish . go Nothing []+resourceTreeToClasses :: Overrides -> [String] -> ResourceTree String -> [Class]+resourceTreeToClasses overrides elidedPrefixes = finish . go Nothing [] where finish (Right (_, classes)) = classes finish (Left _) = []@@ -105,19 +142,19 @@ go :: Maybe Text -> [RenderedPiece] -> ResourceTree String -> Either (Maybe ClassMember) ([ClassMember], [Class]) go _parent routePrefix (ResourceLeaf res) = Left $ do- Methods _ methods <- return $ resourceDispatch res -- Ignore subsites.+ Methods _ methods <- pure $ resourceDispatch res -- Ignore subsites. guard (not $ null methods) -- Silently ignore routes without methods. let resName = T.replace "." "" $ T.replace "-" "_" fullName fullName = intercalate "_" [pack st :: Text | Static st <- resourcePieces res]- return Method+ pure Method { cmField = if null fullName then "_" else resName- , cmPieces = routePrefix <> renderRoutePieces (resourcePieces res) }+ , cmPieces = routePrefix <> renderRoutePieces overrides (resourcePieces res) } go parent routePrefix (ResourceParent name _ pieces children) = let elideThisPrefix = name `elem` elidedPrefixes pref = cleanName $ pack name jsName = maybe "" (<> "_") parent <> pref newParent = if elideThisPrefix then parent else Just jsName- newRoutePrefix = routePrefix <> renderRoutePieces pieces+ newRoutePrefix = routePrefix <> renderRoutePieces overrides pieces membersMethods = catMaybes childrenMethods (childrenMethods, childrenClasses) = partitionEithers $ map (go newParent newRoutePrefix) children (membersClasses, moreClasses) = concat *** concat $ unzip childrenClasses@@ -137,7 +174,7 @@ cleanName :: Text -> Text cleanName = underscorize . uncapitalize . dropWhileEnd C.isUpper- where uncapitalize t = (toLower $ take 1 t) <> drop 1 t+ where uncapitalize t = toLower (take 1 t) <> drop 1 t underscorize = T.pack . go . T.unpack where go (c:cs) | C.isUpper c = '_' : C.toLower c : go cs | otherwise = c : go cs@@ -150,13 +187,13 @@ disambiguateFields klass = klass { classMembers = processMembers $ classMembers klass } where processMembers = fromMap . disambiguate viaLetters . disambiguate viaArgCount . toMap- fromMap = concat . M.elems- toMap = M.fromListWith (++) . labelled- labelled = map (cmField &&& return)- append t = \cm -> cm { cmField = cmField cm <> t cm }+ fromMap = concat . Map.elems+ toMap = Map.fromListWith (++) . labelled+ labelled = map (cmField &&& pure)+ append t cm = cm { cmField = cmField cm <> t cm } - disambiguate :: ([ClassMember] -> [ClassMember]) -> M.Map Text [ClassMember] -> M.Map Text [ClassMember]- disambiguate inner = M.fromListWith (++) . concatMap f . M.toList+ disambiguate :: ([ClassMember] -> [ClassMember]) -> Map.Map Text [ClassMember] -> Map.Map Text [ClassMember]+ disambiguate inner = Map.fromListWith (++) . concatMap f . Map.toList where f :: (Text, [ClassMember]) -> [(Text, [ClassMember])] f y@(_, [ ]) = [y]@@ -175,16 +212,40 @@ classMemberToFlowDef ChildClass {..} = " " <> cmField <> " : " <> cmClassName <> ";\n" classMemberToFlowDef Method {..} = " " <> cmField <> "(" <> args <> "): string { " <> body <> "; }\n" where- args = intercalate ", " $ zipWith render variableNames (filter isVariable cmPieces)+ args = intercalate ", " $ zipWith render variableNames $ mapMaybe getType cmPieces where- render name typ = name <> ": " <> (case typ of { Number -> "number"; String -> "string" })+ render name typ = name <> ": " <> argType typ + getType (Path _) = Nothing+ getType (Dyn t) = Just t++ argType NumberT = "number"+ argType StringT = "string"+ argType (NonEmptyT t) = "Array<" <> argType t <> ">"+ body = "return this.root + '" <> routeStr variableNames cmPieces <> "'" where- routeStr vars (Path p:rest) = (if null p then "" else "/" <> p) <> routeStr vars rest- routeStr (v:vars) (_:rest) = "/' + " <> v <> ".toString() + '" <> routeStr vars rest- routeStr _ _ = ""+ routeStr vars (Path p:rest) = (if null p then "" else "/" <> p) <> routeStr vars rest+ routeStr (v:vars) (Dyn t:rest) = "/' + " <> convert v 0 t <> " + '" <> routeStr vars rest+ routeStr _ _ = "" + convert v i StringT = name v i+ convert v i NumberT = name v i <> ".toString()"+ convert v i (NonEmptyT t) =+ T.concat+ [ name v i+ , ".map(function("+ , name v (i + 1)+ , ") { return "+ , convert v (i + 1) t+ , " }).join(',')"+ ]++ name :: Text -> Int -> Text+ name v 0 = v+ name v i = v <> pack (show i)++ classMemberToFlowInit :: ClassMember -> Text classMemberToFlowInit ChildClass {..} = " this." <> cmField <> " = new " <> cmClassName <> "(root);\n" classMemberToFlowInit Method {} = ""@@ -204,5 +265,7 @@ classesToFlow :: [Class] -> Text classesToFlow = intercalate "\n" . map classToFlow +#if !MIN_VERSION_yesod_core(1, 6, 2) deriving instance (Show a) => Show (ResourceTree a) deriving instance (Show a) => Show (FlatResource a)+#endif
+ test/GeneratorSpec.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE QuasiQuotes #-}++module GeneratorSpec where++import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.Map as Map+import TestImport++type UserId = Int+type NonEmptyUserId = NonEmpty UserId++resources :: [ResourceTree String]+resources = [parseRoutes|+ /api ApiP:+ /users/#UserId UsersR GET+ /users/#Int/foo UsersFooR GET+ /users/#NonEmptyUserId/bar UsersBarR GET+ /users/#Other/baz UsersBazR GET+|]++spec :: Spec+spec = do+ describe "genFlowClasses" $ do+ it "should generate classes" $ do+ let classes = genFlowClasses Map.empty [] [] resources+ map className classes+ `shouldBe`+ [ "PATHS_TYPE_paths"+ , "PATHS_TYPE_paths_static_pages"+ , "PATHS_TYPE_paths_api"+ ]++ it "should identify path variable types" $ do+ let+ classes = genFlowClasses Map.empty [] [] resources+ apiClass = find ((== "PATHS_TYPE_paths_api") . className) classes+ map classMembers apiClass+ `shouldBe`+ Just+ [ Method+ "users"+ [ Path "api"+ , Path "users"+ , Dyn NumberT+ ]+ , Method+ "users_bar"+ [ Path "api"+ , Path "users"+ , Dyn (NonEmptyT NumberT)+ , Path "bar"+ ]+ , Method+ "users_baz"+ [ Path "api"+ , Path "users"+ , Dyn StringT+ , Path "baz"+ ]+ , Method+ "users_foo"+ [ Path "api"+ , Path "users"+ , Dyn NumberT+ , Path "foo"+ ]+ ]+ it "should respect overrides " $ do+ let+ classes = genFlowClasses (Map.fromList [("UserId", StringT)]) [] [] resources+ apiClass = find ((== "PATHS_TYPE_paths_api") . className) classes+ map classMembers apiClass+ `shouldBe`+ Just+ [ Method+ "users"+ [ Path "api"+ , Path "users"+ , Dyn StringT+ ]+ , Method+ "users_bar"+ [ Path "api"+ , Path "users"+ , Dyn (NonEmptyT StringT)+ , Path "bar"+ ]+ , Method+ "users_baz"+ [ Path "api"+ , Path "users"+ , Dyn StringT+ , Path "baz"+ ]+ , Method+ "users_foo"+ [ Path "api"+ , Path "users"+ , Dyn NumberT+ , Path "foo"+ ]+ ]+ describe "classesToFlow" $ do+ it "should generate formal parameters for each path variable" $ do+ let+ cls =+ [ Class+ "x"+ [ Method+ "y"+ [ Path "x"+ , Dyn StringT+ , Path "y"+ , Dyn NumberT+ , Path "z"+ , Dyn StringT+ ]+ ]+ ]+ normalizeText (classesToFlow cls)+ `shouldBe`+ normalizeText [st|+ class x {+ y(a: string, aa: number, aaa: string): string { return this.root + '/x/' + a + '/y/' + aa.toString() + '/z/' + aaa + ''; }+ root: string;+ constructor(root: string) {+ this.root = root;+ }+ }+ |]+ it "should avoid name shadowing in nested binders" $ do+ let+ cls =+ [ Class+ "x"+ [ Method+ "y"+ [ Path "x"+ , Dyn (NonEmptyT (NonEmptyT NumberT))+ , Path "y"+ ]+ ]+ ]+ normalizeText (classesToFlow cls)+ `shouldBe`+ normalizeText [st|+ class x {+ y(a: Array<Array<number>>): string { return this.root + '/x/' + a.map(function(a1) { return a1.map(function(a2) { return a2.toString() }).join(',') }).join(',') + '/y'; }+ root: string;+ constructor(root: string) {+ this.root = root;+ }+ }+ |]++ describe "genFlowSource" $+ it "should work end-to-end" $ do+ let source = genFlowSource Map.empty [] [] "'test'" resources+ normalizeText source+ `shouldBe`+ normalizeText [st|+ /* @flow */+ class PATHS_TYPE_paths {+ api : PATHS_TYPE_paths_api;+ static_pages : PATHS_TYPE_paths_static_pages;+ root: string;+ constructor(root: string) {+ this.root = root;+ this.api = new PATHS_TYPE_paths_api(root);+ this.static_pages = new PATHS_TYPE_paths_static_pages(root);+ }+ }+ class PATHS_TYPE_paths_static_pages {+ root: string;+ constructor(root: string) {+ this.root = root;+ }+ }+ class PATHS_TYPE_paths_api {+ users(a: number): string { return this.root + '/api/users/' + a.toString() + ''; }+ users_bar(a: Array<number>): string { return this.root + '/api/users/' + a.map(function(a1) { return a1.toString() }).join(',') + '/bar'; }+ users_baz(a: string): string { return this.root + '/api/users/' + a + '/baz'; }+ users_foo(a: number): string { return this.root + '/api/users/' + a.toString() + '/foo'; }+ root: string;+ constructor(root: string) {+ this.root = root;+ }+ }+ var PATHS: PATHS_TYPE_paths = new PATHS_TYPE_paths('test');+ |]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/TestImport.hs view
@@ -0,0 +1,20 @@+module TestImport+ ( module X+ , normalizeText+ , parseRoutes+ , ResourceTree(..)+ , st+ ) where++import Yesod.Routes.Flow.Generator as X++import ClassyPrelude as X+import qualified Data.Text as T+import Test.Hspec as X+import Text.Shakespeare.Text (st)+import Yesod.Core.Dispatch (parseRoutes)+import Yesod.Routes.TH.Types (ResourceTree(..))++-- Avoid having to exactly compare leading whitespace or empty lines+normalizeText :: Text -> Text+normalizeText = T.unlines . filter (/="") . map T.strip . T.lines
yesod-routes-flow.cabal view
@@ -1,45 +1,76 @@-name: yesod-routes-flow-version: 2.0-synopsis: Generate Flow routes for Yesod-description: Parse the Yesod routes data structure and generate routes that can be used with Flow.-homepage: https://github.com/frontrowed/yesod-routes-flow-license: MIT-license-file: LICENSE-author: Max Cantor, Felipe Lessa-maintainer: Greg Weber <greg@frontrowed.com>--- copyright:-category: Web-build-type: Simple-extra-source-files: README.md-cabal-version: >=1.10+cabal-version: 1.18+name: yesod-routes-flow+version: 3.0.0.1+license: MIT+license-file: LICENSE+copyright: 2021 Renaissance Learning Inc+maintainer: engineering@freckle.com+author: Freckle Engineering+homepage: https://github.com/freckle/yesod-routes-flow+bug-reports: https://github.com/freckle/yesod-routes-flow/issues+synopsis: Generate Flow routes for Yesod+description:+ Parse the Yesod routes data structure and generate routes that can be used with Flow. +category: Web+build-type: Simple+extra-doc-files:+ Changelog.md+ README.md++source-repository head+ type: git+ location: https://github.com/freckle/yesod-routes-flow+ library- exposed-modules: Yesod.Routes.Flow.Generator- -- other-modules:- -- other-extensions:- default-extensions:- ConstraintKinds,- DeriveDataTypeable,- ExtendedDefaultRules,- FlexibleContexts,- FlexibleInstances,- LambdaCase,- NoImplicitPrelude,- OverloadedStrings,- RecordWildCards,- ScopedTypeVariables,- StandaloneDeriving,- TemplateHaskell,- TupleSections,- TypeSynonymInstances- build-depends:- attoparsec,- base < 5,- classy-prelude >= 0.7,- system-fileio,- system-filepath >= 0.4,- containers,- text,- yesod-core >= 1.4 && < 2.0- -- hs-source-dirs:- default-language: Haskell2010+ exposed-modules: Yesod.Routes.Flow.Generator+ other-modules: Paths_yesod_routes_flow+ default-language: Haskell2010+ default-extensions:+ ConstraintKinds DeriveDataTypeable ExtendedDefaultRules+ FlexibleContexts FlexibleInstances LambdaCase NoImplicitPrelude+ OverloadedStrings RecordWildCards ScopedTypeVariables+ StandaloneDeriving TemplateHaskell TupleSections+ TypeSynonymInstances++ build-depends:+ attoparsec >=0.13.2.0,+ base >=4.10.1.0 && <5,+ classy-prelude >=0.7,+ containers >=0.5.10.2,+ system-fileio >=0.3.16.3,+ system-filepath >=0.4,+ text >=1.2.2.2,+ yesod-core >=1.4 && <2.0++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ other-modules:+ GeneratorSpec+ TestImport+ Paths_yesod_routes_flow++ default-language: Haskell2010+ default-extensions:+ ConstraintKinds DeriveDataTypeable ExtendedDefaultRules+ FlexibleContexts FlexibleInstances LambdaCase NoImplicitPrelude+ OverloadedStrings RecordWildCards ScopedTypeVariables+ StandaloneDeriving TemplateHaskell TupleSections+ TypeSynonymInstances++ build-depends:+ attoparsec >=0.13.2.0,+ base >=4.10.1.0 && <5,+ classy-prelude >=0.7,+ containers >=0.5.10.2,+ hspec >=2.4.4,+ hspec-expectations >=0.8.2,+ semigroups >=0.18.3,+ shakespeare >=2.0.14.1,+ system-fileio >=0.3.16.3,+ system-filepath >=0.4,+ text >=1.2.2.2,+ yesod-core >=1.4 && <2.0,+ yesod-routes-flow -any