yesod-routes-flow-1.0.1: Yesod/Routes/Flow/Generator.hs
module Yesod.Routes.Flow.Generator
( genFlowRoutesPrefix
, genFlowRoutes
) where
import ClassyPrelude hiding (FilePath)
import Data.List (nubBy)
import Data.Function (on)
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) )
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
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"
-- route hackery..
fullTree = resourcesApp :: [ResourceTree String]
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
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 [] = []
renderRoutePieces pieces = intercalate "/" $ map renderRoutePiece pieces
renderRoutePiece p = case p of
Static st -> pack st :: Text
Dynamic "Text" -> ": string"
Dynamic "Int" -> ": number"
Dynamic d -> ": string"
isVariable r = length r > 1 && DT.head r == ':'
resRoute res = renderRoutePieces $ resourcePieces res
resName res = cleanName . pack $ resourceName 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) =
let rname = resName res in
-- 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)
where
pieces = DT.splitOn "/" routeString
variables = snd $ foldl' (\(i,prev) typ -> (i+1, prev <> [("a" <> tshow i, typ)]))
(0::Int, [])
(filter isVariable pieces)
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!"
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
-- 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))
where
fxn = resToCoffeeString parent (routePrefix <> "/" <> renderRoutePieces pieces <> "/")
res = map fxn children
resToCoffeeString parent routePrefix (ResourceParent name _ pieces children) =
([linkFromParent], Left $ resourceClassDef)
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"
<> " " <> "root: string;\n"
<> intercalate "\n" childMembers
<> " " <> parentMembers memberLinkFromParent
<> "\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
deriving instance (Show a) => Show (ResourceTree a)
deriving instance (Show a) => Show (FlatResource a)