{-# 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 { quoteExp :: String -> Q Exp
quoteExp = 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 forall t. [ResourceTree t] -> [(String, String)]
findOverlapNames [ResourceTree String]
res of
            [] -> forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift [ResourceTree String]
res
            [(String, String)]
z -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ String
"Overlapping routes: " forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map 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
    forall (m :: * -> *). Quasi m => String -> m ()
qAddDependentFile String
fp
    String
s <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO 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
    { quoteExp :: String -> Q Exp
quoteExp = forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift 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 =
    forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> ([ResourceTree String], [String])
parse Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== Char
' ')) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> [String] -> [String]
lineContinuations [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (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)
        | forall (t :: * -> *) a. Foldable t => t a -> Int
length String
spaces forall a. Ord a => a -> a -> Bool
< Int
indent = ([], String
thisLine 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) = forall a. a -> Maybe a
Just String
x
        parseAttr String
_ = forall a. Maybe a
Nothing

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

        spaces :: String
spaces = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (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 forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf 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 <- 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 (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
spaces 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 ((forall typ.
String
-> Bool -> [Piece typ] -> [ResourceTree typ] -> ResourceTree typ
ResourceParent String
constr Bool
check [Piece String]
pieces [ResourceTree String]
children' 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 ((forall typ. Resource typ -> ResourceTree typ
ResourceLeaf (forall typ.
String
-> [Piece typ] -> Dispatch typ -> [String] -> Bool -> Resource typ
Resource String
constr [Piece String]
pieces Dispatch String
disp [String]
attrs Bool
check)forall a. a -> [a] -> [a]
:), [String]
otherLines)
                [] -> (forall a. a -> a
id, [String]
otherLines)
                [String]
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Invalid resource line: " 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 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
str in
    String
pieceforall a. a -> [a] -> [a]
:(String -> [String]
splitSpaces String
rest)

    where 
        parse :: String -> ( String, String)
        parse :: String -> (String, String)
parse (Char
'{':String
s) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char
'{'forall a. a -> [a] -> [a]
:) 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) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char
cforall a. a -> [a] -> [a]
:) 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
_) = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Invalid resource line (nested curly bracket): " forall a. [a] -> [a] -> [a]
++ String
str
        parseBracket (Char
'}':String
s) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char
'}'forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ String -> (String, String)
parse String
s
        parseBracket (Char
c:String
s) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char
cforall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ String -> (String, String)
parseBracket String
s
        parseBracket String
"" = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Invalid resource line (unclosed curly bracket): " 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 forall a b. (a -> b) -> a -> b
$ String -> String
drop1Slash String
s1
    pieces :: [Piece String]
pieces = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, Piece String)]
pieces'
    mmulti :: Maybe String
mmulti = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Maybe (Bool, String)
mmulti'
    check :: Bool
check = Bool
check1 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a b. (a, b) -> a
fst [(Bool, Piece String)]
pieces' Bool -> Bool -> Bool
&& forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True 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 =
    forall a b. (a -> b) -> [a] -> [b]
map forall {typ}. ResourceTree typ -> ResourceTree typ
goTree
  where
    goTree :: ResourceTree typ -> ResourceTree typ
goTree (ResourceLeaf Resource typ
res) = forall typ. Resource typ -> ResourceTree typ
ResourceLeaf (forall {typ}. Resource typ -> Resource typ
goRes Resource typ
res)
    goTree (ResourceParent String
w Bool
x [Piece typ]
y [ResourceTree typ]
z) = forall typ.
String
-> Bool -> [Piece typ] -> [ResourceTree typ] -> ResourceTree typ
ResourceParent String
w Bool
x [Piece typ]
y (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 forall a. [a] -> [a] -> [a]
++ forall typ. Resource typ -> [String]
resourceAttrs Resource typ
res }
      where
        usedKeys :: Set String
usedKeys = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe (String, String)
toPair forall a b. (a -> b) -> a -> b
$ 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 forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
usedKeys
        noDupes :: [String]
noDupes = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
used) [String]
attrs

    toPair :: String -> Maybe (String, String)
toPair String
s =
        case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'=') String
s of
            (String
x, Char
'=':String
y) -> forall a. a -> Maybe a
Just (String
x, String
y)
            (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 =
    forall {c} {b}.
([String] -> c) -> ([String] -> b) -> [String] -> (c, b)
go forall a. a -> a
id 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
attrforall 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
zforall a. a -> [a] -> [a]
:)) [String]
rest

dispatchFromString :: [String] -> Maybe String -> Dispatch String
dispatchFromString :: [String] -> Maybe String -> Dispatch String
dispatchFromString [String]
rest Maybe String
mmulti
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
rest = forall typ. Maybe typ -> [String] -> Dispatch typ
Methods Maybe String
mmulti []
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isUpper) [String]
rest = forall typ. Maybe typ -> [String] -> Dispatch typ
Methods Maybe String
mmulti [String]
rest
dispatchFromString [String
subTyp, String
subFun] Maybe String
Nothing =
    forall typ. typ -> String -> Dispatch typ
