{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module TFHOE.Repr.String where

-- import Data.Functor.Identity (Identity)
import Data.Monoid ((<>))
import Data.String (IsString(..))

import TFHOE.Expr

-- * Type 'Repr_String'

-- | 'String' interpreter.
newtype Repr_String (fun:: * -> *) h
 =      Repr_String
 {    unRepr_String
        -- Inherited attributes:
        :: Precedence
        -> Repr_String_Lambda_Depth
        -- Synthetised attributes:
        -> String
 }
type Repr_String_Lambda_Depth = Int

string_repr :: Repr_String fun h -> String
string_repr r = unRepr_String r precedence_Toplevel 0

string_repr_any :: ty h -> Repr_String fun h -> Either err String
string_repr_any _ty = return . string_repr

instance Show (Repr_String fun a) where
	show = string_repr

instance Expr_Fun fun (Repr_String fun) where
	type Fun_from_Repr (Repr_String fun) = fun
	app (Repr_String f) (Repr_String x) = Repr_String $ \p v ->
		let p' = precedence_App in
		paren p p' $
		f p' v <> " " <> x p' v
	inline     = repr_string_fun "!"
	val        = repr_string_fun ""
	lazy       = repr_string_fun "~"
	
	let_inline = repr_string_let "!"
	let_val    = repr_string_let ""
	let_lazy   = repr_string_let "~"

-- ** Instance 'Fun' helpers
repr_string_fun :: String -> (Repr_String fun a2 -> Repr_String fun a1) -> Repr_String fun a
repr_string_fun mode e =
	Repr_String $ \p v ->
		let p' = precedence_Fun in
		let x = "x" <> show v in
		paren p p' $
		"\\" <> mode <> x <> " -> " <>
		unRepr_String (e (Repr_String $ \_p _v -> x)) p' (succ v)
repr_string_let
 :: String
 -> Repr_String fun a1
 -> (Repr_String fun a3 -> Repr_String fun a2)
 -> Repr_String fun a
repr_string_let mode e in_ =
	Repr_String $ \p v ->
		let p' = precedence_Let in
		let x = "x" <> show v in
		paren p p' $
		"let" <> mode <> " " <> x <> " = " <> unRepr_String e p (succ v) <> " in " <>
		unRepr_String (in_ (Repr_String $ \_p _v -> x)) p (succ v)

instance Expr_Bool (Repr_String fun) where
	bool a = Repr_String $ \_p _v -> show a
	neg (Repr_String x) =
		Repr_String $ \p v ->
			let p' = precedence_Neg in
			paren p p' $ "!" <> x (precedence_succ p') v
	and (Repr_String x) (Repr_String y) =
		Repr_String $ \p v ->
			let p' = precedence_And in
			paren p p' $ x p' v <> " & " <> y p' v
	or (Repr_String x) (Repr_String y) =
		Repr_String $ \p v ->
			let p' = precedence_Or in
			paren p p'  $ x p' v <> " | " <> y p' v
	{-xor (Repr_String x) (Repr_String y) =
		Repr_String $ \p v ->
			let p' = precedence_Xor in
			paren p p'  $ x p' v <> " * " <> y p' v
	-}
instance Expr_Int (Repr_String fun) where
	int a = Repr_String $ \_p _v -> show a
	add (Repr_String x) (Repr_String y) =
		Repr_String $ \p v ->
			let p' = precedence_Add in
			paren p p' $ x p' v <> " + " <> y p' v
{-
instance Expr_If Repr_String where
	if_
	 (Repr_String cond)
	 (Repr_String ok)
	 (Repr_String ko) =
		Repr_String $ \p v ->
			let p' = precedence_If in
			paren p p' $
			"if " <> cond p' v <>
			" then " <> ok p' v <>
			" else " <> ko p' v
	when_ (Repr_String cond) (Repr_String ok) =
		Repr_String $ \p v ->
			let p' = precedence_If in
			paren p p' $
			"when " <> cond p' v <>
			" " <> ok 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_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_Add      :: Precedence
precedence_Add       = precedence_Or
precedence_Xor      :: Precedence
precedence_Xor       = Precedence 5
precedence_And      :: Precedence
precedence_And       = Precedence 6
precedence_App      :: Precedence
precedence_App       = Precedence 7
precedence_Neg      :: Precedence
precedence_Neg       = Precedence 8
precedence_Atomic   :: Precedence
precedence_Atomic    = Precedence 9