{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
-- | Interpreter to serialize an expression into a 'Text'.
module Language.LOL.Symantic.Repr.Text where

import Data.Monoid ((<>))
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as Text

import Language.LOL.Symantic.Expr

-- * Type 'Repr_Text'

-- | Interpreter's data.
newtype Repr_Text (lam:: * -> *) h
 =      Repr_Text
 {    unRepr_Text
        -- Inherited attributes:
        :: Precedence
        -> Repr_Text_Lambda_Depth
        -- Synthetised attributes:
        -> Text
 }
type Repr_Text_Lambda_Depth = Int

-- | Interpreter.
text_from_expr :: Repr_Text lam h -> Text
text_from_expr r = unRepr_Text r precedence_Toplevel 0

{-
instance Show (Repr_Text lam a) where
	show = text_from_expr
-}
instance Sym_Lambda lam (Repr_Text lam) where
	type Lambda_from_Repr (Repr_Text lam) = lam
	app (Repr_Text f) (Repr_Text x) = Repr_Text $ \p v ->
		let p' = precedence_App in
		paren p p' $
		f p' v <> " " <> x p' v
	inline     = repr_text_fun "!"
	val        = repr_text_fun ""
	lazy       = repr_text_fun "~"
	
	let_inline = repr_text_let "!"
	let_val    = repr_text_let ""
	let_lazy   = repr_text_let "~"

-- ** Helpers for 'Sym_Lambda' instances
repr_text_fun :: Text -> (Repr_Text lam a2 -> Repr_Text lam a1) -> Repr_Text lam a
repr_text_fun mode e =
	Repr_Text $ \p v ->
		let p' = precedence_Lambda in
		let x = "x" <> Text.pack (show v) in
		paren p p' $
		"\\" <> mode <> x <> " -> " <>
		unRepr_Text (e (Repr_Text $ \_p _v -> x)) p' (succ v)
repr_text_let
 :: Text
 -> Repr_Text lam a1
 -> (Repr_Text lam a3 -> Repr_Text lam a2)
 -> Repr_Text lam a
repr_text_let mode e in_ =
	Repr_Text $ \p v ->
		let p' = precedence_Let in
		let x = "x" <> Text.pack (show v) in
		paren p p' $
		"let" <> mode <> " " <> x <> " = " <> unRepr_Text e p (succ v) <> " in " <>
		unRepr_Text (in_ (Repr_Text $ \_p _v -> x)) p (succ v)

instance Sym_Bool (Repr_Text lam) where
	bool a = Repr_Text $ \_p _v ->
		Text.pack (show a)
	not (Repr_Text x) =
		Repr_Text $ \p v ->
			let p' = precedence_Not in
			paren p p' $ "!" <> x p' v
	and (Repr_Text x) (Repr_Text y) =
		Repr_Text $ \p v ->
			let p' = precedence_And in
			paren p p' $ x p' v <> " & " <> y p' v
	or (Repr_Text x) (Repr_Text y) =
		Repr_Text $ \p v ->
			let p' = precedence_Or in
			paren p p'  $ x p' v <> " | " <> y p' v
	{-xor (Repr_Text x) (Repr_Text y) =
		Repr_Text $ \p v ->
			let p' = precedence_Xor in
			paren p p'  $ x p' v <> " * " <> y p' v
	-}
instance Sym_Int (Repr_Text lam) where
	int a = Repr_Text $ \_p _v ->
		Text.pack (show a)
	neg (Repr_Text x) =
		Repr_Text $ \p v ->
			let p' = precedence_Neg in
			paren p p' $ "-" <> x p' v
	add (Repr_Text x) (Repr_Text y) =
		Repr_Text $ \p v ->
			let p' = precedence_Add in
			paren p p' $ x p' v <> " + " <> y p' v
instance Sym_Maybe lam (Repr_Text lam) where
	maybe (Repr_Text n) (Repr_Text j) (Repr_Text m) =
		Repr_Text $ \p v ->
			let p' = precedence_App in
			paren p p' $ "maybe"
				 <> " " <> n p' v
				 <> " " <> j p' v
				 <> " " <> m p' v
instance Sym_Maybe_Cons (Repr_Text lam) where
	nothing =
		Repr_Text $ \_p _v ->
			"nothing"
	just (Repr_Text a) =
		Repr_Text $ \p v ->
			let p' = precedence_App in
			paren p p' $ "just "
				 <> a (p') v
instance Sym_If (Repr_Text lam) where
	if_ (Repr_Text cond) (Repr_Text ok) (Repr_Text ko) =
		Repr_Text $ \p v ->
			let p' = precedence_If in
			paren p p' $
			"if " <> cond p' v <>
			" then " <> ok p' v <>
			" else " <> ko p' v
instance Sym_When (Repr_Text lam) where
	when (Repr_Text cond) (Repr_Text ok) =
		Repr_Text $ \p v ->
			let p' = precedence_If in
			paren p p' $
			"when " <> cond p' v <>
			" " <> ok p' v
instance Sym_Eq (Repr_Text lam) where
	eq (Repr_Text x) (Repr_Text y) =
		Repr_Text $ \p v ->
			let p' = precedence_Eq in
			paren p p' $
			x p' v <> " == " <> y p' v

-- ** Type 'Precedence'

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 :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
paren prec prec' x =
	if prec >= prec'
	 then fromString "(" <> x <> fromString ")"
	 else x

precedence_Toplevel :: Precedence
precedence_Toplevel  = Precedence 0
precedence_Lambda   :: Precedence
precedence_Lambda    = Precedence 1
precedence_If       :: Precedence
precedence_If        = Precedence 2
precedence_Let      :: Precedence
precedence_Let       = Precedence 3
precedence_Eq       :: Precedence
precedence_Eq        = Precedence 4
precedence_Or       :: Precedence
precedence_Or        = Precedence 5
precedence_Xor      :: Precedence
precedence_Xor       = Precedence 6
precedence_And      :: Precedence
precedence_And       = Precedence 7
precedence_Add      :: Precedence
precedence_Add       = precedence_And
precedence_App      :: Precedence
precedence_App       = Precedence 8
precedence_Not      :: Precedence
precedence_Not       = Precedence 9
precedence_Neg      :: Precedence
precedence_Neg       = precedence_Not
precedence_Atomic   :: Precedence
precedence_Atomic    = Precedence maxBound