{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}

module Servant.Static.TH.Internal.Api where

import Data.List.NonEmpty (NonEmpty)
import Language.Haskell.TH
       (Dec, Q, Type, appT, litT, mkName,
        runIO, strTyLit, tySynD)
import Language.Haskell.TH.Syntax (addDependentFile)
import Servant.API (Get, (:<|>), (:>))
import System.FilePath (takeFileName)

import Servant.Static.TH.Internal.FileTree
import Servant.Static.TH.Internal.Mime

fileTreeToApiType :: FileTree -> Q Type
fileTreeToApiType :: FileTree -> Q Type
fileTreeToApiType (FileTreeFile FilePath
filePath ByteString
_) = do
  FilePath -> Q ()
addDependentFile FilePath
filePath
  MimeTypeInfo Q Type
mimeT Q Type
respT ByteString -> Q Exp
_ <- FilePath -> Q MimeTypeInfo
extensionToMimeTypeInfoEx FilePath
filePath
  let fileName :: FilePath
fileName = FilePath -> FilePath
takeFileName FilePath
filePath
  let fileNameLitT :: Q Type
      fileNameLitT :: Q Type
fileNameLitT = Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (Q TyLit -> Q Type) -> Q TyLit -> Q Type
forall a b. (a -> b) -> a -> b
$ FilePath -> Q TyLit
forall (m :: * -> *). Quote m => FilePath -> m TyLit
strTyLit FilePath
fileName
  case FilePath
fileName of
    -- We special-case files called "index.html" and generate a type that serves on both
    -- the root, and under the path "index.html".
    FilePath
"index.html" -> [t|Get '[$(Q Type
mimeT)] $(Q Type
respT) :<|> $(Q Type
fileNameLitT) :> Get '[$(Q Type
mimeT)] $(Q Type
respT)|]
    FilePath
_ -> [t|$(Q Type
fileNameLitT) :> Get '[$(Q Type
mimeT)] $(Q Type
respT)|]
fileTreeToApiType (FileTreeDir FilePath
filePath NonEmpty FileTree
fileTrees) =
  let fileNameLitT :: Q Type
      fileNameLitT :: Q Type
fileNameLitT = Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (Q TyLit -> Q Type) -> Q TyLit -> Q Type
forall a b. (a -> b) -> a -> b
$ FilePath -> Q TyLit
forall (m :: * -> *). Quote m => FilePath -> m TyLit
strTyLit (FilePath -> Q TyLit) -> FilePath -> Q TyLit
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName FilePath
filePath
  in [t|$(Q Type
fileNameLitT) :> $(NonEmpty (Q Type) -> Q Type
combineWithServantOrT NonEmpty (Q Type)
nonEmptyApiTypesQ)|]
  where
    nonEmptyApiTypesQ :: NonEmpty (Q Type)
    nonEmptyApiTypesQ :: NonEmpty (Q Type)
nonEmptyApiTypesQ = (FileTree -> Q Type) -> NonEmpty FileTree -> NonEmpty (Q Type)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileTree -> Q Type
fileTreeToApiType NonEmpty FileTree
fileTrees

-- | Given a list of @'Q' 'Type'@, combine them with Servant's '(:<|>)'
-- function and return the resulting @'Q' 'Type'@.
combineWithServantOrT :: NonEmpty (Q Type) -> Q Type
combineWithServantOrT :: NonEmpty (Q Type) -> Q Type
combineWithServantOrT = (Q Type -> Q Type -> Q Type) -> NonEmpty (Q Type) -> Q Type
forall a. (a -> a -> a) -> NonEmpty a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 ((Q Type -> Q Type -> Q Type) -> NonEmpty (Q Type) -> Q Type)
-> (Q Type -> Q Type -> Q Type) -> NonEmpty (Q Type) -> Q Type
forall a b. (a -> b) -> a -> b
$ Q Type -> Q Type -> Q Type -> Q Type
combineWithType [t|(:<|>)|]

combineWithType :: Q Type -> Q Type -> Q Type -> Q Type
combineWithType :: Q Type -> Q Type -> Q Type -> Q Type
combineWithType Q Type
combiningType = Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Q Type -> Q Type -> Q Type)
-> (Q Type -> Q Type) -> Q Type -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT Q Type
combiningType

-- | Take a template directory argument as a 'FilePath' and create a Servant
-- type representing the files in the directory.  Empty directories will be
-- ignored. @index.html@ files will also be served at the root.
--
-- For example, assume the following directory structure:
--
-- @
--   $ tree dir\/
--   dir\/
--   ├── js
--   │   └── test.js
--   └── index.html
-- @
--
-- 'createApiType' is used like the following:
--
-- @
--   \{\-\# LANGUAGE DataKinds \#\-\}
--   \{\-\# LANGUAGE TemplateHaskell \#\-\}
--
--   type FrontEndAPI = $('createApiType' \"dir\")
-- @
--
-- At compile time, it will expand to the following:
--
-- @
--   type FrontEndAPI =
--          \"js\" ':>' \"test.js\" ':>' 'Get' \'['JS'] 'Data.ByteString.ByteString'
--     ':<|>' 'Get' \'['Servant.HTML.Blaze.HTML'] 'Text.Blaze.Html.Html'
--     ':<|>' \"index.html\" ':>' 'Get' \'['Servant.HTML.Blaze.HTML'] 'Text.Blaze.Html.Html'
-- @
createApiType
  :: FilePath -- ^ directory name to read files from
  -> Q Type
createApiType :: FilePath -> Q Type
createApiType FilePath
templateDir = do
  NonEmpty FileTree
fileTree <- IO (NonEmpty FileTree) -> Q (NonEmpty FileTree)
forall a. IO a -> Q a
runIO (IO (NonEmpty FileTree) -> Q (NonEmpty FileTree))
-> IO (NonEmpty FileTree) -> Q (NonEmpty FileTree)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (NonEmpty FileTree)
getFileTreeIgnoreEmpty FilePath
templateDir
  NonEmpty (Q Type) -> Q Type
combineWithServantOrT (NonEmpty (Q Type) -> Q Type) -> NonEmpty (Q Type) -> Q Type
forall a b. (a -> b) -> a -> b
$ (FileTree -> Q Type) -> NonEmpty FileTree -> NonEmpty (Q Type)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileTree -> Q Type
fileTreeToApiType NonEmpty FileTree
fileTree

-- | This is similar to 'createApiType', but it creates the whole type synonym
-- declaration.
--
-- Given the following code:
--
-- @
--   \{\-\# LANGUAGE DataKinds \#\-\}
--   \{\-\# LANGUAGE TemplateHaskell \#\-\}
--
--   $('createApiDec' \"FrontAPI\" \"dir\")
-- @
--
-- You can think of it as expanding to the following:
--
-- @
--   type FrontAPI = $('createApiType' \"dir\")
-- @
createApiDec
  :: String   -- ^ name of the api type synonym
  -> FilePath -- ^ directory name to read files from
  -> Q [Dec]
createApiDec :: FilePath -> FilePath -> Q [Dec]
createApiDec FilePath
apiName FilePath
templateDir =
  Dec -> [Dec]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [TyVarBndr ()] -> Q Type -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> [TyVarBndr ()] -> m Type -> m Dec
tySynD (FilePath -> Name
mkName FilePath
apiName) [] (FilePath -> Q Type
createApiType FilePath
templateDir)