    {-# LANGUAGE PatternGuards #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE TupleSections #-}
    {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter

    module Yesod.Routes.Parse
        ( parseRoutes
        , parseRoutesFile
        , parseRoutesNoCheck
        , parseRoutesFileNoCheck
        , parseType
        , parseTypeTree
        , TypeTree (..)
        , dropBracket
        , nameToType
        , isTvar
        ) where

    import Language.Haskell.TH.Syntax
    import Data.Char (isUpper, isLower, isSpace)
    import Language.Haskell.TH.Quote
    import qualified System.IO as SIO
    import Yesod.Routes.TH
    import Yesod.Routes.Overlap (findOverlapNames)
    import Data.List (foldl', isPrefixOf)
    import Data.Maybe (mapMaybe)
    import qualified Data.Set as Set

    -- | 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
    parseRoutes = QuasiQuoter { quoteExp :: String -> Q Exp
    quoteExp = String -> Q Exp
    forall {m :: * -> *}. Quote m => String -> m Exp
    x }
      where
        x :: String -> m Exp
    x String
    s = do
            let res :: [ResourceTree String]
    res = String -> [ResourceTree String]
    resourcesFromString String
    s
            case [ResourceTree String] -> [(String, String)]
    forall t. [ResourceTree t] -> [(String, String)]
    findOverlapNames [ResourceTree String]
    res of
                [] -> [ResourceTree String] -> m Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => [ResourceTree String] -> m Exp
    lift [ResourceTree String]
    res
                [(String, String)]
    z -> String -> m Exp
    forall a. HasCallStack => String -> a
    error (String -> m Exp) -> String -> m Exp
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ String
    "Overlapping routes: " String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : ((String, String) -> String) -> [(String, String)] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (String, String) -> String
    forall a. Show a => a -> String
    show [(String, String)]
    z

    -- | Same as 'parseRoutes', but uses an external file instead of quasiquotation.
    --
    -- The recommended file extension is @.yesodroutes@.
    parseRoutesFile :: FilePath -> Q Exp
    parseRoutesFile :: String -> Q Exp
    parseRoutesFile = QuasiQuoter -> String -> Q Exp
    parseRoutesFileWith QuasiQuoter
    parseRoutes

    -- | Same as 'parseRoutesNoCheck', but uses an external file instead of quasiquotation.
    --
    -- The recommended file extension is @.yesodroutes@.
    parseRoutesFileNoCheck :: FilePath -> Q Exp
    parseRoutesFileNoCheck :: String -> Q Exp
    parseRoutesFileNoCheck = QuasiQuoter -> String -> Q Exp
    parseRoutesFileWith QuasiQuoter
    parseRoutesNoCheck

    parseRoutesFileWith :: QuasiQuoter -> FilePath -> Q Exp
    parseRoutesFileWith :: QuasiQuoter -> String -> Q Exp
    parseRoutesFileWith QuasiQuoter
    qq String
    fp = do
        String -> Q ()
    forall (m :: * -> *). Quasi m => String -> m ()
    qAddDependentFile String
    fp
        s <- IO String -> Q String
    forall a. IO a -> Q a
    forall (m :: * -> *) a. Quasi m => IO a -> m a
    qRunIO (IO String -> Q String) -> IO String -> Q String
    forall a b. (a -> b) -> a -> b
    $ String -> IO String
    readUtf8File String
    fp
        quoteExp qq s

    readUtf8File :: FilePath -> IO String
    readUtf8File :: String -> IO String
    readUtf8File String
    fp = do
        h <- String -> IOMode -> IO Handle
    SIO.openFile String
    fp IOMode
    SIO.ReadMode
        SIO.hSetEncoding h SIO.utf8_bom
        SIO.hGetContents h

    -- | Same as 'parseRoutes', but performs no overlap checking.
    parseRoutesNoCheck :: QuasiQuoter
    parseRoutesNoCheck :: QuasiQuoter
    parseRoutesNoCheck = QuasiQuoter
        { quoteExp :: String -> Q Exp
    quoteExp = [ResourceTree String] -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => [ResourceTree String] -> m Exp
    lift ([ResourceTree String] -> Q Exp)
    -> (String -> [ResourceTree String]) -> String -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [ResourceTree String]
    resourcesFromString
        }

    -- | Converts 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 :: String -> [ResourceTree String]
    resourcesFromString =
        ([ResourceTree String], [String]) -> [ResourceTree String]
    forall a b. (a, b) -> a
    fst (([ResourceTree String], [String]) -> [ResourceTree String])
    -> (String -> ([ResourceTree String], [String]))
    -> String
    -> [ResourceTree String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> [String] -> ([ResourceTree String], [String])
    parse Int
    0 ([String] -> ([ResourceTree String], [String]))
    -> (String -> [String])
    -> String
    -> ([ResourceTree String], [String])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> Bool) -> [String] -> [String]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    ' ')) ([String] -> [String])
    -> (String -> [String]) -> String -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> [String] -> [String])
    -> [String] -> [String] -> [String]
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr String -> [String] -> [String]
    lineContinuations [] ([String] -> [String])
    -> (String -> [String]) -> String -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String]
    lines (String -> [String]) -> (String -> String) -> String -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '\r')
      where
        parse :: Int -> [String] -> ([ResourceTree String], [String])
    parse Int
    _ [] = ([], [])
        parse Int
    indent (String
    thisLine:[String]
    otherLines)
            | String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    spaces Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    indent = ([], String
    thisLine String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : [String]
    otherLines)
            | Bool
    otherwise = ([ResourceTree String] -> [ResourceTree String]
    this [ResourceTree String]
    others, [String]
    remainder)
          where
            parseAttr :: String -> Maybe String
    parseAttr (Char
    '!':String
    x) = String -> Maybe String
    forall a. a -> Maybe a
    Just String
    x
            parseAttr String
    _ = Maybe String
    forall a. Maybe a
    Nothing

            stripColonLast :: [String] -> Maybe [String]
    stripColonLast =
                ([String] -> [String]) -> [String] -> Maybe [String]
    forall {c}. ([String] -> c) -> [String] -> Maybe c
    go [String] -> [String]
    forall a. a -> a
    id
              where
                go :: ([String] -> c) -> [String] -> Maybe c
    go [String] -> c
    _ [] = Maybe c
    forall a. Maybe a
    Nothing
                go [String] -> c
    front [String
    x]
                    | String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    x = Maybe c
    forall a. Maybe a
    Nothing
                    | String -> Char
    forall a. HasCallStack => [a] -> a
    last String
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    ':' = c -> Maybe c
    forall a. a -> Maybe a
    Just (c -> Maybe c) -> c -> Maybe c
    forall a b. (a -> b) -> a -> b
    $ [String] -> c
    front [String -> String
    forall a. HasCallStack => [a] -> [a]
    init String
    x]
                    | Bool
    otherwise = Maybe c
    forall a. Maybe a
    Nothing
                go [String] -> c
    front (String
    x:[String]
    xs) = ([String] -> c) -> [String] -> Maybe c
    go ([String] -> c
    front ([String] -> c) -> ([String] -> [String]) -> [String] -> c
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String
    xString -> [String] -> [String]
    forall a. a -> [a] -> [a]
    :)) [String]
    xs

            spaces :: String
    spaces = (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    ' ') String
    thisLine
            ([ResourceTree String]
    others, [String]
    remainder) = Int -> [String] -> ([ResourceTree String], [String])
    parse Int
    indent [String]
    otherLines'
            ([ResourceTree String] -> [ResourceTree String]
    this, [String]
    otherLines') =
                case (String -> Bool) -> [String] -> [String]
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (Bool -> Bool
    not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    isPrefixOf String
    "--") ([String] -> [String]) -> [String] -> [String]
    forall a b. (a -> b) -> a -> b
    $ String -> [String]
    splitSpaces String
    thisLine of
                    (String
    pattern:[String]
    rest0)
                        | Just (String
    constr:[String]
    rest) <- [String] -> Maybe [String]
    stripColonLast [String]
    rest0
                        , Just [String]
    attrs <- (String -> Maybe String) -> [String] -> Maybe [String]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM String -> Maybe String
    parseAttr [String]
    rest ->
                        let ([ResourceTree String]
    children, [String]
    otherLines'') = Int -> [String] -> ([ResourceTree String], [String])
    parse (String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    spaces Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) [String]
    otherLines
                            children' :: [ResourceTree String]
    children' = [String] -> [ResourceTree String] -> [ResourceTree String]
    addAttrs [String]
    attrs [ResourceTree String]
    children
                            ([Piece String]
    pieces, Bool
    check) =
                                case String -> ([Piece String], Maybe String, Bool)
    piecesFromStringCheck String
    pattern of
                                    ([Piece String]
    p, Maybe String
    Nothing, Bool
    c) -> ([Piece String]
    p, Bool
    c)
                                    -- FIXME: Give better error message
                                    ([Piece String], Maybe String, Bool)
    _ -> String -> ([Piece String], Bool)
    forall a. HasCallStack => String -> a
    error String
    "Invalid resource line: bad overlap"
                         in ((String
    -> Bool
    -> [Piece String]
    -> [ResourceTree String]
    -> ResourceTree String
    forall typ.
    String
    -> Bool -> [Piece typ] -> [ResourceTree typ] -> ResourceTree typ
    ResourceParent String
    constr Bool
    check [Piece String]
    pieces [ResourceTree String]
    children' ResourceTree String
    -> [ResourceTree String] -> [ResourceTree String]
    forall a. a -> [a] -> [a]
    :), [String]
    otherLines'')
                    (String
    pattern:String
    constr:[String]
    rest) ->
                        let ([Piece String]
    pieces, Maybe String
    mmulti, Bool
    check) = String -> ([Piece String], Maybe String, Bool)
    piecesFromStringCheck String
    pattern
                            ([String]
    attrs, [String]
    rest') = [String] -> ([String], [String])
    takeAttrs [String]
    rest
                            disp :: Dispatch String
    disp = [String] -> Maybe String -> Dispatch String
    dispatchFromString [String]
    rest' Maybe String
    mmulti
                         in ((Resource String -> ResourceTree String
    forall typ. Resource typ -> ResourceTree typ
    ResourceLeaf (String
    -> [Piece String]
    -> Dispatch String
    -> [String]
    -> Bool
    -> Resource String
    forall typ.
    String
    -> [Piece typ] -> Dispatch typ -> [String] -> Bool -> Resource typ
    Resource String
    constr [Piece String]
    pieces Dispatch String
    disp [String]
    attrs Bool
    check)ResourceTree String
    -> [ResourceTree String] -> [ResourceTree String]
    forall a. a -> [a] -> [a]
    :), [String]
    otherLines)
                    [] -> ([ResourceTree String] -> [ResourceTree String]
    forall a. a -> a
    id, [String]
    otherLines)
                    [String]
    _ -> String
    -> ([ResourceTree String] -> [ResourceTree String], [String])
    forall a. HasCallStack => String -> a
    error (String
     -> ([ResourceTree String] -> [ResourceTree String], [String]))
    -> String
    -> ([ResourceTree String] -> [ResourceTree String], [String])
    forall a b. (a -> b) -> a -> b
    $ String
    "Invalid resource line: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    thisLine

    -- | Splits a string by spaces, as long as the spaces are not enclosed by curly brackets (not recursive).
    splitSpaces :: String -> [String]
    splitSpaces :: String -> [String]
    splitSpaces String
    "" = []
    splitSpaces String
    str =
        let (String
    rest, String
    piece) = String -> (String, String)
    parse (String -> (String, String)) -> String -> (String, String)
    forall a b. (a -> b) -> a -> b
    $ (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace String
    str in
        String
    pieceString -> [String] -> [String]
    forall a. a -> [a] -> [a]
    :(String -> [String]
    splitSpaces String
    rest)

        where
            parse :: String -> ( String, String)
            parse :: String -> (String, String)
    parse (Char
    '{':String
    s) = (String -> String) -> (String, String) -> (String, String)
    forall a b. (a -> b) -> (String, a) -> (String, b)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Char
    '{'Char -> String -> String
    forall a. a -> [a] -> [a]
    :) ((String, String) -> (String, String))
    -> (String, String) -> (String, String)
    forall a b. (a -> b) -> a -> b
    $ String -> (String, String)
    parseBracket String
    s
            parse (Char
    c:String
    s) | Char -> Bool
    isSpace Char
    c = (String
    s, [])
            parse (Char
    c:String
    s) = (String -> String) -> (String, String) -> (String, String)
    forall a b. (a -> b) -> (String, a) -> (String, b)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Char
    cChar -> String -> String
    forall a. a -> [a] -> [a]
    :) ((String, String) -> (String, String))
    -> (String, String) -> (String, String)
    forall a b. (a -> b) -> a -> b
    $ String -> (String, String)
    parse String
    s
            parse String
    "" = (String
    "", String
    "")

            parseBracket :: String -> ( String, String)
            parseBracket :: String -> (String, String)
    parseBracket (Char
    '{':String
    _) = String -> (String, String)
    forall a. HasCallStack => String -> a
    error (String -> (String, String)) -> String -> (String, String)
    forall a b. (a -> b) -> a -> b
    $ String
    "Invalid resource line (nested curly bracket): " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    str
            parseBracket (Char
    '}':String
    s) = (String -> String) -> (String, String) -> (String, String)
    forall a b. (a -> b) -> (String, a) -> (String, b)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Char
    '}'Char -> String -> String
    forall a. a -> [a] -> [a]
    :) ((String, String) -> (String, String))
    -> (String, String) -> (String, String)
    forall a b. (a -> b) -> a -> b
    $ String -> (String, String)
    parse String
    s
            parseBracket (Char
    c:String
    s) = (String -> String) -> (String, String) -> (String, String)
    forall a b. (a -> b) -> (String, a) -> (String, b)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Char
    cChar -> String -> String
    forall a. a -> [a] -> [a]
    :) ((String, String) -> (String, String))
    -> (String, String) -> (String, String)
    forall a b. (a -> b) -> a -> b
    $ String -> (String, String)
    parseBracket String
    s
            parseBracket String
    "" = String -> (String, String)
    forall a. HasCallStack => String -> a
    error (String -> (String, String)) -> String -> (String, String)
    forall a b. (a -> b) -> a -> b
    $ String
    "Invalid resource line (unclosed curly bracket): " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    str

    piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool)
    piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool)
    piecesFromStringCheck String
    s0 =
        ([Piece String]
    pieces, Maybe String
    mmulti, Bool
    check)
      where
        (String
    s1, Bool
    check1) = String -> (String, Bool)
    stripBang String
    s0
        ([(Bool, Piece String)]
    pieces', Maybe (Bool, String)
    mmulti') = String -> ([(Bool, Piece String)], Maybe (Bool, String))
    piecesFromString (String -> ([(Bool, Piece String)], Maybe (Bool, String)))
    -> String -> ([(Bool, Piece String)], Maybe (Bool, String))
    forall a b. (a -> b) -> a -> b
    $ String -> String
    drop1Slash String
    s1
        pieces :: [Piece String]
    pieces = ((Bool, Piece String) -> Piece String)
    -> [(Bool, Piece String)] -> [Piece String]
    forall a b. (a -> b) -> [a] -> [b]
    map (Bool, Piece String) -> Piece String
    forall a b. (a, b) -> b
    snd [(Bool, Piece String)]
    pieces'
        mmulti :: Maybe String
    mmulti = ((Bool, String) -> String) -> Maybe (Bool, String) -> Maybe String
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Bool, String) -> String
    forall a b. (a, b) -> b
    snd Maybe (Bool, String)
    mmulti'
        check :: Bool
    check = Bool
    check1 Bool -> Bool -> Bool
    && ((Bool, Piece String) -> Bool) -> [(Bool, Piece String)] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (Bool, Piece String) -> Bool
    forall a b. (a, b) -> a
    fst [(Bool, Piece String)]
    pieces' Bool -> Bool -> Bool
    && Bool -> ((Bool, String) -> Bool) -> Maybe (Bool, String) -> Bool
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Bool
    True (Bool, String) -> Bool
    forall a b. (a, b) -> a
    fst Maybe (Bool, String)
    mmulti'

        stripBang :: String -> (String, Bool)
    stripBang (Char
    '!':String
    rest) = (String
    rest, Bool
    False)
        stripBang String
    x = (String
    x, Bool
    True)

    addAttrs :: [String] -> [ResourceTree String] -> [ResourceTree String]
    addAttrs :: [String] -> [ResourceTree String] -> [ResourceTree String]
    addAttrs [String]
    attrs =
        (ResourceTree String -> ResourceTree String)
    -> [ResourceTree String] -> [ResourceTree String]
    forall a b. (a -> b) -> [a] -> [b]
    map ResourceTree String -> ResourceTree String
    forall {typ}. ResourceTree typ -> ResourceTree typ
    goTree
      where
        goTree :: ResourceTree typ -> ResourceTree typ
    goTree (ResourceLeaf Resource typ
    res) = Resource typ -> ResourceTree typ
    forall typ. Resource typ -> ResourceTree typ
    ResourceLeaf (Resource typ -> Resource typ
    forall {typ}. Resource typ -> Resource typ
    goRes Resource typ
    res)
        goTree (ResourceParent String
    w Bool
    x [Piece typ]
    y [ResourceTree typ]
    z) = String
    -> Bool -> [Piece typ] -> [ResourceTree typ] -> ResourceTree typ
    forall typ.
    String
    -> Bool -> [Piece typ] -> [ResourceTree typ] -> ResourceTree typ
    ResourceParent String
    w Bool
    x [Piece typ]
    y ((ResourceTree typ -> ResourceTree typ)
    -> [ResourceTree typ] -> [ResourceTree typ]
    forall a b. (a -> b) -> [a] -> [b]
    map ResourceTree typ -> ResourceTree typ
    goTree [ResourceTree typ]
    z)

        goRes :: Resource typ -> Resource typ
    goRes Resource typ
    res =
            Resource typ
    res { resourceAttrs = noDupes ++ resourceAttrs res }
          where
            usedKeys :: Set String
    usedKeys = [String] -> Set String
    forall a. Ord a => [a] -> Set a
    Set.fromList ([String] -> Set String) -> [String] -> Set String
    forall a b. (a -> b) -> a -> b
    $ ((String, String) -> String) -> [(String, String)] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (String, String) -> String
    forall a b. (a, b) -> a
    fst ([(String, String)] -> [String]) -> [(String, String)] -> [String]
    forall a b. (a -> b) -> a -> b
    $ (String -> Maybe (String, String))
    -> [String] -> [(String, String)]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe String -> Maybe (String, String)
    toPair ([String] -> [(String, String)]) -> [String] -> [(String, String)]
    forall a b. (a -> b) -> a -> b
    $ Resource typ -> [String]
    forall typ. Resource typ -> [String]
    resourceAttrs Resource typ
    res
            used :: String -> Bool
    used String
    attr =
                case String -> Maybe (String, String)
    toPair String
    attr of
                    Maybe (String, String)
    Nothing -> Bool
    False
                    Just (String
    key, String
    _) -> String
    key String -> Set String -> Bool
    forall a. Ord a => a -> Set a -> Bool
    `Set.member` Set String
    usedKeys
            noDupes :: [String]
    noDupes = (String -> Bool) -> [String] -> [String]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Bool
    used) [String]
    attrs

        toPair :: String -> Maybe (String, String)
    toPair String
    s =
            case (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '=') String
    s of
                (String
    x, Char
    '=':String
    y) -> (String, String) -> Maybe (String, String)
    forall a. a -> Maybe a
    Just (String
    x, String
    y)
                (String, String)
    _ -> Maybe (String, String)
    forall a. Maybe a
    Nothing

    -- | Take attributes out of the list and put them in the first slot in the
    -- result tuple.
    takeAttrs :: [String] -> ([String], [String])
    takeAttrs :: [String] -> ([String], [String])
    takeAttrs =
        ([String] -> [String])
    -> ([String] -> [String]) -> [String] -> ([String], [String])
    forall {c} {b}.
    ([String] -> c) -> ([String] -> b) -> [String] -> (c, b)
    go [String] -> [String]
    forall a. a -> a
    id [String] -> [String]
    forall a. a -> a
    id
      where
        go :: ([String] -> c) -> ([String] -> b) -> [String] -> (c, b)
    go [String] -> c
    x [String] -> b
    y [] = ([String] -> c
    x [], [String] -> b
    y [])
        go [String] -> c
    x [String] -> b
    y ((Char
    '!':String
    attr):[String]
    rest) = ([String] -> c) -> ([String] -> b) -> [String] -> (c, b)
    go ([String] -> c
    x ([String] -> c) -> ([String] -> [String]) -> [String] -> c
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String
    attrString -> [String] -> [String]
    forall a. a -> [a] -> [a]
    :)) [String] -> b
    y [String]
    rest
        go [String] -> c
    x [String] -> b
    y (String
    z:[String]
    rest) = ([String] -> c) -> ([String] -> b) -> [String] -> (c, b)
    go [String] -> c
    x ([String] -> b
    y ([String] -> b) -> ([String] -> [String]) -> [String] -> b
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String
    zString -> [String] -> [String]
    forall a. a -> [a] -> [a]
    :)) [String]
    rest

    dispatchFromString :: [String] -> Maybe String -> Dispatch String
    dispatchFromString :: [String] -> Maybe String -> Dispatch String
    dispatchFromString [String]
    rest Maybe String
    mmulti
        | [String] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [String]
    rest = Maybe String -> [String] -> Dispatch String
    forall typ. Maybe typ -> [String] -> Dispatch typ
    Methods Maybe String
    mmulti []
        | (String -> Bool) -> [String] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all ((Char -> Bool) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Char -> Bool
    isUpper) [String]
    rest = Maybe String -> [String] -> Dispatch String
    forall typ. Maybe typ -> [String] -> Dispatch typ
    Methods Maybe String
    mmulti [String]
    rest
    dispatchFromString [String
    subTyp, String
    subFun] Maybe String
    Nothing =
        String -> String -> Dispatch String
    forall typ. typ -> String -> Dispatch typ
    Subsite String
    subTyp String
    subFun
    dispatchFromString [String
    _, String
    _] Just{} =
        String -> Dispatch String
    forall a. HasCallStack => String -> a
    error String
    "Subsites cannot have a multipiece"
    dispatchFromString [String]
    rest Maybe String
    _ = String -> Dispatch String
    forall a. HasCallStack => String -> a
    error (String -> Dispatch String) -> String -> Dispatch String
    forall a b. (a -> b) -> a -> b
    $ String
    "Invalid list of methods: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [String] -> String
    forall a. Show a => a -> String
    show [String]
    rest

    drop1Slash :: String -> String
    drop1Slash :: String -> String
    drop1Slash (Char
    '/':String
    x) = String
    x
    drop1Slash String
    x = String
    x

    piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe (CheckOverlap, String))
    piecesFromString :: String -> ([(Bool, Piece String)], Maybe (Bool, String))
    piecesFromString String
    "" = ([], Maybe (Bool, String)
    forall a. Maybe a
    Nothing)
    piecesFromString String
    x =
        case (Either (Bool, String) (Bool, Piece String)
    this, ([(Bool, Piece String)], Maybe (Bool, String))
    rest) of
            (Left (Bool, String)
    typ, ([], Maybe (Bool, String)
    Nothing)) -> ([], (Bool, String) -> Maybe (Bool, String)
    forall a. a -> Maybe a
    Just (Bool, String)
    typ)
            (Left (Bool, String)
    _, ([(Bool, Piece String)], Maybe (Bool, String))
    _) -> String -> ([(Bool, Piece String)], Maybe (Bool, String))
    forall a. HasCallStack => String -> a
    error String
    "Multipiece must be last piece"
            (Right (Bool, Piece String)
    piece, ([(Bool, Piece String)]
    pieces, Maybe (Bool, String)
    mtyp)) -> ((Bool, Piece String)
    piece(Bool, Piece String)
    -> [(Bool, Piece String)] -> [(Bool, Piece String)]
    forall a. a -> [a] -> [a]
    :[(Bool, Piece String)]
    pieces, Maybe (Bool, String)
    mtyp)
      where
        (String
    y, String
    z) = (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '/') String
    x
        this :: Either (Bool, String) (Bool, Piece String)
    this = String -> Either (Bool, String) (Bool, Piece String)
    pieceFromString String
    y
        rest :: ([(Bool, Piece String)], Maybe (Bool, String))
    rest = String -> ([(Bool, Piece String)], Maybe (Bool, String))
    piecesFromString (String -> ([(Bool, Piece String)], Maybe (Bool, String)))
    -> String -> ([(Bool, Piece String)], Maybe (Bool, String))
    forall a b. (a -> b) -> a -> b
    $ Int -> String -> String
    forall a. Int -> [a] -> [a]
    drop Int
    1 String
    z

    parseType :: String -> Type
    parseType :: String -> Type
    parseType String
    orig =
        Type -> (TypeTree -> Type) -> Maybe TypeTree -> Type
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (String -> Type
    forall a. HasCallStack => String -> a
    error (String -> Type) -> String -> Type
    forall a b. (a -> b) -> a -> b
    $ String
    "Invalid type: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show String
    orig) TypeTree -> Type
    ttToType (Maybe TypeTree -> Type) -> Maybe TypeTree -> Type
    forall a b. (a -> b) -> a -> b
    $ String -> Maybe TypeTree
    parseTypeTree String
    orig

    parseTypeTree :: String -> Maybe TypeTree
    parseTypeTree :: String -> Maybe TypeTree
    parseTypeTree String
    orig =
        [String] -> Maybe TypeTree
    toTypeTree [String]
    pieces
      where
        pieces :: [String]
    pieces = (String -> Bool) -> [String] -> [String]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null) ([String] -> [String]) -> [String] -> [String]
    forall a b. (a -> b) -> a -> b
    $ (Char -> Bool) -> String -> [String]
    forall {a}. (a -> Bool) -> [a] -> [[a]]
    splitOn (\Char
    c -> Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '-' Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    ' ') (String -> [String]) -> String -> [String]
    forall a b. (a -> b) -> a -> b
    $ String -> String
    addDashes String
    orig
        addDashes :: String -> String
    addDashes [] = []
        addDashes (Char
    x:String
    xs) =
            String -> String
    front (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ String -> String
    addDashes String
    xs
          where
            front :: String -> String
    front String
    rest
                | Char
    x Char -> String -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` String
    "()[]" = Char
    '-' Char -> String -> String
    forall a. a -> [a] -> [a]
    : Char
    x Char -> String -> String
    forall a. a -> [a] -> [a]
    : Char
    '-' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rest
                | Bool
    otherwise = Char
    x Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    rest
        splitOn :: (a -> Bool) -> [a] -> [[a]]
    splitOn a -> Bool
    c [a]
    s =
            case [a]
    y' of
                a
    _:[a]
    y -> [a]
    x [a] -> [[a]] -> [[a]]
    forall a. a -> [a] -> [a]
    : (a -> Bool) -> [a] -> [[a]]
    splitOn a -> Bool
    c [a]
    y
                [] -> [[a]
    x]
          where
            ([a]
    x, [a]
    y') = (a -> Bool) -> [a] -> ([a], [a])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break a -> Bool
    c [a]
    s

    data TypeTree = TTTerm String
                  | TTApp TypeTree TypeTree
                  | TTList TypeTree
        deriving (Int -> TypeTree -> String -> String
    [TypeTree] -> String -> String
    TypeTree -> String
    (Int -> TypeTree -> String -> String)
    -> (TypeTree -> String)
    -> ([TypeTree] -> String -> String)
    -> Show TypeTree
    forall a.
    (Int -> a -> String -> String)
    -> (a -> String) -> ([a] -> String -> String) -> Show a
    $cshowsPrec :: Int -> TypeTree -> String -> String
    showsPrec :: Int -> TypeTree -> String -> String
    $cshow :: TypeTree -> String
    show :: TypeTree -> String
    $cshowList :: [TypeTree] -> String -> String
    showList :: [TypeTree] -> String -> String
    Show, TypeTree -> TypeTree -> Bool
    (TypeTree -> TypeTree -> Bool)
    -> (TypeTree -> TypeTree -> Bool) -> Eq TypeTree
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: TypeTree -> TypeTree -> Bool
    == :: TypeTree -> TypeTree -> Bool
    $c/= :: TypeTree -> TypeTree -> Bool
    /= :: TypeTree -> TypeTree -> Bool
    Eq)

    toTypeTree :: [String] -> Maybe TypeTree
    toTypeTree :: [String] -> Maybe TypeTree
    toTypeTree [String]
    orig = do
        (x, []) <- [String] -> Maybe (TypeTree, [String])
    gos [String]
    orig
        return x
      where
        go :: [String] -> Maybe (TypeTree, [String])
    go [] = Maybe (TypeTree, [String])
    forall a. Maybe a
    Nothing
        go (String
    "(":[String]
    xs) = do
            (x, rest) <- [String] -> Maybe (TypeTree, [String])
    gos [String]
    xs
            case rest of
                String
    ")":[String]
    rest' -> (TypeTree, [String]) -> Maybe (TypeTree, [String])
    forall a. a -> Maybe a
    Just (TypeTree
    x, [String]
    rest')
                [String]
    _ -> Maybe (TypeTree, [String])
    forall a. Maybe a
    Nothing
        go (String
    "[":[String]
    xs) = do
            (x, rest) <- [String] -> Maybe (TypeTree, [String])
    gos [String]
    xs
            case rest of
                String
    "]":[String]
    rest' -> (TypeTree, [String]) -> Maybe (TypeTree, [String])
    forall a. a -> Maybe a
    Just (TypeTree -> TypeTree
    TTList TypeTree
    x, [String]
    rest')
                [String]
    _ -> Maybe (TypeTree, [String])
    forall a. Maybe a
    Nothing
        go (String
    x:[String]
    xs) = (TypeTree, [String]) -> Maybe (TypeTree, [String])
    forall a. a -> Maybe a
    Just (String -> TypeTree
    TTTerm String
    x, [String]
    xs)

        gos :: [String] -> Maybe (TypeTree, [String])
    gos [String]
    xs1 = do
            (t, xs2) <- [String] -> Maybe (TypeTree, [String])
    go [String]
    xs1
            (ts, xs3) <- gos' id xs2
            Just (foldl' TTApp t ts, xs3)

        gos' :: ([TypeTree] -> [TypeTree])
    -> [String] -> Maybe ([TypeTree], [String])
    gos' [TypeTree] -> [TypeTree]
    front [] = ([TypeTree], [String]) -> Maybe ([TypeTree], [String])
    forall a. a -> Maybe a
    Just ([TypeTree] -> [TypeTree]
    front [], [])
        gos' [TypeTree] -> [TypeTree]
    front (String
    x:[String]
    xs)
            | String
    x String -> [String] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` String -> [String]
    words String
    ") ]" = ([TypeTree], [String]) -> Maybe ([TypeTree], [String])
    forall a. a -> Maybe a
    Just ([TypeTree] -> [TypeTree]
    front [], String
    xString -> [String] -> [String]
    forall a. a -> [a] -> [a]
    :[String]
    xs)
            | Bool
    otherwise = do
                (t, xs') <- [String] -> Maybe (TypeTree, [String])
    go ([String] -> Maybe (TypeTree, [String]))
    -> [String] -> Maybe (TypeTree, [String])
    forall a b. (a -> b) -> a -> b
    $ String
    xString -> [String] -> [String]
    forall a. a -> [a] -> [a]
    :[String]
    xs
                gos' (front . (t:)) xs'

    ttToType :: TypeTree -> Type
    ttToType :: TypeTree -> Type
    ttToType (TTTerm String
    s) = (Type, Name) -> Type
    forall a b. (a, b) -> a
    fst ((Type, Name) -> Type) -> (Type, Name) -> Type
    forall a b. (a -> b) -> a -> b
    $ String -> (Type, Name)
    nameToType String
    s
    ttToType (TTApp TypeTree
    x TypeTree
    y) = TypeTree -> Type
    ttToType TypeTree
    x Type -> Type -> Type
    `AppT` TypeTree -> Type
    ttToType TypeTree
    y
    ttToType (TTList TypeTree
    t) = Type
    ListT Type -> Type -> Type
    `AppT` TypeTree -> Type
    ttToType TypeTree
    t

    nameToType :: String -> (Type, Name)
    nameToType :: String -> (Type, Name)
    nameToType String
    t = (, Name
    nm) (Type -> (Type, Name)) -> Type -> (Type, Name)
    forall a b. (a -> b) -> a -> b
    $ if String -> Bool
    isTvar String
    t
                   then Name -> Type
    VarT Name
    nm
                   else Name -> Type
    ConT Name
    nm
        where nm :: Name
    nm = String -> Name
    mkName String
    t

    isTvar :: String -> Bool
    isTvar :: String -> Bool
    isTvar (Char
    h:String
    _) = Char -> Bool
    isLower Char
    h
    isTvar String
    _     = Bool
    False

    pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)
    pieceFromString :: String -> Either (Bool, String) (Bool, Piece String)
    pieceFromString (Char
    '#':Char
    '!':String
    x) = (Bool, Piece String) -> Either (Bool, String) (Bool, Piece String)
    forall a b. b -> Either a b
    Right ((Bool, Piece String)
     -> Either (Bool, String) (Bool, Piece String))
    -> (Bool, Piece String)
    -> Either (Bool, String) (Bool, Piece String)
    forall a b. (a -> b) -> a -> b
    $ (Bool
    False, String -> Piece String
    forall typ. typ -> Piece typ
    Dynamic (String -> Piece String) -> String -> Piece String
    forall a b. (a -> b) -> a -> b
    $ String -> String
    dropBracket String
    x)
    pieceFromString (Char
    '!':Char
    '#':String
    x) = (Bool, Piece String) -> Either (Bool, String) (Bool, Piece String)
    forall a b. b -> Either a b
    Right ((Bool, Piece String)
     -> Either (Bool, String) (Bool, Piece String))
    -> (Bool, Piece String)
    -> Either (Bool, String) (Bool, Piece String)
    forall a b. (a -> b) -> a -> b
    $ (Bool
    False, String -> Piece String
    forall typ. typ -> Piece typ
    Dynamic (String -> Piece String) -> String -> Piece String
    forall a b. (a -> b) -> a -> b
    $ String -> String
    dropBracket String
    x) -- https://github.com/yesodweb/yesod/issues/652
    pieceFromString (Char
    '#':String
    x) = (Bool, Piece String) -> Either (Bool, String) (Bool, Piece String)
    forall a b. b -> Either a b
    Right ((Bool, Piece String)
     -> Either (Bool, String) (Bool, Piece String))
    -> (Bool, Piece String)
    -> Either (Bool, String) (Bool, Piece String)
    forall a b. (a -> b) -> a -> b
    $ (Bool
    True, String -> Piece String
    forall typ. typ -> Piece typ
    Dynamic (String -> Piece String) -> String -> Piece String
    forall a b. (a -> b) -> a -> b
    $ String -> String
    dropBracket String
    x)

    pieceFromString (Char
    '*':Char
    '!':String
    x) = (Bool, String) -> Either (Bool, String) (Bool, Piece String)
    forall a b. a -> Either a b
    Left (Bool
    False, String
    x)
    pieceFromString (Char
    '+':Char
    '!':String
    x) = (Bool, String) -> Either (Bool, String) (Bool, Piece String)
    forall a b. a -> Either a b
    Left (Bool
    False, String
    x)

    pieceFromString (Char
    '!':Char
    '*':String
    x) = (Bool, String) -> Either (Bool, String) (Bool, Piece String)
    forall a b. a -> Either a b
    Left (Bool
    False, String
    x)
    pieceFromString (Char
    '!':Char
    '+':String
    x) = (Bool, String) -> Either (Bool, String) (Bool, Piece String)
    forall a b. a -> Either a b
    Left (Bool
    False, String
    x)

    pieceFromString (Char
    '*':String
    x) = (Bool, String) -> Either (Bool, String) (Bool, Piece String)
    forall a b. a -> Either a b
    Left (Bool
    True, String
    x)
    pieceFromString (Char
    '+':String
    x) = (Bool, String) -> Either (Bool, String) (Bool, Piece String)
    forall a b. a -> Either a b
    Left (Bool
    True, String
    x)

    pieceFromString (Char
    '!':String
    x) = (Bool, Piece String) -> Either (Bool, String) (Bool, Piece String)
    forall a b. b -> Either a b
    Right ((Bool, Piece String)
     -> Either (Bool, String) (Bool, Piece String))
    -> (Bool, Piece String)
    -> Either (Bool, String) (Bool, Piece String)
    forall a b. (a -> b) -> a -> b
    $ (Bool
    False, String -> Piece String
    forall typ. String -> Piece typ
    Static String
    x)
    pieceFromString String
    x = (Bool, Piece String) -> Either (Bool, String) (Bool, Piece String)
    forall a b. b -> Either a b
    Right ((Bool, Piece String)
     -> Either (Bool, String) (Bool, Piece String))
    -> (Bool, Piece String)
    -> Either (Bool, String) (Bool, Piece String)
    forall a b. (a -> b) -> a -> b
    $ (Bool
    True, String -> Piece String
    forall typ. String -> Piece typ
    Static String
    x)

    dropBracket :: String -> String
    dropBracket :: String -> String
    dropBracket str :: String
    str@(Char
    '{':String
    x) = case (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '}') String
    x of
        (String
    s, String
    "}") -> String
    s
        (String, String)
    _ -> String -> String
    forall a. HasCallStack => String -> a
    error (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ String
    "Unclosed bracket ('{'): " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    str
    dropBracket String
    x = String
    x

    -- | If this line ends with a backslash, concatenate it together with the next line.
    --
    -- @since 1.6.8
    lineContinuations :: String -> [String] -> [String]
    lineContinuations :: String -> [String] -> [String]
    lineContinuations String
    this [] = [String
    this]
    lineContinuations String
    this below :: [String]
    below@(String
    next:[String]
    rest) = case String -> Maybe (String, Char)
    forall {b}. [b] -> Maybe ([b], b)
    unsnoc String
    this of
        Just (String
    this', Char
    '\\') -> (String
    this' String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    next)String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    :[String]
    rest
        Maybe (String, Char)
    _ -> String
    thisString -> [String] -> [String]
    forall a. a -> [a] -> [a]
    :[String]
    below
      where unsnoc :: [b] -> Maybe ([b], b)
    unsnoc [b]
    s = if [b] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [b]
    s then Maybe ([b], b)
    forall a. Maybe a
    Nothing else ([b], b) -> Maybe ([b], b)
    forall a. a -> Maybe a
    Just ([b] -> [b]
    forall a. HasCallStack => [a] -> [a]
    init [b]
    s, [b] -> b
    forall a. HasCallStack => [a] -> a
    last [b]
    s)