diff --git a/Yesod/Routes/Flow/Generator.hs b/Yesod/Routes/Flow/Generator.hs --- a/Yesod/Routes/Flow/Generator.hs +++ b/Yesod/Routes/Flow/Generator.hs @@ -6,142 +6,203 @@ import ClassyPrelude hiding (FilePath) import Data.Text (dropWhileEnd) -import qualified Data.Text as DT import Filesystem (createTree, writeTextFile) import Filesystem.Path (FilePath, directory) -import qualified Data.Char as DC import Yesod.Routes.TH.Types - -- ( ResourceTree(..), - -- Piece(Dynamic, Static), - -- FlatResource, - -- Resource(resourceDispatch, resourceName, resourcePieces), - -- Dispatch(Methods, Subsite) ) +import qualified Data.Char as C +import qualified Data.Map as M +import qualified Data.Text as T genFlowRoutes :: [ResourceTree String] -> FilePath -> IO () genFlowRoutes ra fp = genFlowRoutesPrefix [] [] ra fp "''" genFlowRoutesPrefix :: [String] -> [String] -> [ResourceTree String] -> FilePath -> Text -> IO () -genFlowRoutesPrefix routePrefixes elidedPrefixes resourcesApp fp prefix = do +genFlowRoutesPrefix routePrefixes elidedPrefixes fullTree fp prefix = do createTree $ directory fp writeTextFile fp routesCs where routesCs = - let res = (resToCoffeeString Nothing "" $ ResourceParent "paths" False [] hackedTree) - in "/* @flow */\n" <> - either id id (snd res) - <> "\nvar PATHS: PATHS_TYPE_paths = new PATHS_TYPE_paths("<>prefix<>");\n" + 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" - -- route hackery.. - fullTree = resourcesApp :: [ResourceTree String] + -- Route hackery. landingRoutes = flip filter fullTree $ \case ResourceParent _ _ _ _ -> False ResourceLeaf res -> not $ elem (resourceName res) ["AuthR", "StaticR"] - - parentName :: ResourceTree String -> String -> Bool - parentName (ResourceParent n _ _ _) name = n == name - parentName _ _ = False - parents = -- if routePrefixes is empty, include all routes - filter (\n -> routePrefixes == [] || any (parentName n) routePrefixes) fullTree + filter (\n -> null routePrefixes || any (parentName n) routePrefixes) fullTree hackedTree = ResourceParent "staticPages" False [] landingRoutes : parents - cleanName = underscorize . uncapitalize . dropWhileEnd DC.isUpper - where uncapitalize t = (toLower $ take 1 t) <> drop 1 t - underscorize = DT.pack . go . DT.unpack - where go (c:cs) | DC.isUpper c = '_' : DC.toLower c : go cs - | otherwise = c : go cs - go [] = [] +parentName :: ResourceTree String -> String -> Bool +parentName (ResourceParent n _ _ _) name = n == name +parentName _ _ = False + +---------------------------------------------------------------------- + +data RenderedPiece = + Path Text + | Number + | String + +isVariable :: RenderedPiece -> Bool +isVariable (Path _) = False +isVariable _ = True + +renderRoutePieces :: [Piece String] -> [RenderedPiece] +renderRoutePieces = map renderRoutePiece + where + renderRoutePiece (Static st) = Path $ T.dropAround (== '/') $ pack st + renderRoutePiece (Dynamic typ) = if isNumberType typ then Number else String + isNumberType "Int" = True isNumberType type_ = "Id" `isSuffixOf` type_ -- UserId, PageId, PostId, etc. - renderRoutePieces pieces = intercalate "/" $ map renderRoutePiece pieces - renderRoutePiece p = case p of - Static st -> pack st :: Text - Dynamic type_ | isNumberType type_ -> ": number" - | otherwise -> ": string" - isVariable r = length r > 1 && DT.head r == ':' - resRoute res = renderRoutePieces $ resourcePieces res - fullName res = intercalate "_" [pack st :: Text | Static st <- resourcePieces res] - singleSlash = DT.replace "//" "/" - resToCoffeeString :: Maybe Text -> Text -> ResourceTree String -> ([(Text, Text)], Either Text Text) - resToCoffeeString _parent routePrefix (ResourceLeaf res) = - -- previously assumed there weren't multiple methods per route path - -- now hacking in support - let jsNames = case resourceDispatch res of - Subsite _ _ -> [] -- silently ignore subsites - Methods _ [] -> error "no methods! (never here, check hasMethods)" - Methods _ methods -> - let resName_ = DT.replace "." "" $ DT.replace "-" "_" $ fullName res - prefix_ = if resName_ == "" then "" else resName_ <> "_" - -- we basically never will want to refer to OPTIONS - -- routes directly - callableMeths = filter (\a -> a /= "OPTIONS") methods in - if length callableMeths > 1 || resName_ == "" - then map ((prefix_ <>) . toLower . pack) callableMeths - else [resName_] - in ([], Right $ intercalate "\n" $ map mkLine jsNames) +---------------------------------------------------------------------- + +-- | A Flow class that will be generated. +data Class = + Class + { className :: Text + , classMembers :: [ClassMember] + } + +data ClassMember = + -- | A 'ResourceParent' inside the 'ResourceParent' + -- that generated this class. + ChildClass + { cmField :: Text -- ^ Field name used to refer to the child class. + , cmClassName :: Text -- ^ Class name of the child class. + } + -- | A callable method. + | Method + { cmField :: Text -- ^ Field name used to refer to the method. + , cmPieces :: [RenderedPiece] -- ^ Pieces to render the route. + } + +variableCount :: ClassMember -> Int +variableCount ChildClass {} = 0 +variableCount Method {..} = length (filter isVariable cmPieces) + +variableNames :: [Text] +variableNames = T.cons <$> ['a'..'z'] <*> ("" : variableNames) + +---------------------------------------------------------------------- + +-- | Create a list of 'Class'es from a 'ResourceTree'. +resourceTreeToClasses :: [String] -> ResourceTree String -> [Class] +resourceTreeToClasses elidedPrefixes = finish . go Nothing [] + where + finish (Right (_, classes)) = classes + finish (Left _) = [] + + 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. + 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 + { cmField = if null fullName then "_" else resName + , cmPieces = routePrefix <> renderRoutePieces (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 + membersMethods = catMaybes childrenMethods + (childrenMethods, childrenClasses) = partitionEithers $ map (go newParent newRoutePrefix) children + (membersClasses, moreClasses) = concat *** concat $ unzip childrenClasses + in Right $ + if elideThisPrefix + then (membersClasses, moreClasses) + else + let ourClass = + Class + { className = "PATHS_TYPE_" <> jsName + , classMembers = membersClasses ++ membersMethods } + ourReference = + ChildClass + { cmClassName = className ourClass + , cmField = pref } + in ([ourReference], ourClass : moreClasses) + +cleanName :: Text -> Text +cleanName = underscorize . uncapitalize . dropWhileEnd C.isUpper + 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 + go [] = [] + +---------------------------------------------------------------------- + +-- | Disambiguate fields by appending suffixes. +disambiguateFields :: Class -> Class +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 } + + disambiguate :: ([ClassMember] -> [ClassMember]) -> M.Map Text [ClassMember] -> M.Map Text [ClassMember] + disambiguate inner = M.fromListWith (++) . concatMap f . M.toList where - pieces = DT.splitOn "/" routeString - variables = zip variableNames (filter isVariable pieces) - where variableNames = DT.cons <$> ['a'..'z'] <*> ("" : variableNames) - mkLine jsName = " " <> jsName <> "(" - <> csvArgs variables - <> "): string { " - -- <> presenceChk - <> "return this.root + " <> quote (routeStr variables variablePieces) <> "; }" - routeStr vars ((Left p):rest) | null p = routeStr vars rest - | otherwise = "/" <> p <> routeStr vars rest - routeStr (v:vars) ((Right _):rest) = "/' + " <> fst v <> ".toString() + '" <> routeStr vars rest - routeStr [] [] = "" - routeStr _ [] = error "extra vars!" - routeStr [] _ = error "no more vars!" + f :: (Text, [ClassMember]) -> [(Text, [ClassMember])] + f y@(_, [ ]) = [y] + f y@(_, [_]) = [y] + f (_, xs ) = labelled $ inner xs - variablePieces = map (\p -> if isVariable p then Right p else Left p) pieces - csvArgs :: [(Text, Text)] -> Text - csvArgs = intercalate "," . map (\(var, typ) -> var <> typ) - quote str = "'" <> str <> "'" - routeString = singleSlash routePrefix <> resRoute res + -- Append the number of arguments. + viaArgCount = map $ append (T.pack . show . variableCount) - -- This is here because in the Flow code, we dont refer to - -- PATHS.api.doc.foo but PATHS.doc.foobar. So we can keep our route - -- organization in place but also leave Flow alone. - resToCoffeeString parent routePrefix (ResourceParent name _ pieces children) | name `elem` elidedPrefixes = - (concatMap fst res, Left $ intercalate "\n" (map (either id id . snd) res)) + -- Append arbitrary letters as a last resort. + viaLetters = zipWith (append . const) variableNames + +---------------------------------------------------------------------- + +classMemberToFlowDef :: ClassMember -> Text +classMemberToFlowDef ChildClass {..} = " " <> cmField <> " : " <> cmClassName <> ";\n" +classMemberToFlowDef Method {..} = " " <> cmField <> "(" <> args <> "): string { " <> body <> "; }\n" + where + args = intercalate ", " $ zipWith render variableNames (filter isVariable cmPieces) where - fxn = resToCoffeeString parent (routePrefix <> "/" <> renderRoutePieces pieces <> "/") - res = map fxn children + render name typ = name <> ": " <> (case typ of { Number -> "number"; String -> "string" }) - resToCoffeeString parent routePrefix (ResourceParent name _ pieces children) = - ([linkFromParent], Left $ resourceClassDef) + body = "return this.root + '" <> routeStr variableNames cmPieces <> "'" where - parentMembers f = - intercalate "\n " $ map f $ concatMap fst childFlow - memberInitFromParent (slot, klass) = " this." <> slot <> " = new " <> klass <> "(root);" - memberLinkFromParent (slot, klass) = "" <> slot <> ": " <> klass <> ";" - linkFromParent = (pref, resourceClassName) - resourceClassDef = - "class " <> resourceClassName <> " {\n" - <> intercalate "\n" childMembers <> "\n" - <> parentMembers memberLinkFromParent <> "\n" - <> " root: string;\n" - <> " constructor(root: string) {\n" - <> " this.root = root;\n " - <> parentMembers memberInitFromParent - <> "\n }\n" - <> "}\n\n" - <> intercalate "\n" childClasses - (childClasses, childMembers) = partitionEithers $ map snd childFlow - jsName = maybe "" (<> "_") parent <> pref - childFlow = flip map (filter hasMethods children) $ resToCoffeeString - (Just jsName) - (routePrefix <> "/" <> renderRoutePieces pieces <> "/") - pref = cleanName $ pack name - resourceClassName = "PATHS_TYPE_" <> jsName - -- Silently ignore routes without methods. - hasMethods (ResourceLeaf res) = case resourceDispatch res of { Methods _ [] -> False; _ -> True} - hasMethods _ = True + routeStr vars (Path p:rest) = (if null p then "" else "/" <> p) <> routeStr vars rest + routeStr (v:vars) (_:rest) = "/' + " <> v <> ".toString() + '" <> routeStr vars rest + routeStr _ _ = "" + +classMemberToFlowInit :: ClassMember -> Text +classMemberToFlowInit ChildClass {..} = " this." <> cmField <> " = new " <> cmClassName <> "(root);\n" +classMemberToFlowInit Method {} = "" + +classToFlow :: Class -> Text +classToFlow Class {..} = + "class " <> className <> " {\n" + <> concat (classMemberToFlowDef <$> classMembers) + <> "\n" + <> " root: string;\n" + <> " constructor(root: string) {\n" + <> " this.root = root;\n" + <> concat (classMemberToFlowInit <$> classMembers) + <> " }\n" + <> "}\n" + +classesToFlow :: [Class] -> Text +classesToFlow = intercalate "\n" . map classToFlow deriving instance (Show a) => Show (ResourceTree a) deriving instance (Show a) => Show (FlatResource a) diff --git a/yesod-routes-flow.cabal b/yesod-routes-flow.cabal --- a/yesod-routes-flow.cabal +++ b/yesod-routes-flow.cabal @@ -1,5 +1,5 @@ name: yesod-routes-flow -version: 1.1.1 +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 @@ -38,6 +38,7 @@ classy-prelude >= 0.7, system-fileio, system-filepath >= 0.4, + containers, text, yesod-core >= 1.4 && < 2.0 -- hs-source-dirs: