{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE LambdaCase #-}

module SfxScripting (
  module Exports,
  showText,
  ToText(..),
  pathToText,
  LoopM,
  breakL, continueL, loopM,
  ) where

import BasePrelude as Exports hiding (
  fold, die, printf, (%), option, stripPrefix, sort, sortOn, sortBy,
  nub, FilePath, find )
import Turtle as Exports hiding ( toText )
import qualified Turtle as Turtle
import qualified Data.Text as T

class ToText a where
  toText :: a -> Text

showText :: Show a => a -> Text
showText = T.pack . show

instance ToText Text where
  toText = id

instance ToText String where
  toText = T.pack

instance ToText FilePath where
  toText = either id id . Turtle.toText

pathToText :: FilePath -> Text
pathToText = toText

data LoopState r a = Done r | Next | Value a
  deriving (Eq,Ord,Show,Functor,Foldable,Traversable)

newtype LoopM m r a = LoopM { unLoopM :: m (LoopState r a) }
  deriving (Functor)

instance Applicative m => Applicative (LoopM m r) where
  pure = LoopM . pure . Value
  LoopM mf <*> LoopM mx = LoopM (app <$> mf <*> mx)
    where app (Value f) (Value x) = Value (f x)
          app (Value {}) (Done r) = Done r
          app (Value {}) Next = Next
          app (Done r) _ = Done r
          app Next _ = Next

instance Monad m => Monad (LoopM m r) where
  return = pure
  LoopM m >>= f = LoopM $ do
    m >>= \case
      Value x -> unLoopM (f x)
      Done r -> return (Done r)
      Next -> return Next

loopM :: (Monad m, Foldable t) => r -> t a -> (a -> LoopM m r ()) -> m r
loopM r0 xs0 f = go (toList xs0)
  where
    go [] = return r0
    go (x:xs) = do
      unLoopM (f x) >>= \case
        Value _ -> go xs
        Done r -> return r
        Next -> go xs

breakL :: Applicative m => r -> LoopM m r a
breakL = LoopM . pure . Done

continueL :: Applicative m => LoopM m r a
continueL = LoopM (pure Next)