Subsite String
subTyp String
subFun
dispatchFromString [String
_, String
_] Just{} =
    forall a. HasCallStack => String -> a
error String
"Subsites cannot have a multipiece"
dispatchFromString [String]
rest Maybe String
_ = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Invalid list of methods: " forall a. [a] -> [a] -> [a]
++ 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
"" = ([], 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)) -> ([], forall a. a -> Maybe a
Just (Bool, String)
typ)
        (Left (Bool, 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)
pieceforall a. a -> [a] -> [a]
:[(Bool, Piece String)]
pieces, Maybe (Bool, String)
mtyp)
  where
    (String
y, String
z) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (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 forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 String
z

parseType :: String -> Type
parseType :: String -> Type
parseType String
orig =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Invalid type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
orig) TypeTree -> Type
ttToType 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$ forall {a}. (a -> Bool) -> [a] -> [[a]]
splitOn (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
' ') forall a b. (a -> b) -> a -> b
$ String -> String
addDashes String
orig
    addDashes :: String -> String
addDashes [] = []
    addDashes (Char
x:String
xs) =
        String -> String
front forall a b. (a -> b) -> a -> b
$ String -> String
addDashes String
xs
      where
        front :: String -> String
front String
rest
            | Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"()[]" = Char
'-' forall a. a -> [a] -> [a]
: Char
x forall a. a -> [a] -> [a]
: Char
'-' forall a. a -> [a] -> [a]
: String
rest
            | Bool
otherwise = Char
x 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 forall a. a -> [a] -> [a]
: (a -> Bool) -> [a] -> [[a]]
splitOn a -> Bool
c [a]
y
            [] -> [[a]
x]
      where
        ([a]
x, [a]
y') = 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
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
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
    forall (m :: * -> *) a. Monad m => a -> m a
return TypeTree
x
  where
    go :: [String] -> Maybe (TypeTree, [String])
go [] = 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' -> forall a. a -> Maybe a
Just (TypeTree
x, [String]
rest')
            [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' -> forall a. a -> Maybe a
Just (TypeTree -> TypeTree
TTList TypeTree
x, [String]
rest')
            [String]
_ -> forall a. Maybe a
Nothing
    go (String
x:[String]
xs) = 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' forall a. a -> a
id [String]
xs2
        forall a. a -> Maybe a
Just (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 [] = forall a. a -> Maybe a
Just ([TypeTree] -> [TypeTree]
front [], [])
    gos' [TypeTree] -> [TypeTree]
front (String
x:[String]
xs)
        | String
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String -> [String]
words String
") ]" = forall a. a -> Maybe a
Just ([TypeTree] -> [TypeTree]
front [], String
xforall a. a -> [a] -> [a]
:[String]
xs)
        | Bool
otherwise = do
            (TypeTree
t, [String]
xs') <- [String] -> Maybe (TypeTree, [String])
go forall a b. (a -> b) -> a -> b
$ String
xforall a. a -> [a] -> [a]
:[String]
xs
            ([TypeTree] -> [TypeTree])
-> [String] -> Maybe ([TypeTree], [String])
gos' ([TypeTree] -> [TypeTree]
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeTree
tforall 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 forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
t
               else Name -> Type
ConT 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) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ (Bool
False, forall typ. typ -> Piece typ
Dynamic forall a b. (a -> b) -> a -> b
$ String -> String
dropBracket String
x)
pieceFromString (Char
'!':Char
'#':String
x) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ (Bool
False, forall typ. typ -> Piece typ
Dynamic forall a b. (a -> b) -> a -> b
$ String -> String
dropBracket String
x) -- https://github.com/yesodweb/yesod/issues/652
pieceFromString (Char
'#':String
x) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ (Bool
True, forall typ. typ -> Piece typ
Dynamic forall a b. (a -> b) -> a -> b
$ String -> String
dropBracket String
x)

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

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

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

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

dropBracket :: String -> String
dropBracket :: String -> String
dropBracket str :: String
str@(Char
'{':String
x) = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'}') String
x of
    (String
s, String
"}") -> String
s
    (String, String)
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Unclosed bracket ('{'): " 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 forall {b}. [b] -> Maybe ([b], b)
unsnoc String
this of
    Just (String
this', Char
'\\') -> (String
this'forall a. [a] -> [a] -> [a]
++String
next)forall a. a -> [a] -> [a]
:[String]
rest
    Maybe (String, Char)
_ -> String
thisforall a. a -> [a] -> [a]
:[String]
below
  where unsnoc :: [b] -> Maybe ([b], b)
unsnoc [b]
s = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [b]
s then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (forall a. [a] -> [a]
init [b]
s, forall a. [a] -> a
last [b]
s)