module Yesod.Routes.Parse
( parseRoutes
, parseRoutesFile
, parseRoutesNoCheck
, parseRoutesFileNoCheck
, parseType
, parseTypeTree
, TypeTree (..)
) where
import Language.Haskell.TH.Syntax
import Data.Char (isUpper)
import Language.Haskell.TH.Quote
import qualified System.IO as SIO
import Yesod.Routes.TH
import Yesod.Routes.Overlap (findOverlapNames)
import Data.List (foldl')
parseRoutes :: QuasiQuoter
parseRoutes = QuasiQuoter { quoteExp = x }
where
x s = do
let res = resourcesFromString s
case findOverlapNames res of
[] -> lift res
z -> error $ unlines $ "Overlapping routes: " : map show z
parseRoutesFile :: FilePath -> Q Exp
parseRoutesFile = parseRoutesFileWith parseRoutes
parseRoutesFileNoCheck :: FilePath -> Q Exp
parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck
parseRoutesFileWith :: QuasiQuoter -> FilePath -> Q Exp
parseRoutesFileWith qq fp = do
qAddDependentFile fp
s <- qRunIO $ readUtf8File fp
quoteExp qq s
readUtf8File :: FilePath -> IO String
readUtf8File fp = do
h <- SIO.openFile fp SIO.ReadMode
SIO.hSetEncoding h SIO.utf8_bom
SIO.hGetContents h
parseRoutesNoCheck :: QuasiQuoter
parseRoutesNoCheck = QuasiQuoter
{ quoteExp = lift . resourcesFromString
}
resourcesFromString :: String -> [ResourceTree String]
resourcesFromString =
fst . parse 0 . filter (not . all (== ' ')) . lines
where
parse _ [] = ([], [])
parse indent (thisLine:otherLines)
| length spaces < indent = ([], thisLine : otherLines)
| otherwise = (this others, remainder)
where
spaces = takeWhile (== ' ') thisLine
(others, remainder) = parse indent otherLines'
(this, otherLines') =
case takeWhile (/= "--") $ words thisLine of
[pattern, constr] | last constr == ':' ->
let (children, otherLines'') = parse (length spaces + 1) otherLines
(pieces, Nothing) = piecesFromString $ drop1Slash pattern
in ((ResourceParent (init constr) pieces children :), otherLines'')
(pattern:constr:rest) ->
let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
(attrs, rest') = takeAttrs rest
disp = dispatchFromString rest' mmulti
in ((ResourceLeaf (Resource constr pieces disp attrs):), otherLines)
[] -> (id, otherLines)
_ -> error $ "Invalid resource line: " ++ thisLine
takeAttrs :: [String] -> ([String], [String])
takeAttrs =
go id id
where
go x y [] = (x [], y [])
go x y (('!':attr):rest) = go (x . (attr:)) y rest
go x y (z:rest) = go x (y . (z:)) rest
dispatchFromString :: [String] -> Maybe String -> Dispatch String
dispatchFromString rest mmulti
| null rest = Methods mmulti []
| all (all isUpper) rest = Methods mmulti rest
dispatchFromString [subTyp, subFun] Nothing =
Subsite subTyp subFun
dispatchFromString [_, _] Just{} =
error "Subsites cannot have a multipiece"
dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest
drop1Slash :: String -> String
drop1Slash ('/':x) = x
drop1Slash x = x
piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe String)
piecesFromString "" = ([], Nothing)
piecesFromString x =
case (this, rest) of
(Left typ, ([], Nothing)) -> ([], Just typ)
(Left _, _) -> error "Multipiece must be last piece"
(Right piece, (pieces, mtyp)) -> (piece:pieces, mtyp)
where
(y, z) = break (== '/') x
this = pieceFromString y
rest = piecesFromString $ drop 1 z
parseType :: String -> Type
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)