{-# LANGUAGE PackageImports #-}

module Text.Papillon.Parser (
	Peg,
	Definition,
	NameLeaf,
	parse,
	dv_peg,
	dv_pegFile,
	Leaf_(..)
) where

import Data.Char
import Control.Monad
import "monads-tf" Control.Monad.State
import Language.Haskell.TH

type Nil = ()
type Leaf = Either String ExR
data Leaf_ = NotAfter Leaf | Here Leaf
notAfter, here :: Leaf -> Leaf_
notAfter = NotAfter
here = Here
type NameLeaf = (Name, Leaf_)
type Expression = [NameLeaf]
type ExpressionHs = (Expression, ExR)
type Selection = [ExpressionHs]
type Typ = Name
type Definition = (String, Typ, Selection)
type Peg = [Definition]

type Ex = ExpQ -> ExpQ
type ExR = ExpQ

left :: b -> Either a b
right :: a -> Either a b
left = Right
right = Left

nil :: Nil
nil = ()

cons :: a -> [a] -> [a]
cons = (:)
mkNameLeaf :: String -> b -> (Name, b)
mkNameLeaf x y = (mkName x, y)
mkExpressionHs :: a -> Ex -> (a, ExR)
mkExpressionHs x y = (x, getEx y)
mkDef :: a -> String -> c -> (a, Name, c)
mkDef x y z = (x, mkName y, z)

toExp :: String -> Ex
toExp v = \f -> f `appE` varE (mkName v)

apply :: String -> Ex -> Ex
apply f x = \g -> x (toExp f g)

getEx :: Ex -> ExR
getEx ex = ex (varE $ mkName "id")

empty :: [a]
empty = []

type PegFile = (String, Peg, String)
mkPegFile :: a -> b -> c -> (a, b, c)
mkPegFile = (,,)

true :: Bool
true = True

isEqual, isSlash, isSemi,
	isColon, isOpenWave, isCloseWave, isLowerU, isNot :: Char -> Bool
isEqual = (== '=')
isSlash = (== '/')
isSemi = (== ';')
isColon = (== ':')
isOpenWave = (== '{')
isCloseWave = (== '}')
isLowerU c = isLower c || c == '_'
isNot = (== '!')

isOpenBr, isP, isA, isI, isL, isO, isN, isBar, isCloseBr, isNL :: Char -> Bool
[isOpenBr, isP, isA, isI, isL, isO, isN, isBar, isCloseBr, isNL] =
	map (==) "[pailon|]\n"

flipMaybe :: StateT s Maybe a -> StateT s Maybe ()
flipMaybe action = StateT $ \s -> case runStateT action s of
	Nothing -> Just ((), s)
	_ -> Nothing

type PackratM = StateT Derivs Maybe
type Result v = Maybe ((v, Derivs))
data Derivs
    = Derivs {dv_pegFile :: (Result PegFile),
              dv_prePeg :: (Result String),
              dv_afterPeg :: (Result String),
              dv_pap :: (Result Nil),
              dv_peg :: (Result Peg),
              dv_definition :: (Result Definition),
              dv_selection :: (Result Selection),
              dv_expressionHs :: (Result ExpressionHs),
              dv_expression :: (Result Expression),
              dv_nameLeaf :: (Result NameLeaf),
              dv_leaf_ :: (Result Leaf_),
              dv_leaf :: (Result Leaf),
              dv_test :: (Result ExR),
              dv_hsExp :: (Result Ex),
              dv_typ :: (Result String),
              dv_variable :: (Result String),
              dv_tvtail :: (Result String),
              dv_alpha :: (Result Char),
              dv_upper :: (Result Char),
              dv_lower :: (Result Char),
              dv_digit :: (Result Char),
              dv_spaces :: (Result Nil),
              dv_space :: (Result Nil),
              dvChars :: (Result Char)}
parse :: String -> Derivs
parse s = d
          where d = Derivs pegFile prePeg afterPeg pap peg definition selection expressionHs expression nameLeaf leaf_ leaf test hsExp typ variable tvtail alpha upper lower digit spaces space char
                pegFile = runStateT p_pegFile d
                prePeg = runStateT p_prePeg d
                afterPeg = runStateT p_afterPeg d
                pap = runStateT p_pap d
                peg = runStateT p_peg d
                definition = runStateT p_definition d
                selection = runStateT p_selection d
                expressionHs = runStateT p_expressionHs d
                expression = runStateT p_expression d
                nameLeaf = runStateT p_nameLeaf d
                leaf_ = runStateT p_leaf_ d
                leaf = runStateT p_leaf d
                test = runStateT p_test d
                hsExp = runStateT p_hsExp d
                typ = runStateT p_typ d
                variable = runStateT p_variable d
                tvtail = runStateT p_tvtail d
                alpha = runStateT p_alpha d
                upper = runStateT p_upper d
                lower = runStateT p_lower d
                digit = runStateT p_digit d
                spaces = runStateT p_spaces d
                space = runStateT p_space d
                char = flip runStateT d (do c : s' <- return s
                                            put (parse s')
                                            return c)
dv_pegFileM :: PackratM PegFile
dv_prePegM :: PackratM String
dv_afterPegM :: PackratM String
dv_papM :: PackratM Nil
dv_pegM :: PackratM Peg
dv_definitionM :: PackratM Definition
dv_selectionM :: PackratM Selection
dv_expressionHsM :: PackratM ExpressionHs
dv_expressionM :: PackratM Expression
dv_nameLeafM :: PackratM NameLeaf
dv_leaf_M :: PackratM Leaf_
dv_leafM :: PackratM Leaf
dv_testM :: PackratM ExR
dv_hsExpM :: PackratM Ex
dv_typM :: PackratM String
dv_variableM :: PackratM String
dv_tvtailM :: PackratM String
dv_alphaM :: PackratM Char
dv_upperM :: PackratM Char
dv_lowerM :: PackratM Char
dv_digitM :: PackratM Char
dv_spacesM :: PackratM Nil
dv_spaceM :: PackratM Nil
dv_pegFileM = StateT dv_pegFile
dv_prePegM = StateT dv_prePeg
dv_afterPegM = StateT dv_afterPeg
dv_papM = StateT dv_pap
dv_pegM = StateT dv_peg
dv_definitionM = StateT dv_definition
dv_selectionM = StateT dv_selection
dv_expressionHsM = StateT dv_expressionHs
dv_expressionM = StateT dv_expression
dv_nameLeafM = StateT dv_nameLeaf
dv_leaf_M = StateT dv_leaf_
dv_leafM = StateT dv_leaf
dv_testM = StateT dv_test
dv_hsExpM = StateT dv_hsExp
dv_typM = StateT dv_typ
dv_variableM = StateT dv_variable
dv_tvtailM = StateT dv_tvtail
dv_alphaM = StateT dv_alpha
dv_upperM = StateT dv_upper
dv_lowerM = StateT dv_lower
dv_digitM = StateT dv_digit
dv_spacesM = StateT dv_spaces
dv_spaceM = StateT dv_space
dvCharsM :: PackratM Char
dvCharsM = StateT dvChars
p_pegFile :: PackratM PegFile
p_prePeg :: PackratM String
p_afterPeg :: PackratM String
p_pap :: PackratM Nil
p_peg :: PackratM Peg
p_definition :: PackratM Definition
p_selection :: PackratM Selection
p_expressionHs :: PackratM ExpressionHs
p_expression :: PackratM Expression
p_nameLeaf :: PackratM NameLeaf
p_leaf_ :: PackratM Leaf_
p_leaf :: PackratM Leaf
p_test :: PackratM ExR
p_hsExp :: PackratM Ex
p_typ :: PackratM String
p_variable :: PackratM String
p_tvtail :: PackratM String
p_alpha :: PackratM Char
p_upper :: PackratM Char
p_lower :: PackratM Char
p_digit :: PackratM Char
p_spaces :: PackratM Nil
p_space :: PackratM Nil
p_pegFile = msum [do pp <- dv_prePegM
                     _ <- dv_papM
                     p <- dv_pegM
                     _ <- dv_spacesM
                     b <- dvCharsM
                     if id isBar b then return () else fail "not match"
                     c <- dvCharsM
                     if id isCloseBr c then return () else fail "not match"
                     n <- dvCharsM
                     if id isNL n then return () else fail "not match"
                     atp <- dv_afterPegM
                     return (id mkPegFile pp p atp)]
p_prePeg = msum [do d <- get
                    flipMaybe dv_papM
                    put d
                    c <- dvCharsM
                    if id const true c then return () else fail "not match"
                    pp <- dv_prePegM
                    return (id cons c pp),
                 do return (id empty)]
p_afterPeg = msum [do c <- dvCharsM
                      if id const true c then return () else fail "not match"
                      atp <- dv_afterPegM
                      return (id cons c atp),
                   do return (id empty)]
p_pap = msum [do nl <- dvCharsM
                 if id isNL nl then return () else fail "not match"
                 ob <- dvCharsM
                 if id isOpenBr ob then return () else fail "not match"
                 p <- dvCharsM
                 if id isP p then return () else fail "not match"
                 a <- dvCharsM
                 if id isA a then return () else fail "not match"
                 pp <- dvCharsM
                 if id isP pp then return () else fail "not match"
                 i <- dvCharsM
                 if id isI i then return () else fail "not match"
                 l <- dvCharsM
                 if id isL l then return () else fail "not match"
                 ll <- dvCharsM
                 if id isL ll then return () else fail "not match"
                 o <- dvCharsM
                 if id isO o then return () else fail "not match"
                 n <- dvCharsM
                 if id isN n then return () else fail "not match"
                 b <- dvCharsM
                 if id isBar b then return () else fail "not match"
                 nll <- dvCharsM
                 if id isNL nll then return () else fail "not match"
                 return (id nil)]
p_peg = msum [do _ <- dv_spacesM
                 d <- dv_definitionM
                 p <- dv_pegM
                 return (id cons d p),
              do return (id empty)]
p_definition = msum [do v <- dv_variableM
                        _ <- dv_spacesM
                        c <- dvCharsM
                        if id isColon c then return () else fail "not match"
                        cc <- dvCharsM
                        if id isColon cc then return () else fail "not match"
                        _ <- dv_spacesM
                        t <- dv_typM
                        _ <- dv_spacesM
                        e <- dvCharsM
                        if id isEqual e then return () else fail "not match"
                        _ <- dv_spacesM
                        sel <- dv_selectionM
                        _ <- dv_spacesM
                        s <- dvCharsM
                        if id isSemi s then return () else fail "not match"
                        return (id mkDef v t sel)]
p_selection = msum [do ex <- dv_expressionHsM
                       _ <- dv_spacesM
                       e <- dvCharsM
                       if id isSlash e then return () else fail "not match"
                       _ <- dv_spacesM
                       sel <- dv_selectionM
                       return (id cons ex sel),
                    do ex <- dv_expressionHsM
                       return (id cons ex empty)]
p_expressionHs = msum [do e <- dv_expressionM
                          _ <- dv_spacesM
                          o <- dvCharsM
                          if id isOpenWave o then return () else fail "not match"
                          _ <- dv_spacesM
                          h <- dv_hsExpM
                          _ <- dv_spacesM
                          c <- dvCharsM
                          if id isCloseWave c then return () else fail "not match"
                          return (id mkExpressionHs e h)]
p_expression = msum [do l <- dv_nameLeafM
                        _ <- dv_spacesM
                        e <- dv_expressionM
                        return (id cons l e),
                     do return (id empty)]
p_nameLeaf = msum [do n <- dv_variableM
                      c <- dvCharsM
                      if id isColon c then return () else fail "not match"
                      l <- dv_leaf_M
                      return (id mkNameLeaf n l)]
p_leaf_ = msum [do n <- dvCharsM
                   if id isNot n then return () else fail "not match"
                   l <- dv_leafM
                   return (id notAfter l),
                do l <- dv_leafM
                   return (id here l)]
p_leaf = msum [do t <- dv_testM
                  return (id left t),
               do v <- dv_variableM
                  return (id right v)]
p_test = msum [do o <- dvCharsM
                  if id isOpenBr o then return () else fail "not match"
                  h <- dv_hsExpM
                  c <- dvCharsM
                  if id isCloseBr c then return () else fail "not match"
                  return (id getEx h)]
p_hsExp = msum [do v <- dv_variableM
                   _ <- dv_spacesM
                   h <- dv_hsExpM
                   return (id apply v h),
                do v <- dv_variableM
                   return (id toExp v)]
p_typ = msum [do u <- dv_upperM
                 t <- dv_tvtailM
                 return (id cons u t)]
p_variable = msum [do l <- dv_lowerM
                      t <- dv_tvtailM
                      return (id cons l t)]
p_tvtail = msum [do a <- dv_alphaM
                    t <- dv_tvtailM
                    return (id cons a t),
                 do return (id empty)]
p_alpha = msum [do u <- dv_upperM
                   return (id u),
                do l <- dv_lowerM
                   return (id l),
                do d <- dv_digitM
                   return (id d)]
p_upper = msum [do u <- dvCharsM
                   if id isUpper u then return () else fail "not match"
                   return (id u)]
p_lower = msum [do l <- dvCharsM
                   if id isLowerU l then return () else fail "not match"
                   return (id l)]
p_digit = msum [do d <- dvCharsM
                   if id isDigit d then return () else fail "not match"
                   return (id d)]
p_spaces = msum [do _ <- dv_spaceM
                    _ <- dv_spacesM
                    return (id nil),
                 do return (id nil)]
p_space = msum [do l <- dvCharsM
                   if id isSpace l then return () else fail "not match"
                   return (id nil)]