yesod-routes-flow 1.1.1 → 2.0
raw patch · 2 files changed
+169/−107 lines, 2 filesdep +containers
Dependencies added: containers
Files
- Yesod/Routes/Flow/Generator.hs +167/−106
- yesod-routes-flow.cabal +2/−1
Yesod/Routes/Flow/Generator.hs view
@@ -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)
yesod-routes-flow.cabal view
@@ -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: