module Control.Biegunka.Script
(
Script(..), Annotate(..)
, MAnnotations, Annotations
, HasRoot(..), HasSource(..)
, runScript, evalScript
, script, sourced, actioned, constructTargetFilePath
, app, profileName, sourcePath, sourceURL, profiles
, order, sourceReaction, actionReaction, activeUser, maxRetries
, URI, UserW(..), User(..), React(..), Retry(..), incr, into
) where
import Control.Applicative (Applicative(..), (<$>))
import Control.Lens hiding (Action)
import Control.Monad.Free (Free(..), iter, liftF)
import Control.Monad.State (StateT(..))
import Control.Monad.Reader (MonadReader(..), ReaderT(..), local)
import Control.Monad.Trans (lift)
import Data.Copointed (copoint)
import Data.Default.Class (Default(..))
import Data.List (isSuffixOf)
import Data.Monoid (mempty)
import Data.Set (Set)
import Data.String (IsString(..))
import Data.Void (Void)
import System.FilePath ((</>))
import System.FilePath.Lens
import System.Command.QQ (Eval(..))
import System.Posix.Types (CUid)
import System.Process (CmdSpec(..))
import Control.Biegunka.Language
import Control.Biegunka.Script.Token
data family Annotate (sc :: Scope) :: *
data instance Annotate Sources = AS
{ asToken :: Token
, asProfile :: String
, asUser :: Maybe UserW
, asMaxRetries :: Retry
, asReaction :: React
}
data instance Annotate Actions = AA
{ aaURI :: URI
, aaOrder :: Int
, aaMaxOrder :: Int
, aaUser :: Maybe UserW
, aaMaxRetries :: Retry
, aaReaction :: React
}
type URI = String
data User u where
UserID :: CUid -> User CUid
Username :: String -> User String
instance Show (User u)
instance u ~ String => IsString (User u) where
fromString = Username
instance u ~ CUid => Num (User u) where
UserID a + UserID b = UserID (a + b)
UserID a * UserID b = UserID (a * b)
abs (UserID a) = UserID (abs a)
signum (UserID a) = signum (UserID a)
fromInteger = UserID . fromInteger
data UserW = forall u. UserW (User u)
deriving instance Show UserW
data React = Ignorant | Abortive
deriving (Show, Read, Eq, Ord, Enum, Bounded)
newtype Retry = Retry { unRetry :: Int }
deriving (Show, Read, Eq, Ord)
instance Default Retry where
def = Retry 0
incr :: Retry -> Retry
incr (Retry n) = Retry (succ n)
data Annotations = Annotations
{ _app :: FilePath
, _profileName :: String
, _sourcePath :: FilePath
, _sourceURL :: URI
, _activeUser :: Maybe UserW
, _maxRetries :: Retry
, _sourceReaction :: React
, _actionReaction :: React
}
deriving instance Show Annotations
instance Default Annotations where
def = Annotations
{ _app = mempty
, _profileName = mempty
, _sourcePath = mempty
, _sourceURL = mempty
, _activeUser = Nothing
, _maxRetries = Retry 1
, _sourceReaction = Abortive
, _actionReaction = Ignorant
}
data MAnnotations = MAnnotations
{ _profiles :: Set String
, _order :: Int
, _maxOrder :: Int
} deriving (Show, Read)
instance Default MAnnotations where
def = MAnnotations
{ _profiles = mempty
, _order = 0
, _maxOrder = 0
}
makeLensesWith ?? ''Annotations $ defaultRules & generateSignatures .~ False
class HasRoot s where
root :: Lens' s FilePath
instance HasRoot Annotations where
root = app
class HasSource s where
source :: Lens' s FilePath
instance HasSource Annotations where
source = sourcePath
app :: Lens' Annotations FilePath
profileName :: Lens' Annotations String
sourcePath :: Lens' Annotations FilePath
sourceURL :: Lens' Annotations String
activeUser :: Lens' Annotations (Maybe UserW)
maxRetries :: Lens' Annotations Retry
sourceReaction :: Lens' Annotations React
actionReaction :: Lens' Annotations React
makeLensesWith ?? ''MAnnotations $ defaultRules & generateSignatures .~ False
profiles :: Lens' MAnnotations (Set String)
order :: Lens' MAnnotations Int
maxOrder :: Lens' MAnnotations Int
newtype Script s a = Script
{ unScript ::
StreamT (Tokenize s)
(ReaderT Annotations
(StateT MAnnotations (Free (Term Annotate s)))) a
} deriving (Functor, Applicative, Monad, MonadReader Annotations)
instance Default a => Default (Script s a) where
def = return def
instance (scope ~ Actions, a ~ ()) => Eval (Script scope a) where
eval command args = actioned (\_ sfp -> Command sfp (RawCommand command args))
type family Tokenize (s :: Scope) :: *
type instance Tokenize Actions = Void
type instance Tokenize Sources = Token
runScript
:: MAnnotations
-> Annotations
-> Infinite (Tokenize s)
-> Script s a
-> (Free (Term Annotate s) a, MAnnotations)
runScript s e es (Script i) =
let r = runStateT (runReaderT (runStreamT es i) e) s
ast = fmap fst r
(_, as) = iter copoint r
in (ast, as)
evalScript
:: MAnnotations
-> Annotations
-> Infinite (Tokenize s)
-> Script s a
-> Free (Term Annotate s) a
evalScript = (((fst .) .) .) . runScript
script :: Term Annotate s a -> Script s a
script = Script . liftS
liftS
:: Term Annotate s a
-> StreamT (Tokenize s) (ReaderT Annotations (StateT MAnnotations (Free (Term Annotate s)))) a
liftS = lift . liftF
annotateActions
:: Script Actions a
-> StreamT Token
(ReaderT Annotations
(StateT MAnnotations (Free (Term Annotate Sources)))) (Free (Term Annotate Actions) a)
annotateActions i =
lift . ReaderT $ \e -> StateT $ \s -> return (runScript s e noTokens i)
sourced
:: String -> URI -> FilePath
-> Script Actions () -> (FilePath -> IO ()) -> Script Sources ()
sourced ty url path inner update = Script $ do
rfp <- view app
local (set sourcePath (constructTargetFilePath rfp url path) . set sourceURL url) $ do
token <- next
annotation <- AS
<$> pure token
<*> view profileName
<*> view activeUser
<*> view maxRetries
<*> view sourceReaction
order .= 0
maxOrder .= size inner
ast <- annotateActions inner
sfp <- view sourcePath
liftS $ TS annotation (Source ty url sfp update) ast ()
profiles . contains (asProfile annotation) .= True
size :: Script Actions a -> Int
size = iterFrom 0 go . evalScript def def noTokens
where
go :: Term Annotate Actions Int -> Int
go (TA _ _ result) = succ result
go (TM _ result) = result
iterFrom :: Functor f => a -> (f a -> a) -> Free f b -> a
iterFrom zero phi = go where
go (Pure _) = zero
go (Free m) = phi (go <$> m)
actioned :: (FilePath -> FilePath -> Action) -> Script Actions ()
actioned f = Script $ do
annotation <- AA
<$> view sourceURL
<*> (order <+= 1)
<*> use maxOrder
<*> view activeUser
<*> view maxRetries
<*> view actionReaction
rfp <- view app
sfp <- view sourcePath
liftS $ TA annotation (f rfp sfp) ()
constructTargetFilePath :: FilePath -> FilePath -> FilePath -> FilePath
constructTargetFilePath r s path =
r </> path </> case "/" `isSuffixOf` path of
True -> s^.filename
False -> ""
into :: FilePath -> FilePath
into = (++ "/")