{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveFunctor #-}
module Dep.Loader
(
Loader (..),
ResourceKey (..),
DatatypeName,
ModuleName,
load,
ResourceNotFound (..),
FromResource (..),
dataDirLoader,
FileExtension,
DataDir,
dataDir,
extendDataDir,
)
where
import Control.Exception (Exception, throw, throwIO)
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe
import Data.ByteString
import Data.Functor
import Data.List.Split
import Data.Map.Strict qualified as Map
import Data.Monoid
import Data.Proxy
import GHC.Generics qualified as G
import GHC.TypeLits (KnownSymbol, symbolVal)
import System.Directory (doesFileExist)
import System.FilePath
import Data.Coerce
import GHC.Generics qualified
import System.Console.GetOpt (getOpt)
import Data.Foldable qualified
import Data.Typeable
import Data.Proxy
import System.Environment (lookupEnv)
import Dep.Has
import Dep.Value
import Data.Aeson qualified
import Data.Text
import Data.Text.Encoding (decodeUtf8')
import Data.Text.Encoding.Error
import Data.List.Split
newtype Loader v m =
Loader { Loader v m -> ResourceKey -> m (Maybe v)
loadMaybe :: ResourceKey -> m (Maybe v) }
deriving (forall x. Loader v m -> Rep (Loader v m) x)
-> (forall x. Rep (Loader v m) x -> Loader v m)
-> Generic (Loader v m)
forall x. Rep (Loader v m) x -> Loader v m
forall x. Loader v m -> Rep (Loader v m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall v (m :: * -> *) x. Rep (Loader v m) x -> Loader v m
forall v (m :: * -> *) x. Loader v m -> Rep (Loader v m) x
$cto :: forall v (m :: * -> *) x. Rep (Loader v m) x -> Loader v m
$cfrom :: forall v (m :: * -> *) x. Loader v m -> Rep (Loader v m) x
G.Generic
load :: forall r v m . (FromResource r, Typeable r, Typeable v, Monad m) => Loader v m -> m v
load :: Loader v m -> m v
load Loader v m
loader = do
let key :: ResourceKey
key = FromResource r => ResourceKey
forall a. FromResource a => ResourceKey
resourceKey @r
Maybe v
mb <- Loader v m -> ResourceKey -> m (Maybe v)
forall v (m :: * -> *). Loader v m -> ResourceKey -> m (Maybe v)
loadMaybe Loader v m
loader ResourceKey
key
case Maybe v
mb of
Maybe v
Nothing -> ResourceNotFound -> m v
forall a e. Exception e => e -> a
throw (ResourceNotFound -> m v) -> ResourceNotFound -> m v
forall a b. (a -> b) -> a -> b
$ TypeRep -> ResourceKey -> TypeRep -> ResourceNotFound
ResourceNotFound (Proxy r -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy r
forall k (t :: k). Proxy t
Proxy @r)) ResourceKey
key (Proxy v -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy v
forall k (t :: k). Proxy t
Proxy @v))
Just v
b -> v -> m v
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
b
instance Monad m => Semigroup (Loader v m) where
Loader ResourceKey -> m (Maybe v)
f <> :: Loader v m -> Loader v m -> Loader v m
<> Loader ResourceKey -> m (Maybe v)
g = (ResourceKey -> m (Maybe v)) -> Loader v m
forall v (m :: * -> *). (ResourceKey -> m (Maybe v)) -> Loader v m
Loader \ResourceKey
key -> do
let Alt (MaybeT m (Maybe v)
m) = ((ResourceKey -> m (Maybe v)) -> ResourceKey -> Alt (MaybeT m) v
coerce ResourceKey -> m (Maybe v)
f (ResourceKey -> Alt (MaybeT m) v)
-> (ResourceKey -> Alt (MaybeT m) v)
-> ResourceKey
-> Alt (MaybeT m) v
forall a. Semigroup a => a -> a -> a
<> (ResourceKey -> m (Maybe v)) -> ResourceKey -> Alt (MaybeT m) v
coerce ResourceKey -> m (Maybe v)
g) ResourceKey
key
m (Maybe v)
m
instance Monad m => Monoid (Loader v m) where
mempty :: Loader v m
mempty = (ResourceKey -> m (Maybe v)) -> Loader v m
forall v (m :: * -> *). (ResourceKey -> m (Maybe v)) -> Loader v m
Loader \ResourceKey
_ -> Maybe v -> m (Maybe v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe v
forall a. Maybe a
Nothing
data ResourceKey = ResourceKey
{ ResourceKey -> [ModuleName]
modulePath :: [ModuleName],
ResourceKey -> ModuleName
datatypeName :: DatatypeName
}
deriving (Int -> ResourceKey -> ShowS
[ResourceKey] -> ShowS
ResourceKey -> ModuleName
(Int -> ResourceKey -> ShowS)
-> (ResourceKey -> ModuleName)
-> ([ResourceKey] -> ShowS)
-> Show ResourceKey
forall a.
(Int -> a -> ShowS)
-> (a -> ModuleName) -> ([a] -> ShowS) -> Show a
showList :: [ResourceKey] -> ShowS
$cshowList :: [ResourceKey] -> ShowS
show :: ResourceKey -> ModuleName
$cshow :: ResourceKey -> ModuleName
showsPrec :: Int -> ResourceKey -> ShowS
$cshowsPrec :: Int -> ResourceKey -> ShowS
Show, ResourceKey -> ResourceKey -> Bool
(ResourceKey -> ResourceKey -> Bool)
-> (ResourceKey -> ResourceKey -> Bool) -> Eq ResourceKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResourceKey -> ResourceKey -> Bool
$c/= :: ResourceKey -> ResourceKey -> Bool
== :: ResourceKey -> ResourceKey -> Bool
$c== :: ResourceKey -> ResourceKey -> Bool
Eq, Eq ResourceKey
Eq ResourceKey
-> (ResourceKey -> ResourceKey -> Ordering)
-> (ResourceKey -> ResourceKey -> Bool)
-> (ResourceKey -> ResourceKey -> Bool)
-> (ResourceKey -> ResourceKey -> Bool)
-> (ResourceKey -> ResourceKey -> Bool)
-> (ResourceKey -> ResourceKey -> ResourceKey)
-> (ResourceKey -> ResourceKey -> ResourceKey)
-> Ord ResourceKey
ResourceKey -> ResourceKey -> Bool
ResourceKey -> ResourceKey -> Ordering
ResourceKey -> ResourceKey -> ResourceKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ResourceKey -> ResourceKey -> ResourceKey
$cmin :: ResourceKey -> ResourceKey -> ResourceKey
max :: ResourceKey -> ResourceKey -> ResourceKey
$cmax :: ResourceKey -> ResourceKey -> ResourceKey
>= :: ResourceKey -> ResourceKey -> Bool
$c>= :: ResourceKey -> ResourceKey -> Bool
> :: ResourceKey -> ResourceKey -> Bool
$c> :: ResourceKey -> ResourceKey -> Bool
<= :: ResourceKey -> ResourceKey -> Bool
$c<= :: ResourceKey -> ResourceKey -> Bool
< :: ResourceKey -> ResourceKey -> Bool
$c< :: ResourceKey -> ResourceKey -> Bool
compare :: ResourceKey -> ResourceKey -> Ordering
$ccompare :: ResourceKey -> ResourceKey -> Ordering
$cp1Ord :: Eq ResourceKey
Ord)
type DatatypeName = String
type ModuleName = String
type FileExtension = String
class FromResource a where
resourceKey :: ResourceKey
default resourceKey ::
forall name mod p n nt x.
( G.Generic a,
G.Rep a ~ G.D1 ('G.MetaData name mod p nt) x,
KnownSymbol name,
KnownSymbol mod
) =>
ResourceKey
resourceKey = [ModuleName] -> ModuleName -> ResourceKey
ResourceKey (ModuleName -> ModuleName -> [ModuleName]
forall a. Eq a => [a] -> [a] -> [[a]]
Data.List.Split.splitOn ModuleName
"." (Proxy mod -> ModuleName
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> ModuleName
symbolVal (Proxy mod
forall k (t :: k). Proxy t
Proxy @mod))) (Proxy name -> ModuleName
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> ModuleName
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy @name))
data ResourceNotFound = ResourceNotFound TypeRep ResourceKey TypeRep deriving (Int -> ResourceNotFound -> ShowS
[ResourceNotFound] -> ShowS
ResourceNotFound -> ModuleName
(Int -> ResourceNotFound -> ShowS)
-> (ResourceNotFound -> ModuleName)
-> ([ResourceNotFound] -> ShowS)
-> Show ResourceNotFound
forall a.
(Int -> a -> ShowS)
-> (a -> ModuleName) -> ([a] -> ShowS) -> Show a
showList :: [ResourceNotFound] -> ShowS
$cshowList :: [ResourceNotFound] -> ShowS
show :: ResourceNotFound -> ModuleName
$cshow :: ResourceNotFound -> ModuleName
showsPrec :: Int -> ResourceNotFound -> ShowS
$cshowsPrec :: Int -> ResourceNotFound -> ShowS
Show)
instance Exception ResourceNotFound
type DataDir = FilePath -> IO FilePath
dataDir :: FilePath -> DataDir
dataDir :: ModuleName -> DataDir
dataDir ModuleName
dirPath ModuleName
filePath = DataDir
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleName
dirPath ModuleName -> ShowS
</> ModuleName
filePath)
extendDataDir :: DataDir -> FilePath -> DataDir
extendDataDir :: DataDir -> ModuleName -> DataDir
extendDataDir DataDir
dataDir ModuleName
relDir ModuleName
filePath = DataDir
dataDir (ModuleName
relDir ModuleName -> ShowS
</> ModuleName
filePath)
dataDirLoader :: MonadIO m => [FileExtension] -> DataDir -> Loader ByteString m
dataDirLoader :: [ModuleName] -> DataDir -> Loader ByteString m
dataDirLoader [ModuleName]
extensions DataDir
base = (ResourceKey -> m (Maybe ByteString)) -> Loader ByteString m
forall v (m :: * -> *). (ResourceKey -> m (Maybe v)) -> Loader v m
Loader \ResourceKey {[ModuleName]
modulePath :: [ModuleName]
modulePath :: ResourceKey -> [ModuleName]
modulePath, ModuleName
datatypeName :: ModuleName
datatypeName :: ResourceKey -> ModuleName
datatypeName} -> do
let go :: [ModuleName] -> m (Maybe ByteString)
go [] = do
Maybe ByteString -> m (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
go (ModuleName
ext : [ModuleName]
exts) = do
let relative :: ModuleName
relative = [ModuleName] -> ModuleName
joinPath [ModuleName]
modulePath ModuleName -> ShowS
</> ModuleName -> ShowS
addExtension ModuleName
datatypeName ModuleName
ext
ModuleName
absolute <- IO ModuleName -> m ModuleName
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModuleName -> m ModuleName) -> IO ModuleName -> m ModuleName
forall a b. (a -> b) -> a -> b
$ DataDir
base ModuleName
relative
Maybe ByteString
mbytes <- ModuleName -> m (Maybe ByteString)
forall (m :: * -> *).
MonadIO m =>
ModuleName -> m (Maybe ByteString)
readFileMaybe ModuleName
absolute
case Maybe ByteString
mbytes of
Just ByteString
bs -> Maybe ByteString -> m (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> m (Maybe ByteString))
-> Maybe ByteString -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs
Maybe ByteString
Nothing -> [ModuleName] -> m (Maybe ByteString)
go [ModuleName]
exts
[ModuleName] -> m (Maybe ByteString)
go [ModuleName]
extensions
where
readFileMaybe :: MonadIO m => FilePath -> m (Maybe ByteString)
readFileMaybe :: ModuleName -> m (Maybe ByteString)
readFileMaybe ModuleName
absolute = do
Bool
exists <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ModuleName -> IO Bool
doesFileExist ModuleName
absolute)
if Bool -> Bool
not Bool
exists
then do
Maybe ByteString -> m (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
else do
ByteString
bytes <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ ModuleName -> IO ByteString
Data.ByteString.readFile ModuleName
absolute
Maybe ByteString -> m (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bytes)