{-# OPTIONS_GHC -fglasgow-exts -fno-monomorphism-restriction #-}

-- one grammar, two tasks: parsing and unparsing 
-- lambda-match allows us to mix string parsing and data parsing in the 
-- same monadic framework, so we can easily toggle between the two modes
-- (data parsing is used to "unparse" abstract into concrete syntax)

import Prelude hiding (exp,abs)
import Data.Char (isSpace,isAlpha)
import ControlMonadMatch
import ControlMonadMatchInstances
import Control.Monad.State

----------------------------------------------------------- abstract syntax

data Exp = Var String | App Exp Exp | Lam String Exp deriving Show

-------------------------------------- concrete syntax & conversion cs<->as

exp = var `mplus` app `mplus` abs

var = litp varPU
app = rule appPU $ do { lit "(" ; exp ; exp ; lit ")" }
abs = rule absPU $ do { lit "\\" ; var ; lit "." ; exp }

-- auxiliary functions for grammar
-- literals convert between concrete string and abstract expression on stack
-- nonliterals convert between abstract expression and subexpressions on stack

varPU = (|(Parse, s, st)         | let (hs,ts) = span isAlpha s, not (null hs) 
         -> (Parse,   ts,   Var hs:st))
    +++ (|(Unparse, s, Var v:st) | all isAlpha v 
         -> (Unparse, s++v, st))

appPU = (|(Parse,   s, e2:e1:st)    -> (Parse,   s, App e1 e2:st)) 
    +++ (|(Unparse, s, App e1 e2:st)-> (Unparse, s, e1:e2:st))

absPU = (|(Parse,   s, e:Var v:st)-> (Parse,   s, Lam v e:st))
    +++ (|(Unparse, s, Lam v e:st)-> (Unparse, s, Var v:e:st))

---------------------------------------------------------------- some examples

-- old-fashioned parsing
test1 = parse exp "x"
test2 = parse exp "(x y)"
test3 = parse exp "\\x.x"

-- unparsing, using the same grammar
test4 = unparse exp (Var "x")
test5 = unparse exp (App (Var "x") (Var "x"))
test6 = unparse exp (Lam "x" (Var "x"))

-- mixing parsing and unparsing
test7 = parse   (exp >> toggleMode >> exp) "(\\x.(x x) \\x.(x x))"
test8 = unparse (exp >> toggleMode >> exp) (App (Lam "x" (App (Var "x") (Var "x"))) 
                                                (Lam "x" (App (Var "x") (Var "x"))))

---------------------------------------------------------- the rest is generic

-- parser/unparser combinators; parser state

data Mode = Parse | Unparse deriving (Show,Eq)

type GrammarState = (Mode,String,[Exp])

type PunP a = StateT GrammarState [] a

parse   grammar s = runStateT grammar (Parse,s,[])
unparse grammar e = runStateT grammar (Unparse,"",[e])

modifyState m = get >>= m >>= put

checkMode m = modifyState (\state@(m',_,_)->guard (m==m') >> return state)
toggleMode  = modify $ \(m,s,st)->(case m of {Parse->Unparse;Unparse->Parse},s,st)

-- non-terminals
rule :: (GrammarState -> Match (StateT GrammarState []) GrammarState) -> PunP () -> PunP ()
rule pu grammar = ( checkMode Parse   >> grammar >> modifyState (ex id pu) )
          `mplus` ( checkMode Unparse >> modifyState (ex id pu) >> grammar )

-- terminals
litp :: (GrammarState -> Match (StateT GrammarState []) GrammarState) -> PunP ()
litp pu = ( modifyState (ex id skip) >> modifyState (ex id pu) ) 
  `mplus` ( modifyState (ex id pu)   >> modifyState (ex id fill) ) 

lit l = litp $ (|(Parse,  s,st) | let (hs,ts) = splitAt (length l) s, hs==l 
                                -> (Parse,ts,st) )
           +++ (|(Unparse,s,st) -> (Unparse,s++l,st) )

-- whitespace
skip = (|(Parse,   s, st) -> (Parse,   dropWhile isSpace s, st) )
fill = (|(Unparse, s, st) -> (Unparse, s++" ",              st) )