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