Skip to content

Commit

Permalink
Sync Routing code with yesod
Browse files Browse the repository at this point in the history
  • Loading branch information
ajnsit committed Feb 9, 2017
1 parent f38e18f commit 438678e
Show file tree
Hide file tree
Showing 4 changed files with 18 additions and 11 deletions.
2 changes: 1 addition & 1 deletion src/Routes/Parse.hs
Original file line number Diff line number Diff line change
Expand Up @@ -63,7 +63,7 @@ parseRoutesNoCheck = QuasiQuoter
-- invalid input.
resourcesFromString :: String -> [ResourceTree String]
resourcesFromString =
fst . parse 0 . filter (not . all (== ' ')) . lines
fst . parse 0 . filter (not . all (== ' ')) . lines . filter (/= '\r')
where
parse _ [] = ([], [])
parse indent (thisLine:otherLines)
Expand Down
14 changes: 9 additions & 5 deletions src/Routes/TH/RenderRoute.hs
Original file line number Diff line number Diff line change
Expand Up @@ -46,7 +46,9 @@ mkRouteCons rttypes =

mkRouteCon (ResourceParent name _check pieces children) = do
(cons, decs) <- mkRouteCons children
#if MIN_VERSION_template_haskell(2,11,0)
#if MIN_VERSION_template_haskell(2,12,0)
dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT [''Show, ''Read, ''Eq])
#elif MIN_VERSION_template_haskell(2,11,0)
dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]
#else
let dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq]
Expand All @@ -55,7 +57,7 @@ mkRouteCons rttypes =
where
con = NormalC (mkName name)
$ map (\x -> (notStrict, x))
$ concat [singles, [ConT $ mkName name]]
$ singles ++ [ConT $ mkName name]

singles = concatMap toSingle pieces
toSingle Static{} = []
Expand Down Expand Up @@ -99,7 +101,7 @@ mkRenderRouteClauses =
dyns <- replicateM cnt $ newName "dyn"
sub <-
case resourceDispatch res of
Subsite{} -> fmap return $ newName "sub"
Subsite{} -> return <$> newName "sub"
_ -> return []
let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub

Expand Down Expand Up @@ -136,7 +138,7 @@ mkRenderRouteClauses =
mkPieces _ _ [] _ = []
mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns
mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns
mkPieces _ _ ((Dynamic _) : _) [] = error "mkPieces 120"
mkPieces _ _ (Dynamic _ : _) [] = error "mkPieces 120"

-- | Generate the 'RenderRoute' instance.
--
Expand All @@ -153,7 +155,9 @@ mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
mkRenderRouteInstance' cxt typ ress = do
cls <- mkRenderRouteClauses ress
(cons, decs) <- mkRouteCons ress
#if MIN_VERSION_template_haskell(2,11,0)
#if MIN_VERSION_template_haskell(2,12,0)
did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT clazzes)
#elif MIN_VERSION_template_haskell(2,11,0)
did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT clazzes
#else
let did = DataInstD [] ''Route [typ] cons clazzes
Expand Down
9 changes: 6 additions & 3 deletions src/Routes/TH/RouteAttrs.hs
Original file line number Diff line number Diff line change
Expand Up @@ -9,6 +9,9 @@ import Routes.Class
import Language.Haskell.TH.Syntax
import Data.Set (fromList)
import Data.Text (pack)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif

mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec
mkRouteAttrsInstance typ ress = do
Expand All @@ -18,11 +21,11 @@ mkRouteAttrsInstance typ ress = do
]

goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause]
goTree front (ResourceLeaf res) = fmap return $ goRes front res
goTree front (ResourceLeaf res) = return <$> goRes front res
goTree front (ResourceParent name _check pieces trees) =
fmap concat $ mapM (goTree front') trees
concat <$> mapM (goTree front') trees
where
ignored = ((replicate toIgnore WildP ++) . return)
ignored = (replicate toIgnore WildP ++) . return
toIgnore = length $ filter isDynamic pieces
isDynamic Dynamic{} = True
isDynamic Static{} = False
Expand Down
4 changes: 2 additions & 2 deletions src/Routes/TH/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -53,11 +53,11 @@ data Piece typ = Static String | Dynamic typ
deriving Show

instance Functor Piece where
fmap _ (Static s) = (Static s)
fmap _ (Static s) = Static s
fmap f (Dynamic t) = Dynamic (f t)

instance Lift t => Lift (Piece t) where
lift (Static s) = [|Static $(lift s)|]
lift (Static s) = [|Static $(lift s)|]
lift (Dynamic t) = [|Dynamic $(lift t)|]

data Dispatch typ =
Expand Down

0 comments on commit 438678e

Please sign in to comment.