{-# LANGUAGE UndecidableInstances, LambdaCase, ParallelListComp, ViewPatterns #-}
module Data.Syntax where

import Algebra
import Data.Containers
import qualified Prelude as P
import Algebra.Parser.Regex

type Env f = Map String (ThunkT f)
type Eval f = Env f -> ThunkT f
type ThunkT f = f (SyntaxT f)
data SyntaxT f = ValList [ThunkT f]
              | Dictionary (Env f)
              | Text String
              | Function (ThunkT f -> ThunkT f)
instance Show (ThunkT f) => Show (SyntaxT f) where
  show (ValList l) = show l
  show (Dictionary d) = "{"+show (toList (map show d^.keyed))+"}"
  show (Text t) = show t
  show (Function _) = "<fun>"

dict :: Traversal' (SyntaxT f) (Env f)
dict = prism f g
  where f (Dictionary d) = Right d
        f c = Left c
        g (Dictionary _) d = Dictionary d
        g x _ = x

nil :: SyntaxT f
nil = ValList zero
variable :: Unit f => String -> SyntaxT f -> SyntaxT f
variable n v = Dictionary (fromList [("name",pure $ Text n),("value",pure v)])
funcall :: ThunkT f -> ThunkT f -> SyntaxT f
funcall f x = ValList [f,x]

reduce :: MonadReader (Env m) m => SyntaxT m -> ThunkT m
reduce (ValList (map (>>= reduce) -> (fun:args))) = fun >>= \f -> foldlM call f args
  where call (Function f) x = f x
        call _ _ = error "Invalid function call"
reduce (Dictionary d) = pure $ Dictionary $ fix (\d' -> map (local (d'+) . (>>= reduce)) d)
reduce a = pure a

list_ :: [a] -> [a]
list_ = id
lambda :: MonadReader (Env m) m => SyntaxT Id -> SyntaxT m -> (ThunkT m -> ThunkT m)
lambda pat e = tryAlt
  where tryAlt x = x >>= match >>= maybe (pure nil) bind
          where bind vars = local (compose (_insert<$>list_ vars)) (reduce e)
                  where _insert (s,v) = insert s (pure v)
                match = matchPat pat
matchPat :: Monad f => SyntaxT Id -> (SyntaxT f -> f (Maybe [(String,SyntaxT f)]))
matchPat (Text re) = pure.matchText
  where matchText (Text t) | ((a,wh):_) <- match t = pure $ map2 Text (("&",wh):a)
        matchText _ = zero
        match = runRegex re
matchPat (Dictionary d) = matchDict
  where matchDict (Dictionary d') = 
          traverse (matches d') (toList pats) <&> map concat.sequence
        matchDict _ = pure zero
        pats = (matchPat.yb _Id<$>d)^.keyed
        matches d' (k,m) = maybe (pure zero) (>>= m) (d'^.at k)
matchPat (ValList l) = matchList
  where n = length l
        matchList (ValList l') | length (take n l') == n =
          sequence [matchPat p =<< e | p <- yb _Id<$>l | e <- l'] <&> map concat.sequence
        matchList _ = pure zero
matchPat _ = pure (pure zero)

lambdaSum :: Monad m => [ThunkT m -> ThunkT m] -> ThunkT m -> ThunkT m
lambdaSum = foldr combine (const (pure nil))
  where combine f g = \v -> f v >>= \case
          ValList [] -> g v
          x -> pure x