yesod-routes-flow-1.0: Yesod/Routes/Flow/Generator.hs
module Yesod.Routes.Flow.Generator
( genFlowRoutesPrefix
, genFlowRoutes
) where
import ClassyPrelude
import Data.List (nubBy)
import Data.Function (on)
import Data.Text (dropWhileEnd)
import qualified Data.Text as DT
import Filesystem (createTree)
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
writeFile 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)