    {-# 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 $ "Overlapping routes: " ++ unlines (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 . 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

    -- | 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 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)