yesod/yesod-routes/Yesod/Routes/Parse.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
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')

-- | 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
-- checking. See documentation site for details on syntax.
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

-- | Same as 'parseRoutes', but performs no overlap checking.
parseRoutesNoCheck :: QuasiQuoter
parseRoutesNoCheck = QuasiQuoter
    { quoteExp = lift . resourcesFromString
    }

-- | Convert a multi-line string to a set of resources. See documentation for
-- the format of this string. This is a partial function which calls 'error' on
-- invalid input.
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, check) = piecesFromStringCheck pattern
                     in ((ResourceParent (init constr) check pieces children :), otherLines'')
                (pattern:constr:rest) ->
                    let (pieces, mmulti, check) = piecesFromStringCheck pattern
                        (attrs, rest') = takeAttrs rest
                        disp = dispatchFromString rest' mmulti
                     in ((ResourceLeaf (Resource constr pieces disp attrs check):), otherLines)
                [] -> (id, otherLines)
                _ -> error $ "Invalid resource line: " ++ thisLine

piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool)
piecesFromStringCheck s0 =
    (pieces, mmulti, check)
  where
    (s1, check1) = stripBang s0
    (pieces', mmulti') = piecesFromString $ drop1Slash s1
    pieces = map snd pieces'
    mmulti = fmap snd mmulti'
    check = check1 && all fst pieces' && maybe True fst mmulti'

    stripBang ('!':rest) = (rest, False)
    stripBang x = (x, True)

-- | Take attributes out of the list and put them in the first slot in the
-- result tuple.
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 (CheckOverlap, 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 (CheckOverlap, String) (CheckOverlap, Piece String)
pieceFromString ('#':'!':x) = Right $ (False, Dynamic x)
pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652
pieceFromString ('#':x) = Right $ (True, Dynamic x)

pieceFromString ('*':'!':x) = Left (False, x)
pieceFromString ('+':'!':x) = Left (False, x)

pieceFromString ('!':'*':x) = Left (False, x)
pieceFromString ('!':'+':x) = Left (False, x)

pieceFromString ('*':x) = Left (True, x)
pieceFromString ('+':x) = Left (True, x)

pieceFromString ('!':x) = Right $ (False, Static x)
pieceFromString x = Right $ (True, Static x)