{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

import           Control.Applicative
import           Control.Lens.Cons
import           Control.Lens.SemiIso
import           Control.Lens.TH
import qualified Data.Attoparsec.Text as AP
import           Data.Char
import           Data.Scientific (Scientific)
import           Data.SemiIsoFunctor
import           Data.Syntax (Syntax)
import qualified Data.Syntax as S
import qualified Data.Syntax.Attoparsec.Text as S
import           Data.Syntax.Char (SyntaxChar)
import qualified Data.Syntax.Char as S
import qualified Data.Syntax.Combinator as S
import qualified Data.Syntax.Pretty as S
import           Data.Text (Text)
import qualified Data.Text.IO as T
import qualified Text.PrettyPrint as P

-- A simple lambda calculus.

data Literal = LitStr Text
             | LitNum Scientific
    deriving (Show)

$(makePrisms ''Literal)

data AST = Var Text
         | Lit Literal
         | App AST AST
         | Abs Text AST
         | Let Text AST AST
    deriving (Show)

$(makePrisms ''AST)

-- | A variable name.
name :: Syntax syn Text => syn Text
name = _Cons /$/ S.satisfy isAlpha /*/ S.takeWhile isAlphaNum

-- | A quoted string.
quoted :: SyntaxChar syn seq => syn seq
quoted = S.char '"' */ S.takeTill (=='"') /* S.char '"'

-- | Encloses a symbol in parentheses.
parens :: SyntaxChar syn seq => syn a -> syn a
parens m = S.char '(' */ S.spaces_ */ m /* S.spaces_ /* S.char ')'

-- | A literal.
literal :: SyntaxChar syn Text => syn Literal
literal =  _LitNum /$/ S.scientific
       /|/ _LitStr /$/ quoted

-- | An atom is a variable, literal or an expression in parentheses.
atom :: SyntaxChar syn Text => syn AST
atom =  _Lit /$/ literal
    /|/ _Var /$/ name
    /|/ parens expr

-- | Parses a list of atoms and folds them with the _App prism.
apps :: SyntaxChar syn Text => syn AST
apps = bifoldl1 _App /$/ S.sepBy1 atom S.spaces1

-- | An expression of our lambda calculus.
--
-- Thanks to 'tuple-morph' we don't have to worry about /* and */ here.
-- Tuples are reassociated and units are removed by the 'morphed'
-- isomorphism (applied in /$~ operator).
expr :: SyntaxChar syn Text => syn AST
expr =  _Abs /$~ S.char '\\'    /*/ S.spaces_
             /*/ name           /*/ S.spaces
             /*/  S.string "->" /*/ S.spaces
             /*/ expr

    /|/ _Let /$~ S.string "let" /*/ S.spaces1
             /*/ name           /*/ S.spaces
             /*/ S.char '='     /*/ S.spaces
             /*/ expr           /*/ S.spaces1
             /*/ S.string "in"  /*/ S.spaces1
             /*/ expr

    /|/ apps

main :: IO ()
main = do
    -- Load the standard input.
    t <- T.getContents

    -- Try to parse it.
    case AP.parseOnly (S.getParser expr <* AP.skipSpace <* AP.endOfInput) t of
      Left err  -> putStrLn err
      Right ast -> do
        -- If parsing succeeded print the AST.
        print ast
        
        -- Try to pretty print it.
        -- (Printing cannot really fail in this example)
        case S.runPrinter expr ast of
          Left err  -> putStrLn err
          Right doc -> putStrLn (P.render doc)

    return ()