{-# LANGUAGE RankNTypes, TypeFamilies, RelaxedPolyRec, FlexibleInstances #-}

{-
Like Expr, but using only elementary parser combinators.
-}

module SimpleExpr where

import Control.Applicative
import Control.Monad
import TreeParser
import ParseTree hiding (down)
import ExprLexer hiding (Num)
import qualified ExprLexer as E
import Token
import Data.Maybe
import ParserClass
import SucParser
import ErrorPath

data Expr
  = Add Expr Expr
  | Sub Expr Expr
  | Mul Expr Expr
  | Num Int
  deriving (Eq, Show, Read)

data ExprAlgE e a = ExprAlgE
  { aAdd :: a -> a -> Either e a
  , aSub :: a -> a -> Either e a
  , aMul :: a -> a -> Either e a
  , aNum :: Int ->    Either e a
  }

instance Num Expr where
  (+) = Add
  (-) = Sub
  (*) = Mul
  fromInteger = Num . fromIntegral
  abs = undefined
  signum = undefined

foldExprE :: ExprAlgE e a -> Expr -> ErrorPath e a
foldExprE alg = f where
  f (Add lhs rhs) = level (aAdd alg <$> f lhs <*> f rhs)
  f (Sub lhs rhs) = level (aSub alg <$> f lhs <*> f rhs)
  f (Mul lhs rhs) = level (aMul alg <$> f lhs <*> f rhs)
  f (Num n)       = atom  (aNum alg n)

evalExprReport :: ExprAlgE err a -> String -> Either (Maybe (err, Range)) a
evalExprReport alg = compile parseExpr (foldExprE alg)

compile :: Symbol tok => (input -> Maybe (ParseTree tok a)) ->
  (a -> ErrorPath err b) -> input -> Either (Maybe (err, Range)) b
compile parse fold input = case parse input of
  Nothing -> Left Nothing
  Just tree -> case (runErrorPath . fold . fromJust . rootUnit) tree of
    Left (err, path) ->
      let mrange = unitInnerRange_Syn_ParseTree (compute 0 tree) (0:path)
      in Left (fmap ((,) err) mrange)
    Right v -> Right v

evalAlg :: ExprAlgE String Int
evalAlg = ExprAlgE
  { aAdd = \lhs rhs -> check (lhs + rhs)
  , aSub = \lhs rhs -> check (lhs - rhs)
  , aMul = \lhs rhs -> check (lhs * rhs)
  , aNum = \n -> check n
  }

check :: Int -> Either String Int
check n
  | n `mod` 2 == 0  = Right n
  | otherwise       = Left "odd numbers are a no-no"

type ExprParser = TreeParserA E.ExprToken Expr Expr

pExpr :: ExprParser
pExpr = pSum

pSum :: ExprParser
pSum = pMul
   <|> unit ((\x _ y -> Add x y) <$> pMul <*> symbol Plus <*> pSum)

pMul :: ExprParser
pMul = pUnit
   <|> unit ((\x _ y -> Mul x y) <$> pUnit <*> symbol Star <*> pMul)

pUnit :: ExprParser
pUnit = pNum
    <|> unit ((\_ x _ -> x) <$> symbol POpen <*> pExpr <*> symbol PClose)

pNum :: ExprParser
pNum = unit $ (\(E.Num n) -> Num n) <$> satisfy isNum

testRanges :: (Show s, Show w, Symbol s) => ParseTree s w -> IO ()
testRanges tree = putStr $ unlines $ source : map visualise allRanges
  where
    syn = compute 0 tree
    source = ' ' : show (source_Syn_ParseTree syn)
    (_, len) = outerRange_Syn_ParseTree syn
    allRanges = [ (t0, t1) | t0 <- [0..len - 1], t1 <- [t0 + 1..len] ]
    visualise t@(t0, t1) = "|" ++ sp t0 ++ replicate (t1 - t0) '-' ++ sp (len - t1) ++ "|  " ++ (show . map (unUnit . fst)) (select_Syn_ParseTree syn t)
    sp n = replicate n ' '
    unUnit (Unit x _) = x
    unUnit _  = undefined

parseExpr :: String -> Maybe (ParseTree (Token E.ExprToken) Expr)
parseExpr = pTokens' >& pExpr
  where
    pTokens' :: SucParser Char [Token E.ExprToken]
    pTokens' = pTokens

demo :: String -> IO ()
demo = testRanges . fromJust . parseExpr