{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoOverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Salak.Internal(
loadAndRunSalak'
, loadTrie
, loadList
, LoadSalakT
, LoadSalak
, RunSalakT
, RunSalak
, runRunSalak
, HasSalak(..)
, MonadSalak(..)
, loadMock
, loadEnv
, loadCommandLine
, ParseCommandLine
, defaultParseCommandLine
, tryLoadFile
, Source
, TraceSource
, Keys(..)
, Key(..)
, simpleKeys
, ToKeys(..)
, setVal
, Val(..)
, Value(..)
, ToValue(..)
, liftNT
, SourcePack(..)
, MonadIO
) where
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Control.Monad.IO.Unlift as IU
import Control.Monad.Reader
import qualified Control.Monad.State as MS
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.Maybe
import Data.Text (Text, pack)
import qualified Data.Text as TT
import Salak.Internal.Key
import Salak.Internal.Prop
import Salak.Internal.Source
import Salak.Internal.Val
import qualified Salak.Trie as T
import System.Directory
import System.Environment
data UpdateSource = UpdateSource
{ ref :: MVar Source
, refNo :: Int
, refMap :: HashMap Int String
, qfunc :: MVar QFunc
, update :: MVar (IO ( TraceSource
, IO ()))
}
newtype LoadSalakT m a = LoadSalakT { unLoad :: MS.StateT UpdateSource m a } deriving (Functor, Applicative, Monad, MS.MonadTrans)
type LoadSalak = LoadSalakT IO
liftNT :: MonadIO m => LoadSalak () -> LoadSalakT m ()
liftNT (LoadSalakT a) = do
ud <- MS.get
MS.liftIO $ MS.evalStateT a ud
instance MonadIO m => MonadSalak (LoadSalakT m) where
askSalak = MS.get >>= toSourcePack
instance MonadThrow m => MonadThrow (LoadSalakT m) where
throwM = LoadSalakT . throwM
instance MonadCatch m => MonadCatch (LoadSalakT m) where
catch m f = do
us <- MS.get
lift $ MS.evalStateT (unLoad m) us `catch` (\e -> MS.evalStateT (unLoad $ f e) us)
instance Monad m => MS.MonadState UpdateSource (LoadSalakT m) where
state f = LoadSalakT $ MS.state f
instance MonadIO m => MonadIO (LoadSalakT m) where
liftIO = LoadSalakT . liftIO
instance IU.MonadUnliftIO m => IU.MonadUnliftIO (LoadSalakT m) where
askUnliftIO = LoadSalakT $ do
ut <- MS.get
f <- MS.lift IU.askUnliftIO
return $ IU.UnliftIO $ IU.unliftIO f . (`MS.evalStateT` ut) . unLoad
newtype RunSalakT m a = RunSalakT { unRun :: ReaderT SourcePack m a } deriving (Functor, Applicative, Monad, MonadTrans)
type RunSalak = RunSalakT IO
instance Monad m => MonadSalak (RunSalakT m) where
askSalak = RunSalakT ask
instance Monad m => MonadReader SourcePack (RunSalakT m) where
ask = RunSalakT ask
local f m = RunSalakT $ local f $ unRun m
instance MonadThrow m => MonadThrow (RunSalakT m) where
throwM = RunSalakT . throwM
instance MonadCatch m => MonadCatch (RunSalakT m) where
catch m f = do
us <- ask
lift $ runReaderT (unRun m) us `catch` (\e -> runReaderT (unRun $ f e) us)
instance MonadIO m => MonadIO (RunSalakT m) where
liftIO = RunSalakT . liftIO
instance IU.MonadUnliftIO m => IU.MonadUnliftIO (RunSalakT m) where
askUnliftIO = RunSalakT $ do
ut <- ask
f <- lift IU.askUnliftIO
return $ IU.UnliftIO $ IU.unliftIO f . (`runReaderT` ut) . unRun
instance {-# OVERLAPPABLE #-} (m' ~ t (RunSalakT m), MonadTrans t, Monad m, Monad m') => MonadSalak m' where
askSalak = lift askSalak
runRunSalak :: SourcePack -> RunSalakT m a -> m a
runRunSalak sp (RunSalakT m) = runReaderT m sp
loadTrie :: MonadIO m => Bool -> String -> (Int -> IO TraceSource) -> LoadSalakT m ()
loadTrie canReload name f = do
UpdateSource{..} <- MS.get
v <- liftIO $ readMVar ref
ts <- liftIO $ loadSource f refNo (fmap ([],) v)
let (t,_,es) = extract v ts
if null es
then do
liftIO $ modifyMVar_ update $ \u -> go ts u refNo
let nut = UpdateSource ref (refNo + 1) (HM.insert refNo name refMap) qfunc update
_ <- liftIO $ swapMVar ref t
MS.put nut
else error $ show es
where
go ts ud n = return $ do
(c,d) <- ud
c1 <- loadSource (if canReload then f else (\_ -> return ts)) n c
return (c1,d)
loadList :: (MonadIO m, Foldable f, ToKeys k, ToValue v) => Bool -> String -> IO (f (k,v)) -> LoadSalakT m ()
loadList canReload name iof = loadTrie canReload name (\i -> gen i <$> iof)
loadAndRunSalak' :: (MonadThrow m, MonadIO m) => LoadSalakT m () -> (SourcePack -> m a) -> m a
loadAndRunSalak' lstm f = load lstm >>= f
load :: MonadIO m => LoadSalakT m () -> m SourcePack
load (LoadSalakT lm) = do
r <- liftIO $ newMVar T.empty
q <- liftIO $ newMVar $ \s -> Right $ void $ swapMVar r s
u <- liftIO $ newMVar $ return (T.empty, return ())
MS.execStateT lm (UpdateSource r 0 HM.empty q u) >>= toSourcePack
toSourcePack :: MonadIO m => UpdateSource -> m SourcePack
toSourcePack UpdateSource{..} = liftIO (readMVar ref) >>= \s -> return $ SourcePack s [] qfunc go
where
go = do
t <- readMVar ref
(ts, ac) <- join $ readMVar update
let (s,cs,es) = extract t ts
f <- readMVar qfunc
if null es
then case f s of
Left e -> return (ReloadResult True $ lines e)
Right a -> ac >> a >> return (ReloadResult False $ lines $ show cs)
else return (ReloadResult True es)
loadMock :: MonadIO m => [(Text, Text)] -> LoadSalakT m ()
loadMock fa = loadList False "mock" (return fa)
loadEnv :: MonadIO m => LoadSalakT m ()
loadEnv = loadList False "environment" go
where
go = concatMap split2 . filter ((/= '_') . head . fst) <$> getEnvironment
split2 (k,v) = [(TT.pack k,v),(convert k,v)]
convert = TT.toLower . TT.pack . map (\c -> if c == '_' then '.' else c)
type ParseCommandLine = [String] -> IO [(Text, Text)]
defaultParseCommandLine :: ParseCommandLine
defaultParseCommandLine = return . mapMaybe go
where
go ('-':'-':as) = case break (=='=') as of
(a,'=':b) -> Just (pack a, pack b)
_ -> Nothing
go _ = Nothing
loadCommandLine :: MonadIO m => ParseCommandLine -> LoadSalakT m ()
loadCommandLine pcl = loadList False "commandLine" (getArgs >>= pcl)
tryLoadFile :: MonadIO m => (FilePath -> LoadSalakT m ()) -> FilePath -> LoadSalakT m ()
tryLoadFile f file = do
b <- liftIO $ doesFileExist file
when b $ do
liftIO $ putStrLn $ "Load " ++ file
f file