{-# LANGUAGE Safe #-}

{-
  This module is part of Chatty.
  Copyleft (c) 2014 Marvin Cohrs

  All wrongs reversed. Sharing is an act of love, not crime.
  Please share Antisplice with everyone you like.

  Chatty is free software: you can redistribute it and/or modify
  it under the terms of the GNU Affero General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  Chatty is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  GNU Affero General Public License for more details.

  You should have received a copy of the GNU Affero General Public License
  along with Chatty. If not, see <http://www.gnu.org/licenses/>.
-}

module Text.Chatty.Expansion.History where

import Prelude hiding (id,(.))
import Control.Applicative
import Control.Arrow
import Control.Category (id,(.))
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Text.Chatty.Expansion

newtype HistoryT m a = History {
    HistoryT m a -> [String] -> m (a, [String])
runHistoryT :: [String] -> m (a,[String])
  }

instance Monad m => Monad (HistoryT m) where
  return :: a -> HistoryT m a
return a
a = ([String] -> m (a, [String])) -> HistoryT m a
forall (m :: * -> *) a.
([String] -> m (a, [String])) -> HistoryT m a
History (([String] -> m (a, [String])) -> HistoryT m a)
-> ([String] -> m (a, [String])) -> HistoryT m a
forall a b. (a -> b) -> a -> b
$ \[String]
s -> (a, [String]) -> m (a, [String])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,[String]
s)
  (History [String] -> m (a, [String])
h) >>= :: HistoryT m a -> (a -> HistoryT m b) -> HistoryT m b
>>= a -> HistoryT m b
f = ([String] -> m (b, [String])) -> HistoryT m b
forall (m :: * -> *) a.
([String] -> m (a, [String])) -> HistoryT m a
History (([String] -> m (b, [String])) -> HistoryT m b)
-> ([String] -> m (b, [String])) -> HistoryT m b
forall a b. (a -> b) -> a -> b
$ \[String]
s -> do (a
a,[String]
s') <- [String] -> m (a, [String])
h [String]
s; HistoryT m b -> [String] -> m (b, [String])
forall (m :: * -> *) a. HistoryT m a -> [String] -> m (a, [String])
runHistoryT (a -> HistoryT m b
f a
a) [String]
s'

instance MonadTrans HistoryT where
  lift :: m a -> HistoryT m a
lift m a
m = ([String] -> m (a, [String])) -> HistoryT m a
forall (m :: * -> *) a.
([String] -> m (a, [String])) -> HistoryT m a
History (([String] -> m (a, [String])) -> HistoryT m a)
-> ([String] -> m (a, [String])) -> HistoryT m a
forall a b. (a -> b) -> a -> b
$ \[String]
s -> do a
a <- m a
m; (a, [String]) -> m (a, [String])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,[String]
s)

instance MonadIO m => MonadIO (HistoryT m) where
  liftIO :: IO a -> HistoryT m a
liftIO = m a -> HistoryT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> HistoryT m a) -> (IO a -> m a) -> IO a -> HistoryT m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance Monad m => Functor (HistoryT m) where
  fmap :: (a -> b) -> HistoryT m a -> HistoryT m b
