Grow-1.1: Language/Grow.hs

{-# LANGUAGE RankNTypes #-}
module Language.Grow where

import Definitive
import IO.Filesystem
import Language.Parser
import IO.Time
import Data.Syntax
import Data.Containers
import System.Process
import System.IO.Unsafe (unsafeInterleaveIO)
import Control.Concurrent (forkIO,newEmptyMVar,putMVar,takeMVar)
import System.Directory (getDirectoryContents)

il = liftIO . unsafeInterleaveIO

type GrowSt = Env Growing
type TimeStamp = Max (TimeVal Seconds)
newtype Growing a = Growing (ReaderT GrowSt (WriterT TimeStamp IO) a)
                  deriving (Functor,Applicative,Unit,Monad,
                            MonadFix,MonadWriter TimeStamp,MonadReader GrowSt,MonadIO)
_Growing :: Iso (Growing a) (Growing b) (ReaderT GrowSt (WriterT TimeStamp IO) a) (ReaderT GrowSt (WriterT TimeStamp IO) b)
_Growing = iso Growing (\(Growing a) -> a)

class (MonadWriter TimeStamp m,MonadReader (Env m) m,MonadIO m) => MonadGrow m
instance MonadGrow Growing

instance Semigroup (SyntaxT f) where
  Text t + Text t' = Text (t+t')
  ValList l + ValList l' = ValList (l+l')
  Dictionary d + Dictionary d' = Dictionary (d+d')
  Function f + Function f' = Function (f'.f)
  a + ValList [] = a
  ValList [] + a = a
  a + b = error $ "Illegal shape for + "+shape a+" "+shape b
instance Monoid (SyntaxT f) where
  zero = nil

initial :: GrowSt
initial = fromList [
  ("+", builtin2 $ liftA2 (+)),
  ("cache", b_cache),
  ("hook", b_hook),
  ("words", b_words),
  ("head", b_head),
  ("tee", b_tee),
  ("in", b_in),
  ("eval",b_eval),
  ("environment", pure (Dictionary initial)),
  ("keys", b_keys),
  ("fold", b_fold),
  ("shape", b_shape),
  ("map", b_map),
  ("seq", b_seq),
  ("lambda", b_lambda),
  ("ls", b_ls)
  ]
  where 

type Builtin = forall m. MonadGrow m => ThunkT m

illegalShape fun args = error $ "Illegal shape for function '"+fun+"' : "+show (shape<$>args)

b_ls, b_lambda, b_seq, b_map,b_shape, b_fold, b_keys, b_eval, b_head, b_words, b_hook, b_cache, b_in, b_tee, b_dollar :: Builtin
b_ls = builtin (mute >=> ls)
  where ls (Text s) = do
          tell $ Max (modTime s^.thunk)
          return $ ValList [pure (Text (s+"/"+n)) | n <- getDirectoryContents s^.thunk]
            
b_lambda = builtin2 (\a b -> a >>= flip lambda b)
  where lambda (Text v) x = pure (Function (\a -> local (insert v a) x)) 
        lambda x _ = illegalShape "lambda" [x]
b_seq = builtin2 (liftA2 _seq)
  where _seq (Text _) a = a
        _seq _ a = a
b_map = builtin2 (liftA2 _map)
  where _map (Function f) (ValList l) = ValList (map f l)
        _map (Function f) (Dictionary d) = Dictionary (map f d)
        _map x y = illegalShape "map" [x,y]
b_eval = builtin (>>= reduce)
b_shape = builtin (map (Text . shape))
b_fold = builtin (>>= _fold)
  where _fold (ValList l) = fold<$>sequence l
        _fold (Dictionary d) = fold<$>sequence d
        _fold x = illegalShape "fold" [x]

b_keys = builtin (map _keys)
  where _keys (Dictionary d) = ValList (pure . Text . fst <$> toList (d^.keyed))
        _keys x = illegalShape "keys" [x]
b_head = builtin (>>= _head)
  where _head (ValList (h:t)) = h
        _head x = illegalShape "head" [x]
    
b_words = builtin (map _words)
  where _words (Text t) = ValList [pure (Text w) | w <- words t]
b_hook = builtin3 (bind3 hook)
  where hook (Text prg) (ValList dsts) (ValList args) = do
          (args,dsts) <- mute ((,)<$>sequence args<*>sequence dsts)
          (tsrc,srcVals) <- intercept (traverse getVal args)
          (tdsts,dstVals) <- unzip <$> traverse (intercept . getVal) dsts
          done <- when (any (liftA2 (||) (<tsrc) (==zero)) tdsts) $ il $ do
            vars <- sequence (newEmptyMVar<$srcVals)
            tids <- for (zip vars srcVals) $ \(v,x) -> do
              forkIO $ x^..thunk >> putMVar v ()
            traverse_ takeMVar vars
            callProcess ("./"+prg) [t | Text t <- dsts + args]
          let dstFile n = tell (Max (modTime n^.thunk) + tsrc) >> seq done . Text <$> il (readString n)
          pure (Dictionary $ fromList [(n,dstFile n) | Text n <- dsts])
b_cache = builtin2 $ \x y -> bind2 cache x (listen y)
  where cache (Text f) (Max t,Text c) = do
          t' <- liftIO (modTime f) 
          if t>t' then
             Text c <$ liftIO (writeString f c)
            else Text<$> il (readString f)
        cache x (_,y) = illegalShape "cache" [x,y]
  
b_in = builtin2 $ \e d -> mute d >>= \(Dictionary d') -> local (d'+) e

b_tee = builtin (>>= tee)
  where tee (Text t) = Text t <$ liftIO (putStrLn t)
        tee x = illegalShape "tee" [x]
b_dollar = builtin (mute >=> getVal)

getVal :: MonadGrow m => SyntaxT m -> ThunkT m
getVal (Text t) = ask >>= \d -> sequence (d^.at t) >>= \case
  Nothing -> do
    stamp <- liftIO (Max<$>modTime t)
    Text (readString t^.thunk) <$ tell stamp
  Just x -> pure x
getVal x = illegalShape "getVal" [x]

grow :: String -> Growing a -> IO (TimeStamp,a)
grow t g = (g^..mapping writerT.readerT._Growing) (insert "arg" (pure (Text t)) initial)