Grow.hs

{-# LANGUAGE UndecidableInstances #-}
module Language.Syntax.Grow(
  module Data.Syntax,
  growExpr
  ) where

import Definitive
import Language.Parser
import Data.Containers
import Data.Syntax
import Data.Char
import Language.Grow

instance MonadReader a Id where
  ask = Id undefined
  local _ = id
instance Monoid m => MonadWriter m Id where
  tell _ = pure ()
  listen (Id a) = Id (zero,a)
  censor (Id (a,f)) = Id a
instance MonadIO Id where
  liftIO a = pure undefined

-- ^ For debugging purposes
instance MonadGrow Id

growExpr :: MonadGrow m => Parser String [SyntaxT m]
growExpr = free expr `sepBy1` free (single ';')
  where
    decl = (,)<$>symbol<*>(free (single '=') >> free expr)
    free = (skipMany space >> )
    symbol = many1 (satisfy symChar) <+> quotedString '"'
      where symChar c = isAlphaNum c || (c`elem`".-_/+~%*!")
    funAp = (atom`sepBy1`spaces) <&> call
      where call [x] = x
            call t = ValList $ b_dollar : map pure t
    expr = chainr funAp (op <$> free (single ':' >> (atom <* space))) funAp 
      where op f a b = ValList [b_dollar,pure f,pure a,pure b]
    atom :: MonadGrow m => Parser String (SyntaxT m)
    atom = sum [
      between (single '(') (free $ single ')') (free inParen)
      ,list,dictionary,Text<$>symbol,dollar]
      where dollar = single '$' >> (atom <&> \e -> ValList [b_dollar,pure e])
    inParen = Function . lambdaSum<$>many1 (free (single '|' >> abstract))
              <+> expr
    abstract = lambda<$>atom<*>free (several "~>")*>free expr
    
    list = Quote . ValList . map pure
           <$>between (single '[') (free $ single ']') (free expr`sepBy`free (single ','))
    dictionary = mkDict<$>between (single '{') (free $ single '}') (free decl`sepBy`free (single ','))
    mkDict = Dictionary . fromList . map (\(s,v) -> (s,pure v))