{-# LANGUAGE TemplateHaskell #-}
module Yesod.Routes.TH.Types
    ( -- * Data types
      Resource (..)
    , ResourceTree (..)
    , Piece (..)
    , Dispatch (..)
    , CheckOverlap
    , FlatResource (..)
      -- ** Helper functions
    , resourceMulti
    , resourceTreePieces
    , resourceTreeName
    , flatten
    ) where

import Language.Haskell.TH.Syntax
import Control.Arrow (second)

data ResourceTree typ = ResourceLeaf (Resource typ) | ResourceParent String [(CheckOverlap, Piece typ)] [ResourceTree typ]

resourceTreePieces :: ResourceTree typ -> [(CheckOverlap, Piece typ)]
resourceTreePieces (ResourceLeaf r) = resourcePieces r
resourceTreePieces (ResourceParent _ x _) = x

resourceTreeName :: ResourceTree typ -> String
resourceTreeName (ResourceLeaf r) = resourceName r
resourceTreeName (ResourceParent x _ _) = x

instance Functor ResourceTree where
    fmap f (ResourceLeaf r) = ResourceLeaf (fmap f r)
    fmap f (ResourceParent a b c) = ResourceParent a (map (second $ fmap f) b) $ map (fmap f) c

instance Lift t => Lift (ResourceTree t) where
    lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|]
    lift (ResourceParent a b c) = [|ResourceParent $(lift a) $(lift b) $(lift c)|]

data Resource typ = Resource
    { resourceName :: String
    , resourcePieces :: [(CheckOverlap, Piece typ)]
    , resourceDispatch :: Dispatch typ
    , resourceAttrs :: [String]
    }
    deriving Show

type CheckOverlap = Bool

instance Functor Resource where
    fmap f (Resource a b c d) = Resource a (map (second $ fmap f) b) (fmap f c) d

instance Lift t => Lift (Resource t) where
    lift (Resource a b c d) = [|Resource a b c d|]

data Piece typ = Static String | Dynamic typ
    deriving Show

instance Functor Piece where
    fmap _ (Static s) = (Static s)
    fmap f (Dynamic t) = Dynamic (f t)

instance Lift t => Lift (Piece t) where
    lift (Static s) = [|Static $(lift s)|]
    lift (Dynamic t) = [|Dynamic $(lift t)|]

data Dispatch typ =
    Methods
        { methodsMulti :: Maybe typ -- ^ type of the multi piece at the end
        , methodsMethods :: [String] -- ^ supported request methods
        }
    | Subsite
        { subsiteType :: typ
        , subsiteFunc :: String
        }
    deriving Show

instance Functor Dispatch where
    fmap f (Methods a b) = Methods (fmap f a) b
    fmap f (Subsite a b) = Subsite (f a) b

instance Lift t => Lift (Dispatch t) where
    lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]
    lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|]
    lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|]

resourceMulti :: Resource typ -> Maybe typ
resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
resourceMulti _ = Nothing

data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a)

flatten :: [ResourceTree a] -> [FlatResource a]
flatten =
    concatMap (go id)
  where
    go front (ResourceLeaf (Resource a b c _)) = [FlatResource (front []) a b c]
    go front (ResourceParent name pieces children) =
        concatMap (go (front . ((name, pieces):))) children