fmap a -> b
f HistoryT m a
a = ([String] -> m (b, [String])) -> HistoryT m b
forall (m :: * -> *) a.
([String] -> m (a, [String])) -> HistoryT m a
History (([String] -> m (b, [String])) -> HistoryT m b)
-> ([String] -> m (b, [String])) -> HistoryT m b
forall a b. (a -> b) -> a -> b
$ \[String]
s -> do (a
a',[String]
s') <- HistoryT m a -> [String] -> m (a, [String])
forall (m :: * -> *) a. HistoryT m a -> [String] -> m (a, [String])
runHistoryT HistoryT m a
a [String]
s; (b, [String]) -> m (b, [String])
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f a
a',[String]
s')

instance Monad m => Applicative (HistoryT m) where
  <*> :: HistoryT m (a -> b) -> HistoryT m a -> HistoryT m b
(<*>) = HistoryT m (a -> b) -> HistoryT m a -> HistoryT m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
  pure :: a -> HistoryT m a
pure = a -> HistoryT m a
forall (m :: * -> *) a. Monad m => a -> m a
return

class Monad he => ChHistoryEnv he where
  mcounth :: he Int
  mgeth :: Int -> he String
  mputh :: String -> he ()

instance Monad m => ChHistoryEnv (HistoryT m) where
  mcounth :: HistoryT m Int
mcounth = ([String] -> m (Int, [String])) -> HistoryT m Int
forall (m :: * -> *) a.
([String] -> m (a, [String])) -> HistoryT m a
History (([String] -> m (Int, [String])) -> HistoryT m Int)
-> ([String] -> m (Int, [String])) -> HistoryT m Int
forall a b. (a -> b) -> a -> b
$ Kleisli m [String] (Int, [String]) -> [String] -> m (Int, [String])
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli (([String] -> Int) -> Kleisli m [String] Int
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Kleisli m [String] Int
-> Kleisli m [String] [String]
-> Kleisli m [String] (Int, [String])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Kleisli m [String] [String]
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id)
  mgeth :: Int -> HistoryT m String
mgeth Int
i
    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = let j :: Int
j = -Int
i in ([String] -> m (String, [String])) -> HistoryT m String
forall (m :: * -> *) a.
([String] -> m (a, [String])) -> HistoryT m a
History (([String] -> m (String, [String])) -> HistoryT m String)
-> ([String] -> m (String, [String])) -> HistoryT m String
forall a b. (a -> b) -> a -> b
$ Kleisli m [String] (String, [String])
-> [String] -> m (String, [String])
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli (([String] -> String) -> Kleisli m [String] String
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ([String] -> Int -> String
forall a. [a] -> Int -> a
!!Int
j) Kleisli m [String] String
-> Kleisli m [String] [String]
-> Kleisli m [String] (String, [String])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Kleisli m [String] [String]
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id)
    | Bool
otherwise = ([String] -> m (String, [String])) -> HistoryT m String
forall (m :: * -> *) a.
([String] -> m (a, [String])) -> HistoryT m a
History (([String] -> m (String, [String])) -> HistoryT m String)
-> (Kleisli m [String] (String, [String])
    -> [String] -> m (String, [String]))
-> Kleisli m [String] (String, [String])
-> HistoryT m String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Kleisli m [String] (String, [String])
-> [String] -> m (String, [String])
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli (Kleisli m [String] (String, [String]) -> HistoryT m String)
-> Kleisli m [String] (String, [String]) -> HistoryT m String
forall a b. (a -> b) -> a -> b
$ ([String] -> (String, [String]))
-> Kleisli m [String] (String, [String])
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (([String] -> Int -> String
forall a. [a] -> Int -> a
!!Int
i)([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.[String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> String)
-> ([String] -> [String]) -> [String] -> (String, [String])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [String] -> [String]
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id)
  mputh :: String -> HistoryT m ()
mputh String
s = ([String] -> m ((), [String])) -> HistoryT m ()
forall (m :: * -> *) a.
([String] -> m (a, [String])) -> HistoryT m a
History (([String] -> m ((), [String])) -> HistoryT m ())
-> (Kleisli m [String] ((), [String])
    -> [String] -> m ((), [String]))
-> Kleisli m [String] ((), [String])
-> HistoryT m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Kleisli m [String] ((), [String]) -> [String] -> m ((), [String])
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli (Kleisli m [String] ((), [String]) -> HistoryT m ())
-> Kleisli m [String] ((), [String]) -> HistoryT m ()
forall a b. (a -> b) -> a -> b
$ ([String] -> ((), [String])) -> Kleisli m [String] ((), [String])
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (() -> [String] -> ()
forall a b. a -> b -> a
const () ([String] -> ())
-> ([String] -> [String]) -> [String] -> ((), [String])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:))

expandHist :: ChHistoryEnv h => String -> h String
expandHist :: String -> h String
expandHist [] = String -> h String
forall (m :: * -> *) a. Monad m => a -> m a
return []
expandHist (Char
'!':String
ss) =
  let (String
nm,String
rm) = ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isNum (String -> String)
-> (String -> String) -> String -> (String, String)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isNum) String
ss
      isNum :: Char -> Bool
isNum Char
a = Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
a [Char
'0'..Char
'9'] Bool -> Bool -> Bool
|| (Char
aChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'-')
  in case String
nm of
    [] -> do
      String
ss' <- String -> h String
forall (h :: * -> *). ChHistoryEnv h => String -> h String
expandHist String
ss
      String -> h String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'!'Char -> String -> String
forall a. a -> [a] -> [a]
:String
ss')
    String
_ -> do
      String
hs <- String -> h String
forall (h :: * -> *). ChHistoryEnv h => String -> h String
expandHist String
rm
      String
h <- Int -> h String
forall (he :: * -> *). ChHistoryEnv he => Int -> he String
mgeth (Int -> h String) -> Int -> h String
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
read String
nm
      String -> h String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
hString -> String -> String
forall a. [a] -> [a] -> [a]
++String
hs)
expandHist (Char
s:String
ss) = do String
ss' <- String -> h String
forall (h :: * -> *). ChHistoryEnv h => String -> h String
expandHist String
ss; String -> h String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
sChar -> String -> String
forall a. a -> [a] -> [a]
:String
ss')

instance ChExpand m => ChExpand (HistoryT m) where
  expand :: String -> HistoryT m String
expand = m String -> HistoryT m String
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m String -> HistoryT m String)
-> (String -> m String) -> String -> HistoryT m String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> m String
forall (e :: * -> *). ChExpand e => String -> e String
expand (String -> HistoryT m String)
-> (String -> HistoryT m String) -> String -> HistoryT m String
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> HistoryT m String
forall (h :: * -> *). ChHistoryEnv h => String -> h String
expandHist

withHistory :: Monad m => HistoryT m a -> m a
withHistory :: HistoryT m a -> m a
withHistory = ((a, [String]) -> a) -> m (a, [String]) -> m a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a, [String]) -> a
forall a b. (a, b) -> a
fst (m (a, [String]) -> m a)
-> (HistoryT m a -> m (a, [String])) -> HistoryT m a -> m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (HistoryT m a -> [String] -> m (a, [String]))
-> [String] -> HistoryT m a -> m (a, [String])
forall a b c. (a -> b -> c) -> b -> a -> c
flip HistoryT m a -> [String] -> m (a, [String])
forall (m :: * -> *) a. HistoryT m a -> [String] -> m (a, [String])
runHistoryT []