{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE PatternGuards #-}
{-# 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 :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
x }
  where
    x :: String -> Q 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] -> Q Exp
forall t. Lift t => t -> Q Exp
lift [ResourceTree String]
res
            [(String, String)]
z -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q 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
    String
s <- IO String -> Q String
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
    QuasiQuoter -> String -> Q Exp
quoteExp QuasiQuoter
qq String
s

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

-- | Same as 'parseRoutes', but performs no overlap checking.
parseRoutesNoCheck :: QuasiQuoter
parseRoutesNoCheck :: QuasiQuoter
parseRoutesNoCheck = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = [ResourceTree String] -> Q Exp
forall t. Lift t => t -> Q 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 (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 (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 (t :: * -> *) a. Foldable t => t a -> Bool
null String
x = Maybe c
forall a. Maybe a
Nothing
                | String -> Char
forall a. [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. [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)
mapM String -> Maybe String
parseAttr [String]
rest ->
                    let ([ResourceTree String]
children, [String]
otherLines'') = Int -> [String] -> ([ResourceTree String], [String])
parse (String -> 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, Maybe String
Nothing, Bool
check) = String -> ([Piece String], Maybe String, Bool)
piecesFromStringCheck String
pattern
                     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 (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 (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 (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 (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 (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 :: [String]
resourceAttrs = [String]
noDupes [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Resource typ -> [String]
forall typ. Resource typ -> [String]
resourceAttrs Resource typ
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 c.
([String] -> c) -> ([String] -> c) -> [String] -> (c, c)
go [String] -> [String]
forall a. a -> a
id [String] -> [String]
forall a. a -> a
id
  where
    go :: ([String] -> c) -> ([String] -> c) -> [String] -> (c, c)
go [String] -> c
x [String] -> c
y [] = ([String] -> c
x [], [String] -> c
y [])
    go [String] -> c
x [String] -> c
y ((Char
'!':String
attr):[String]
rest) = ([String] -> c) -> ([String] -> c) -> [String] -> (c, c)
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] -> c
y [String]
rest
    go [String] -> c
x [String] -> c
y (String
z:[String]
rest) = ([String] -> c) -> ([String] -> c) -> [String] -> (c, c)
go [String] -> c
x ([String] -> c
y ([String] -> c) -> ([String] -> [String]) -> [String] -> c
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 (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 (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 (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
showList :: [TypeTree] -> String -> String
$cshowList :: [TypeTree] -> String -> String
show :: TypeTree -> String
$cshow :: TypeTree -> String
showsPrec :: Int -> TypeTree -> String -> String
$cshowsPrec :: Int -> 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
/= :: TypeTree -> TypeTree -> Bool
$c/= :: TypeTree -> TypeTree -> Bool
== :: TypeTree -> TypeTree -> Bool
$c== :: TypeTree -> TypeTree -> Bool
Eq)

toTypeTree :: [String] -> Maybe TypeTree
toTypeTree :: [String] -> Maybe TypeTree
toTypeTree [String]
orig = do
    (TypeTree
x, []) <- [String] -> Maybe (TypeTree, [String])
gos [String]
orig
    TypeTree -> Maybe TypeTree
forall (m :: * -> *) a. Monad m => a -> m a
return TypeTree
x
  where
    go :: [String] -> Maybe (TypeTree, [String])
go [] = Maybe (TypeTree, [String])
forall a. Maybe a
Nothing
    go (String
"(":[String]
xs) = do
        (TypeTree
x, [String]
rest) <- [String] -> Maybe (TypeTree, [String])
gos [String]
xs
        case [String]
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
        (TypeTree
x, [String]
rest) <- [String] -> Maybe (TypeTree, [String])
gos [String]
xs
        case [String]
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
        (TypeTree
t, [String]
xs2) <- [String] -> Maybe (TypeTree, [String])
go [String]
xs1
        ([TypeTree]
ts, [String]
xs3) <- ([TypeTree] -> [TypeTree])
-> [String] -> Maybe ([TypeTree], [String])
gos' [TypeTree] -> [TypeTree]
forall a. a -> a
id [String]
xs2
        (TypeTree, [String]) -> Maybe (TypeTree, [String])
forall a. a -> Maybe a
Just ((TypeTree -> TypeTree -> TypeTree)
-> TypeTree -> [TypeTree] -> TypeTree
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TypeTree -> TypeTree -> TypeTree
TTApp TypeTree
t [TypeTree]
ts, [String]
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 (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
            (TypeTree
t, [String]
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
            ([TypeTree] -> [TypeTree])
-> [String] -> Maybe ([TypeTree], [String])
gos' ([TypeTree] -> [TypeTree]
front ([TypeTree] -> [TypeTree])
-> ([TypeTree] -> [TypeTree]) -> [TypeTree] -> [TypeTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeTree
tTypeTree -> [TypeTree] -> [TypeTree]
forall a. a -> [a] -> [a]
:)) [String]
xs'

ttToType :: TypeTree -> Type
ttToType :: TypeTree -> Type
ttToType (TTTerm String
s) = String -> Type
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
nameToType :: String -> Type
nameToType String
t = if String -> Bool
isTvar String
t
               then Name -> Type
VarT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
t
               else Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ 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 (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. [a] -> [a]
init [b]
s, [b] -> b
forall a. [a] -> a
last [b]
s)