{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
module Servant.Static.TH.Internal.Api where
import Data.Foldable (foldl1)
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 = TyLitQ -> Q Type
litT (TyLitQ -> Q Type) -> TyLitQ -> Q Type
forall a b. (a -> b) -> a -> b
$ FilePath -> TyLitQ
strTyLit FilePath
fileName
case FilePath
fileName of
FilePath
"index.html" -> [t|Get '[$(mimeT)] $(respT) :<|> $(fileNameLitT) :> Get '[$(mimeT)] $(respT)|]
FilePath
_ -> [t|$(fileNameLitT) :> Get '[$(mimeT)] $(respT)|]
fileTreeToApiType (FileTreeDir FilePath
filePath NonEmpty FileTree
fileTrees) =
let fileNameLitT :: Q Type
fileNameLitT = TyLitQ -> Q Type
litT (TyLitQ -> Q Type) -> TyLitQ -> Q Type
forall a b. (a -> b) -> a -> b
$ FilePath -> TyLitQ
strTyLit (FilePath -> TyLitQ) -> FilePath -> TyLitQ
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName FilePath
filePath
in [t|$(fileNameLitT) :> $(combineWithServantOrT nonEmptyApiTypesQ)|]
where
nonEmptyApiTypesQ :: NonEmpty (Q Type)
nonEmptyApiTypesQ :: NonEmpty (Q Type)
nonEmptyApiTypesQ = (FileTree -> Q Type) -> NonEmpty FileTree -> NonEmpty (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileTree -> Q Type
fileTreeToApiType NonEmpty FileTree
fileTrees
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 (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
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
appT Q Type
combiningType
createApiType
:: FilePath
-> 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileTree -> Q Type
fileTreeToApiType NonEmpty FileTree
fileTree
createApiDec
:: String
-> FilePath
-> Q [Dec]
createApiDec :: FilePath -> FilePath -> Q [Dec]
createApiDec FilePath
apiName FilePath
templateDir =
Dec -> [Dec]
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
tySynD (FilePath -> Name
mkName FilePath
apiName) [] (FilePath -> Q Type
createApiType FilePath
templateDir)