1{-# LANGUAGE TemplateHaskell #-} 2{-# LANGUAGE PatternGuards #-} 3{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter 4module Yesod.Routes.Parse 5 ( parseRoutes 6 , parseRoutesFile 7 , parseRoutesNoCheck 8 , parseRoutesFileNoCheck 9 , parseType 10 , parseTypeTree 11 , TypeTree (..) 12 , dropBracket 13 , nameToType 14 ) where 15 16import Language.Haskell.TH.Syntax 17import Data.Char (isUpper, isLower, isSpace) 18import Language.Haskell.TH.Quote 19import qualified System.IO as SIO 20import Yesod.Routes.TH 21import Yesod.Routes.Overlap (findOverlapNames) 22import Data.List (foldl', isPrefixOf) 23import Data.Maybe (mapMaybe) 24import qualified Data.Set as Set 25 26-- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for 27-- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the 28-- checking. See documentation site for details on syntax. 29parseRoutes :: QuasiQuoter 30parseRoutes = QuasiQuoter { quoteExp = x } 31 where 32 x s = do 33 let res = resourcesFromString s 34 case findOverlapNames res of 35 [] -> lift res 36 z -> error $ unlines $ "Overlapping routes: " : map show z 37 38parseRoutesFile :: FilePath -> Q Exp 39parseRoutesFile = parseRoutesFileWith parseRoutes 40 41parseRoutesFileNoCheck :: FilePath -> Q Exp 42parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck 43 44parseRoutesFileWith :: QuasiQuoter -> FilePath -> Q Exp 45parseRoutesFileWith qq fp = do 46 qAddDependentFile fp 47 s <- qRunIO $ readUtf8File fp 48 quoteExp qq s 49 50readUtf8File :: FilePath -> IO String 51readUtf8File fp = do 52 h <- SIO.openFile fp SIO.ReadMode 53 SIO.hSetEncoding h SIO.utf8_bom 54 SIO.hGetContents h 55 56-- | Same as 'parseRoutes', but performs no overlap checking. 57parseRoutesNoCheck :: QuasiQuoter 58parseRoutesNoCheck = QuasiQuoter 59 { quoteExp = lift . resourcesFromString 60 } 61 62-- | Converts a multi-line string to a set of resources. See documentation for 63-- the format of this string. This is a partial function which calls 'error' on 64-- invalid input. 65resourcesFromString :: String -> [ResourceTree String] 66resourcesFromString = 67 fst . parse 0 . filter (not . all (== ' ')) . foldr lineContinuations [] . lines . filter (/= '\r') 68 where 69 parse _ [] = ([], []) 70 parse indent (thisLine:otherLines) 71 | length spaces < indent = ([], thisLine : otherLines) 72 | otherwise = (this others, remainder) 73 where 74 parseAttr ('!':x) = Just x 75 parseAttr _ = Nothing 76 77 stripColonLast = 78 go id 79 where 80 go _ [] = Nothing 81 go front [x] 82 | null x = Nothing 83 | last x == ':' = Just $ front [init x] 84 | otherwise = Nothing 85 go front (x:xs) = go (front . (x:)) xs 86 87 spaces = takeWhile (== ' ') thisLine 88 (others, remainder) = parse indent otherLines' 89 (this, otherLines') = 90 case takeWhile (not . isPrefixOf "--") $ splitSpaces thisLine of 91 (pattern:rest0) 92 | Just (constr:rest) <- stripColonLast rest0 93 , Just attrs <- mapM parseAttr rest -> 94 let (children, otherLines'') = parse (length spaces + 1) otherLines 95 children' = addAttrs attrs children 96 (pieces, Nothing, check) = piecesFromStringCheck pattern 97 in ((ResourceParent constr check pieces children' :), otherLines'') 98 (pattern:constr:rest) -> 99 let (pieces, mmulti, check) = piecesFromStringCheck pattern 100 (attrs, rest') = takeAttrs rest 101 disp = dispatchFromString rest' mmulti 102 in ((ResourceLeaf (Resource constr pieces disp attrs check):), otherLines) 103 [] -> (id, otherLines) 104 _ -> error $ "Invalid resource line: " ++ thisLine 105 106-- | Splits a string by spaces, as long as the spaces are not enclosed by curly brackets (not recursive). 107splitSpaces :: String -> [String] 108splitSpaces "" = [] 109splitSpaces str = 110 let (rest, piece) = parse $ dropWhile isSpace str in 111 piece:(splitSpaces rest) 112 113 where 114 parse :: String -> ( String, String) 115 parse ('{':s) = fmap ('{':) $ parseBracket s 116 parse (c:s) | isSpace c = (s, []) 117 parse (c:s) = fmap (c:) $ parse s 118 parse "" = ("", "") 119 120 parseBracket :: String -> ( String, String) 121 parseBracket ('{':_) = error $ "Invalid resource line (nested curly bracket): " ++ str 122 parseBracket ('}':s) = fmap ('}':) $ parse s 123 parseBracket (c:s) = fmap (c:) $ parseBracket s 124 parseBracket "" = error $ "Invalid resource line (unclosed curly bracket): " ++ str 125 126piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool) 127piecesFromStringCheck s0 = 128 (pieces, mmulti, check) 129 where 130 (s1, check1) = stripBang s0 131 (pieces', mmulti') = piecesFromString $ drop1Slash s1 132 pieces = map snd pieces' 133 mmulti = fmap snd mmulti' 134 check = check1 && all fst pieces' && maybe True fst mmulti' 135 136 stripBang ('!':rest) = (rest, False) 137 stripBang x = (x, True) 138 139addAttrs :: [String] -> [ResourceTree String] -> [ResourceTree String] 140addAttrs attrs = 141 map goTree 142 where 143 goTree (ResourceLeaf res) = ResourceLeaf (goRes res) 144 goTree (ResourceParent w x y z) = ResourceParent w x y (map goTree z) 145 146 goRes res = 147 res { resourceAttrs = noDupes ++ resourceAttrs res } 148 where 149 usedKeys = Set.fromList $ map fst $ mapMaybe toPair $ resourceAttrs res 150 used attr = 151 case toPair attr of 152 Nothing -> False 153 Just (key, _) -> key `Set.member` usedKeys 154 noDupes = filter (not . used) attrs 155 156 toPair s = 157 case break (== '=') s of 158 (x, '=':y) -> Just (x, y) 159 _ -> Nothing 160 161-- | Take attributes out of the list and put them in the first slot in the 162-- result tuple. 163takeAttrs :: [String] -> ([String], [String]) 164takeAttrs = 165 go id id 166 where 167 go x y [] = (x [], y []) 168 go x y (('!':attr):rest) = go (x . (attr:)) y rest 169 go x y (z:rest) = go x (y . (z:)) rest 170 171dispatchFromString :: [String] -> Maybe String -> Dispatch String 172dispatchFromString rest mmulti 173 | null rest = Methods mmulti [] 174 | all (all isUpper) rest = Methods mmulti rest 175dispatchFromString [subTyp, subFun] Nothing = 176 Subsite subTyp subFun 177dispatchFromString [_, _] Just{} = 178 error "Subsites cannot have a multipiece" 179dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest 180 181drop1Slash :: String -> String 182drop1Slash ('/':x) = x 183drop1Slash x = x 184 185piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe (CheckOverlap, String)) 186piecesFromString "" = ([], Nothing) 187piecesFromString x = 188 case (this, rest) of 189 (Left typ, ([], Nothing)) -> ([], Just typ) 190 (Left _, _) -> error "Multipiece must be last piece" 191 (Right piece, (pieces, mtyp)) -> (piece:pieces, mtyp) 192 where 193 (y, z) = break (== '/') x 194 this = pieceFromString y 195 rest = piecesFromString $ drop 1 z 196 197parseType :: String -> Type 198parseType orig = 199 maybe (error $ "Invalid type: " ++ show orig) ttToType $ parseTypeTree orig 200 201parseTypeTree :: String -> Maybe TypeTree 202parseTypeTree orig = 203 toTypeTree pieces 204 where 205 pieces = filter (not . null) $ splitOn (\c -> c == '-' || c == ' ') $ addDashes orig 206 addDashes [] = [] 207 addDashes (x:xs) = 208 front $ addDashes xs 209 where 210 front rest 211 | x `elem` "()[]" = '-' : x : '-' : rest 212 | otherwise = x : rest 213 splitOn c s = 214 case y' of 215 _:y -> x : splitOn c y 216 [] -> [x] 217 where 218 (x, y') = break c s 219 220data TypeTree = TTTerm String 221 | TTApp TypeTree TypeTree 222 | TTList TypeTree 223 deriving (Show, Eq) 224 225toTypeTree :: [String] -> Maybe TypeTree 226toTypeTree orig = do 227 (x, []) <- gos orig 228 return x 229 where 230 go [] = Nothing 231 go ("(":xs) = do 232 (x, rest) <- gos xs 233 case rest of 234 ")":rest' -> Just (x, rest') 235 _ -> Nothing 236 go ("[":xs) = do 237 (x, rest) <- gos xs 238 case rest of 239 "]":rest' -> Just (TTList x, rest') 240 _ -> Nothing 241 go (x:xs) = Just (TTTerm x, xs) 242 243 gos xs1 = do 244 (t, xs2) <- go xs1 245 (ts, xs3) <- gos' id xs2 246 Just (foldl' TTApp t ts, xs3) 247 248 gos' front [] = Just (front [], []) 249 gos' front (x:xs) 250 | x `elem` words ") ]" = Just (front [], x:xs) 251 | otherwise = do 252 (t, xs') <- go $ x:xs 253 gos' (front . (t:)) xs' 254 255ttToType :: TypeTree -> Type 256ttToType (TTTerm s) = nameToType s 257ttToType (TTApp x y) = ttToType x `AppT` ttToType y 258ttToType (TTList t) = ListT `AppT` ttToType t 259 260nameToType :: String -> Type 261nameToType t@(h:_) | isLower h = VarT $ mkName t 262nameToType t = ConT $ mkName t 263 264pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String) 265pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x) 266pieceFromString ('!':'#':x) = Right $ (False, Dynamic $ dropBracket x) -- https://github.com/yesodweb/yesod/issues/652 267pieceFromString ('#':x) = Right $ (True, Dynamic $ dropBracket x) 268 269pieceFromString ('*':'!':x) = Left (False, x) 270pieceFromString ('+':'!':x) = Left (False, x) 271 272pieceFromString ('!':'*':x) = Left (False, x) 273pieceFromString ('!':'+':x) = Left (False, x) 274 275pieceFromString ('*':x) = Left (True, x) 276pieceFromString ('+':x) = Left (True, x) 277 278pieceFromString ('!':x) = Right $ (False, Static x) 279pieceFromString x = Right $ (True, Static x) 280 281dropBracket :: String -> String 282dropBracket str@('{':x) = case break (== '}') x of 283 (s, "}") -> s 284 _ -> error $ "Unclosed bracket ('{'): " ++ str 285dropBracket x = x 286 287-- | If this line ends with a backslash, concatenate it together with the next line. 288-- 289-- @since 1.6.8 290lineContinuations :: String -> [String] -> [String] 291lineContinuations this [] = [this] 292lineContinuations this below@(next:rest) = case unsnoc this of 293 Just (this', '\\') -> (this'++next):rest 294 _ -> this:below 295 where unsnoc s = if null s then Nothing else Just (init s, last s) 296