{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Yesod.Internal.RouteParsing
    ( createRoutes
    , createRender
    , createParse
    , createDispatch
    , Pieces (..)
    , THResource
    , parseRoutes
    , parseRoutesFile
    , parseRoutesNoCheck
    , parseRoutesFileNoCheck
    , Resource (..)
    , Piece (..)
    ) where

import Web.PathPieces
import Language.Haskell.TH.Syntax
import Data.Maybe
import Data.Either
import Data.List
import Data.Char (toLower)
import qualified Data.Text
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Data.Data
import Data.Maybe
import qualified System.IO as SIO

data Pieces =
    SubSite
        { ssType :: Type
        , ssParse :: Exp
        , ssRender :: Exp
        , ssDispatch :: Exp
        , ssToMasterArg :: Exp
        , ssPieces :: [Piece]
        }
  | Simple [Piece] [String] -- ^ methods
    deriving Show
type THResource = (String, Pieces)

createRoutes :: [THResource] -> Q [Con]
createRoutes res =
    return $ map go res
  where
    go (n, SubSite{ssType = s, ssPieces = pieces}) =
        NormalC (mkName n) $ mapMaybe go' pieces ++ [(NotStrict, s)]
    go (n, Simple pieces _) = NormalC (mkName n) $ mapMaybe go' pieces
    go' (SinglePiece x) = Just (NotStrict, ConT $ mkName x)
    go' (MultiPiece x) = Just (NotStrict, ConT $ mkName x)
    go' (StaticPiece _) = Nothing

-- | Generates the set of clauses necesary to parse the given 'Resource's. See 'quasiParse'.
createParse :: [THResource] -> Q [Clause]
createParse res = do
    final' <- final
    clauses <- mapM go res
    return $ if areResourcesComplete res
                then clauses
                else clauses ++ [final']
  where
    cons x y = ConP (mkName ":") [x, y]
    go (constr, SubSite{ssParse = p, ssPieces = ps}) = do
        ri <- [|Right|]
        be <- [|ape|]
        (pat', parse) <- mkPat' be ps $ ri `AppE` ConE (mkName constr)
        
        x <- newName "x"
        let pat = init pat' ++ [VarP x]

        --let pat = foldr (\a b -> cons [LitP (StringL a), b]) (VarP x) pieces
        let eitherSub = p `AppE` VarE x
        let bod = be `AppE` parse `AppE` eitherSub
        --let bod = fmape' `AppE` ConE (mkName constr) `AppE` eitherSub
        return $ Clause [foldr1 cons pat] (NormalB bod) []
    go (n, Simple ps _) = do
        ri <- [|Right|]
        be <- [|ape|]
        (pat, parse) <- mkPat' be ps $ ri `AppE` ConE (mkName n)
        return $ Clause [foldr1 cons pat] (NormalB parse) []
    final = do
        no <- [|Left "Invalid URL"|]
        return $ Clause [WildP] (NormalB no) []
    mkPat' :: Exp -> [Piece] -> Exp -> Q ([Pat], Exp)
    mkPat' be [MultiPiece s] parse = do
        v <- newName $ "var" ++ s
        fmp <- [|fromMultiPiece|]
        let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v
        return ([VarP v], parse')
    mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last"
    mkPat' be (StaticPiece s:rest) parse = do
        (x, parse') <- mkPat' be rest parse
        let sp = LitP $ StringL s
        return (sp : x, parse')
    mkPat' be (SinglePiece s:rest) parse = do
        fsp <- [|fromSinglePiece|]
        v <- newName $ "var" ++ s
        let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v
        (x, parse'') <- mkPat' be rest parse'
        return (VarP v : x, parse'')
    mkPat' _ [] parse = return ([ListP []], parse)

-- | 'ap' for 'Either'
ape :: Either String (a -> b) -> Either String a -> Either String b
ape (Left e) _ = Left e
ape (Right _) (Left e) = Left e
ape (Right f) (Right a) = Right $ f a

-- | Generates the set of clauses necesary to render the given 'Resource's. See
-- 'quasiRender'.
createRender :: [THResource] -> Q [Clause]
createRender = mapM go
  where
    go (n, Simple ps _) = do
        let ps' = zip [1..] ps
        let pat = ConP (mkName n) $ mapMaybe go' ps'
        bod <- mkBod ps'
        return $ Clause [pat] (NormalB $ TupE [bod, ListE []]) []
    go (n, SubSite{ssRender = r, ssPieces = pieces}) = do
        cons' <- [|\a (b, c) -> (a ++ b, c)|]
        let cons a b = cons' `AppE` a `AppE` b
        x <- newName "x"
        let r' = r `AppE` VarE x
        let pieces' = zip [1..] pieces
        let pat = ConP (mkName n) $ mapMaybe go' pieces' ++ [VarP x]
        bod <- mkBod pieces'
        return $ Clause [pat] (NormalB $ cons bod r') []
    go' (_, StaticPiece _) = Nothing
    go' (i, _) = Just $ VarP $ mkName $ "var" ++ show (i :: Int)
    mkBod :: (Show t) => [(t, Piece)] -> Q Exp
    mkBod [] = lift ([] :: [String])
    mkBod ((_, StaticPiece x):xs) = do
        x' <- lift x
        pack <- [|Data.Text.pack|]
        xs' <- mkBod xs
        return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs'
    mkBod ((i, SinglePiece _):xs) = do
        let x' = VarE $ mkName $ "var" ++ show i
        tsp <- [|toSinglePiece|]
        let x'' = tsp `AppE` x'
        xs' <- mkBod xs
        return $ ConE (mkName ":") `AppE` x'' `AppE` xs'
    mkBod ((i, MultiPiece _):_) = do
        let x' = VarE $ mkName $ "var" ++ show i
        tmp <- [|toMultiPiece|]
        return $ tmp `AppE` x'

-- | Whether the set of resources cover all possible URLs.
areResourcesComplete :: [THResource] -> Bool
areResourcesComplete res =
    let (slurps, noSlurps) = partitionEithers $ mapMaybe go res
     in case slurps of
            [] -> False
            _ -> let minSlurp = minimum slurps
                  in helper minSlurp $ reverse $ sort noSlurps
  where
    go :: THResource -> Maybe (Either Int Int)
    go (_, Simple ps _) =
        case reverse ps of
            [] -> Just $ Right 0
            (MultiPiece _:rest) -> go' Left rest
            x -> go' Right x
    go (n, SubSite{ssPieces = ps}) =
        go (n, Simple (ps ++ [MultiPiece ""]) [])
    go' b x = if all isSingle x then Just (b $ length x) else Nothing
    helper 0 _ = True
    helper _ [] = False
    helper m (i:is)
        | i >= m = helper m is
        | i + 1 == m = helper i is
        | otherwise = False
    isSingle (SinglePiece _) = True
    isSingle _ = False

notStatic :: Piece -> Bool
notStatic StaticPiece{} = False
notStatic _ = True

createDispatch :: Exp -- ^ modify a master handler
               -> Exp -- ^ convert a subsite handler to a master handler
               -> [THResource]
               -> Q [Clause]
createDispatch modMaster toMaster = mapM go
  where
    go :: (String, Pieces) -> Q Clause
    go (n, Simple ps methods) = do
        meth <- newName "method"
        xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"
        let pat = [ ConP (mkName n) $ map VarP xs
                  , if null methods then WildP else VarP meth
                  ]
        bod <- go' n meth xs methods
        return $ Clause pat (NormalB bod) []
    go (n, SubSite{ssDispatch = d, ssToMasterArg = tma, ssPieces = ps}) = do
        meth <- newName "method"
        x <- newName "x"
        xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"
        let pat = [ConP (mkName n) $ map VarP xs ++ [VarP x], VarP meth]
        let bod = d `AppE` VarE x `AppE` VarE meth
        fmap' <- [|fmap|]
        let routeToMaster = foldl AppE (ConE (mkName n)) $ map VarE xs
            tma' = foldl AppE tma $ map VarE xs
        let toMaster' = toMaster `AppE` routeToMaster `AppE` tma' `AppE` VarE x
        let bod' = InfixE (Just toMaster') fmap' (Just bod)
        let bod'' = InfixE (Just modMaster) fmap' (Just bod')
        return $ Clause pat (NormalB bod'') []
    go' n _ xs [] = do
        jus <- [|Just|]
        let bod = foldl AppE (VarE $ mkName $ "handle" ++ n) $ map VarE xs
        return $ jus `AppE` (modMaster `AppE` bod)
    go' n meth xs methods = do
        noth <- [|Nothing|]
        j <- [|Just|]
        let noMatch = Match WildP (NormalB noth) []
        return $ CaseE (VarE meth) $ map (go'' n xs j) methods ++ [noMatch]
    go'' n xs j method =
        let pat = LitP $ StringL method
            func = map toLower method ++ n
            bod = foldl AppE (VarE $ mkName func) $ map VarE xs
         in Match pat (NormalB $ j `AppE` (modMaster `AppE` bod)) []

-- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for
-- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the
-- checking. See documentation site for details on syntax.
parseRoutes :: QuasiQuoter
parseRoutes = QuasiQuoter
    { quoteExp = x
    , quotePat = y
    }
  where
    x s = do
        let res = resourcesFromString s
        case findOverlaps res of
            [] -> lift res
            z -> error $ "Overlapping routes: " ++ unlines (map show z)
    y = dataToPatQ (const Nothing) . resourcesFromString

parseRoutesFile :: FilePath -> Q Exp
parseRoutesFile fp = do
    s <- qRunIO $ readUtf8File fp
    quoteExp parseRoutes s

parseRoutesFileNoCheck :: FilePath -> Q Exp
parseRoutesFileNoCheck fp = do
    s <- qRunIO $ readUtf8File fp
    quoteExp parseRoutesNoCheck s

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

-- | Same as 'parseRoutes', but performs no overlap checking.
parseRoutesNoCheck :: QuasiQuoter
parseRoutesNoCheck = QuasiQuoter
    { quoteExp = x
    , quotePat = y
    }
  where
    x = lift . resourcesFromString
    y = dataToPatQ (const Nothing) . resourcesFromString

instance Lift Resource where
    lift (Resource s ps h) = do
        r <- [|Resource|]
        s' <- lift s
        ps' <- lift ps
        h' <- lift h
        return $ r `AppE` s' `AppE` ps' `AppE` h'

-- | A single resource pattern.
--
-- First argument is the name of the constructor, second is the URL pattern to
-- match, third is how to dispatch.
data Resource = Resource String [Piece] [String]
    deriving (Read, Show, Eq, Data, Typeable)

-- | A single piece of a URL, delimited by slashes.
--
-- In the case of StaticPiece, the argument is the value of the piece; for the
-- other constructors, it is the name of the parameter represented by this
-- piece. That value is not used here, but may be useful elsewhere.
data Piece = StaticPiece String
           | SinglePiece String
           | MultiPiece String
    deriving (Read, Show, Eq, Data, Typeable)

instance Lift Piece where
    lift (StaticPiece s) = do
        c <- [|StaticPiece|]
        s' <- lift s
        return $ c `AppE` s'
    lift (SinglePiece s) = do
        c <- [|SinglePiece|]
        s' <- lift s
        return $ c `AppE` s'
    lift (MultiPiece s) = do
        c <- [|MultiPiece|]
        s' <- lift s
        return $ c `AppE` s'

-- | Convert a multi-line string to a set of resources. See documentation for
-- the format of this string. This is a partial function which calls 'error' on
-- invalid input.
resourcesFromString :: String -> [Resource]
resourcesFromString =
    mapMaybe go . lines
  where
    go s =
        case takeWhile (/= "--") $ words s of
            (pattern:constr:rest) ->
                let pieces = piecesFromString $ drop1Slash pattern
                 in Just $ Resource constr pieces rest
            [] -> Nothing
            _ -> error $ "Invalid resource line: " ++ s

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

piecesFromString :: String -> [Piece]
piecesFromString "" = []
piecesFromString x =
    let (y, z) = break (== '/') x
     in pieceFromString y : piecesFromString (drop1Slash z)

pieceFromString :: String -> Piece
pieceFromString ('#':x) = SinglePiece x
pieceFromString ('*':x) = MultiPiece x
pieceFromString x = StaticPiece x

findOverlaps :: [Resource] -> [(Resource, Resource)]
findOverlaps = gos . map justPieces
  where
    justPieces r@(Resource _ ps _) = (ps, r)
    gos [] = []
    gos (x:xs) = mapMaybe (go x) xs ++ gos xs
    go (StaticPiece x:xs, xr) (StaticPiece y:ys, yr)
        | x == y = go (xs, xr) (ys, yr)
        | otherwise = Nothing
    go (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)
    go (_, xr) (MultiPiece _:_, yr) = Just (xr, yr)
    go ([], xr) ([], yr) = Just (xr, yr)
    go ([], _) (_, _) = Nothing
    go (_, _) ([], _) = Nothing
    go (_:xs, xr) (_:ys, yr) = go (xs, xr) (ys, yr)