{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
-- {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoIncoherentInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoUndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}

module Hcompta.Repr.Text.Write where

import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Int (Int)
import Data.Monoid ((<>))
import Data.Ord (Ord(..))
import Data.Text.Buildable (Buildable(..))
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TL
import Prelude (pred, succ)
import Text.Show (Show(..))

import Hcompta.Expr

-- * Type 'Repr_Text_Write'

-- | /Tagless-final interpreter/
-- to evaluate an expression to a 'TL.Builder'.
newtype Repr_Text_Write h
 =      Repr_Text_Write
 {    unRepr_Text_Write
        :: Precedence -> Var_Depth -- inherited attributes
        -> TL.Builder              -- synthetised attributes
 }
{-
data Write_Inh
 =   Write_Inh
 {   Write_Precedence :: Precedence
 ,   Write_Var_Depth  :: Var_Depth
 }
data Write_Syn
 =   Write_Syn
 {   Write_Syn_Text :: TL.Builder
 }
-}
type Var_Depth = Int

repr_text_write :: Repr_Text_Write a -> TL.Builder
repr_text_write x = unRepr_Text_Write x precedence_Toplevel 0
instance Show (Repr_Text_Write a) where
	show = TL.unpack . TL.toLazyText . repr_text_write

instance Expr_Lit Repr_Text_Write where
	lit a = Repr_Text_Write $ \_p _v -> build a
instance Expr_Bool Repr_Text_Write where
	and (Repr_Text_Write x) (Repr_Text_Write y) =
		Repr_Text_Write $ \p v ->
			let p' = precedence_And in
			paren p p' $ x p' v <> " & " <> y p' v
	or (Repr_Text_Write x) (Repr_Text_Write y) =
		Repr_Text_Write $ \p v ->
			let p' = precedence_Or in
			paren p p'  $ x p' v <> " | " <> y p' v
	neg (Repr_Text_Write x) =
		Repr_Text_Write $ \p v ->
			let p' = precedence_Neg in
			paren p p' $ "!" <> x (precedence_succ p') v
instance Expr_Fun Repr_Text_Write where
	app (Repr_Text_Write f) (Repr_Text_Write x) = Repr_Text_Write $ \p v ->
		let p' = precedence_App in
		paren p p' $
		f p' v <> " " <> x p' v
	lazy       = repr_text_write_fun "~"
	val        = repr_text_write_fun ""
	inline     = repr_text_write_fun "!"
	let_lazy   = repr_text_write_let "~"
	let_val    = repr_text_write_let ""
	let_inline = repr_text_write_let "!"

-- ** Instance 'Fun' helpers
repr_text_write_fun :: TL.Builder -> (Repr_Text_Write a2 -> Repr_Text_Write a1) -> Repr_Text_Write a
repr_text_write_fun mode e =
	Repr_Text_Write $ \p v ->
		let p' = precedence_Fun in
		let x = "x" <> build v in
		paren p p' $
		"\\" <> mode <> x <> " -> " <>
		unRepr_Text_Write (e (Repr_Text_Write $ \_p _v -> x)) p' (succ v)
repr_text_write_let
 :: TL.Builder
 -> Repr_Text_Write a1
 -> (Repr_Text_Write a3 -> Repr_Text_Write a2)
 -> Repr_Text_Write a
repr_text_write_let mode e in_ =
	Repr_Text_Write $ \p v ->
		let p' = precedence_Let in
		let x = "x" <> build v in
		paren p p' $
		"let" <> mode <> " " <> x <> " = " <> unRepr_Text_Write e p (succ v) <> " in " <>
		unRepr_Text_Write (in_ (Repr_Text_Write $ \_p _v -> x)) p (succ v)

instance Expr_If Repr_Text_Write where
	if_
	 (Repr_Text_Write cond)
	 (Repr_Text_Write ok)
	 (Repr_Text_Write ko) =
		Repr_Text_Write $ \p v ->
			let p' = precedence_If in
			paren p p' $
			"if " <> cond p' v <>
			" then " <> ok p' v <>
			" else " <> ko p' v
	when_ (Repr_Text_Write cond) (Repr_Text_Write ok) =
		Repr_Text_Write $ \p v ->
			let p' = precedence_If in
			paren p p' $
			"when " <> cond p' v <>
			" " <> ok p' v

-- ** Type 'Precedence'

-- TODO: use an Enum?
newtype Precedence = Precedence Int
 deriving (Eq, Ord, Show)
precedence_pred :: Precedence -> Precedence
precedence_pred (Precedence p) = Precedence (pred p)
precedence_succ :: Precedence -> Precedence
precedence_succ (Precedence p) = Precedence (succ p)
paren :: Precedence -> Precedence -> TL.Builder -> TL.Builder
paren prec prec' x =
	if prec >= prec'
	 then "(" <> x <> ")"
	 else x

precedence_Toplevel :: Precedence
precedence_Toplevel  = Precedence 0
precedence_Fun      :: Precedence
precedence_Fun       = Precedence 1
precedence_Let      :: Precedence
precedence_Let       = Precedence 2
precedence_If       :: Precedence
precedence_If        = Precedence 3
precedence_Or       :: Precedence
precedence_Or        = Precedence 4
precedence_And      :: Precedence
precedence_And       = Precedence 5
precedence_App      :: Precedence
precedence_App       = Precedence 6
precedence_Neg      :: Precedence
precedence_Neg       = Precedence 7
precedence_Atomic   :: Precedence
precedence_Atomic    = Precedence 8