From 42943deab959db542a7ff050a7f7bf01391dd815 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Mon, 22 Apr 2013 15:01:52 +0300
Subject: [PATCH] Better route type parsing (fixes #471)

---
 yesod-core/test/YesodCoreTest/Links.hs | 27 +++++++++++
 yesod-routes/Yesod/Routes/Parse.hs     | 66 +++++++++++++++++++++++++-
 yesod-routes/test/main.hs              | 14 +++++-
 3 files changed, 105 insertions(+), 2 deletions(-)

diff --git a/yesod-core/test/YesodCoreTest/Links.hs b/yesod-core/test/YesodCoreTest/Links.hs
index f030707c..6dbe9ca7 100644
--- a/yesod-core/test/YesodCoreTest/Links.hs
+++ b/yesod-core/test/YesodCoreTest/Links.hs
@@ -17,8 +17,23 @@ mkYesod "Y" [parseRoutes|
 / RootR GET
 /single/#Text TextR GET
 /multi/*Texts TextsR GET
+
+/route-test-1/+[Text] RT1 GET
+/route-test-2/*Vector-String RT2 GET
+/route-test-3/*Vector-(Maybe-Int) RT3 GET
+/route-test-4/#(Foo-Int-Int) RT4 GET
 |]
 
+data Vector a = Vector
+    deriving (Show, Read, Eq)
+
+instance PathMultiPiece (Vector a)
+
+data Foo x y = Foo
+    deriving (Show, Read, Eq)
+
+instance PathPiece (Foo x y)
+
 instance Yesod Y
 
 getRootR :: Handler RepHtml
@@ -30,6 +45,18 @@ getTextR foo = defaultLayout $ toWidget [hamlet|%#{foo}%|]
 getTextsR :: [Text] -> Handler RepHtml
 getTextsR foos = defaultLayout $ toWidget [hamlet|%#{show foos}%|]
 
+getRT1 :: [Text] -> Handler ()
+getRT1 _ = return ()
+
+getRT2 :: Vector String -> Handler ()
+getRT2 _ = return ()
+
+getRT3 :: Vector (Maybe Int) -> Handler ()
+getRT3 _ = return ()
+
+getRT4 :: Foo Int Int -> Handler ()
+getRT4 _ = return ()
+
 linksTest :: Spec
 linksTest = describe "Test.Links" $ do
       it "linkToHome" case_linkToHome
diff --git a/yesod-routes/Yesod/Routes/Parse.hs b/yesod-routes/Yesod/Routes/Parse.hs
index 3c53cdec..9d8c01fb 100644
--- a/yesod-routes/Yesod/Routes/Parse.hs
+++ b/yesod-routes/Yesod/Routes/Parse.hs
@@ -7,6 +7,8 @@ module Yesod.Routes.Parse
     , parseRoutesNoCheck
     , parseRoutesFileNoCheck
     , parseType
+    , parseTypeTree
+    , TypeTree (..)
     ) where
 
 import Language.Haskell.TH.Syntax
@@ -15,6 +17,7 @@ import Language.Haskell.TH.Quote
 import qualified System.IO as SIO
 import Yesod.Routes.TH
 import Yesod.Routes.Overlap (findOverlapNames)
+import Data.List (foldl')
 
 -- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for
 -- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the
@@ -116,11 +119,72 @@ piecesFromString x =
     rest = piecesFromString $ drop 1 z
 
 parseType :: String -> Type
-parseType = ConT . mkName -- FIXME handle more complicated stuff
+parseType orig =
+    maybe (error $ "Invalid type: " ++ show orig) ttToType $ parseTypeTree orig
+
+parseTypeTree :: String -> Maybe TypeTree
+parseTypeTree orig =
+    toTypeTree pieces
+  where
+    pieces = filter (not . null) $ splitOn '-' $ addDashes orig
+    addDashes [] = []
+    addDashes (x:xs) =
+        front $ addDashes xs
+      where
+        front rest
+            | x `elem` "()[]" = '-' : x : '-' : rest
+            | otherwise = x : rest
+    splitOn c s =
+        case y' of
+            _:y -> x : splitOn c y
+            [] -> [x]
+      where
+        (x, y') = break (== c) s
+
+data TypeTree = TTTerm String
+              | TTApp TypeTree TypeTree
+              | TTList TypeTree
+    deriving (Show, Eq)
+
+toTypeTree :: [String] -> Maybe TypeTree
+toTypeTree orig = do
+    (x, []) <- gos orig
+    return x
+  where
+    go [] = Nothing
+    go ("(":xs) = do
+        (x, rest) <- gos xs
+        case rest of
+            ")":rest' -> Just (x, rest')
+            _ -> Nothing
+    go ("[":xs) = do
+        (x, rest) <- gos xs
+        case rest of
+            "]":rest' -> Just (TTList x, rest')
+            _ -> Nothing
+    go (x:xs) = Just (TTTerm x, xs)
+
+    gos xs1 = do
+        (t, xs2) <- go xs1
+        (ts, xs3) <- gos' id xs2
+        Just (foldl' TTApp t ts, xs3)
+
+    gos' front [] = Just (front [], [])
+    gos' front (x:xs)
+        | x `elem` words ") ]" = Just (front [], x:xs)
+        | otherwise = do
+            (t, xs') <- go $ x:xs
+            gos' (front . (t:)) xs'
+
+ttToType :: TypeTree -> Type
+ttToType (TTTerm s) = ConT $ mkName s
+ttToType (TTApp x y) = ttToType x `AppT` ttToType y
+ttToType (TTList t) = ListT `AppT` ttToType t
 
 pieceFromString :: String -> Either String (CheckOverlap, Piece String)
 pieceFromString ('#':'!':x) = Right $ (False, Dynamic x)
 pieceFromString ('#':x) = Right $ (True, Dynamic x)
 pieceFromString ('*':x) = Left x
+pieceFromString ('+':x) = Left x
 pieceFromString ('!':x) = Right $ (False, Static x)
 pieceFromString x = Right $ (True, Static x)
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index 38fe652b..efc996f7 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -17,7 +17,7 @@ import Yesod.Routes.Dispatch hiding (Static, Dynamic)
 import Yesod.Routes.Class hiding (Route)
 import qualified Yesod.Routes.Class as YRC
 import qualified Yesod.Routes.Dispatch as D
-import Yesod.Routes.Parse (parseRoutesNoCheck)
+import Yesod.Routes.Parse (parseRoutesNoCheck, parseTypeTree, TypeTree (..))
 import Yesod.Routes.Overlap (findOverlapNames)
 import Yesod.Routes.TH hiding (Dispatch)
 import Language.Haskell.TH.Syntax
@@ -353,6 +353,18 @@ main = hspec $ do
         it "hierarchy" $ do
             routeAttrs (ParentR (pack "ignored") ChildR) @?= Set.singleton (pack "child")
     hierarchy
+    describe "parseRouteTyoe" $ do
+        let success s t = it s $ parseTypeTree s @?= Just t
+            failure s = it s $ parseTypeTree s @?= Nothing
+        success "Int" $ TTTerm "Int"
+        success "(Int)" $ TTTerm "Int"
+        failure "(Int"
+        failure "(Int))"
+        failure "[Int"
+        failure "[Int]]"
+        success "[Int]" $ TTList $ TTTerm "Int"
+        success "Foo-Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar")
+        success "Foo-Bar-Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz"
 
 getRootR :: Text
 getRootR = pack "this is the root"