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

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

import Language.Symantic.Expr hiding ((<>))

-- * Type 'Repr_Text'

-- | Interpreter's data.
newtype Repr_Text 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 h -> Text
text_from_expr r = unRepr_Text r precedence_Toplevel 0

{-
instance Show (Repr_Text h) where
	show = text_from_expr
-}
instance Sym_Lambda Repr_Text where
	($$) (Repr_Text a1) (Repr_Text a2) =
		Repr_Text $ \p v ->
			let p' = precedence_App in
			paren p p' $ a1 p' v <> " " <> a2 p' v
	lam f =
		Repr_Text $ \p v ->
			let p' = precedence_Lambda in
			let x = "x" <> Text.pack (show v) in
			paren p p' $
			"\\" <> x <> " -> " <>
			unRepr_Text (f (Repr_Text $ \_p _v -> x)) p' (succ v)
	let_ e in_ =
		Repr_Text $ \p v ->
			let p' = precedence_Let in
			let x = "x" <> Text.pack (show v) in
			paren p p' $
			"let" <> " " <> x <> " = " <> unRepr_Text e p (succ v) <> " in " <>
			unRepr_Text (in_ (Repr_Text $ \_p _v -> x)) p (succ v)
instance Sym_Bool Repr_Text 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
	(&&) (Repr_Text x) (Repr_Text y) =
		Repr_Text $ \p v ->
			let p' = precedence_And in
			paren p p' $ x p' v <> " && " <> y p' v
	(||) (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'  $ "xor " <> x p' v <> " " <> y p' v
instance Sym_Int Repr_Text where
	int a = Repr_Text $ \_p _v ->
		Text.pack (show a)
	abs = repr_text_app1 "abs"
	negate (Repr_Text x) =
		Repr_Text $ \p v ->
			let p' = precedence_Neg in
			paren p p' $ "-" <> x p' v
	(+) (Repr_Text x) (Repr_Text y) =
		Repr_Text $ \p v ->
			let p' = precedence_Add in
			paren p p' $ x p' v <> " + " <> y p' v
	(-) (Repr_Text x) (Repr_Text y) =
		Repr_Text $ \p v ->
			let p' = precedence_Sub in
			paren p p' $ x p' v <> " - " <> y p' v
	(*) (Repr_Text x) (Repr_Text y) =
		Repr_Text $ \p v ->
			let p' = precedence_Mul in
			paren p p' $ x p' v <> " * " <> y p' v
	mod (Repr_Text x) (Repr_Text y) =
		Repr_Text $ \p v ->
			let p' = precedence_Mod in
			paren p p' $ x p' v <> " % " <> y p' v
instance Sym_Text Repr_Text where
	text a = Repr_Text $ \_p _v -> Text.pack (show a)
instance Sym_Maybe Repr_Text where
	nothing =
		Repr_Text $ \_p _v ->
			"nothing"
	just  = repr_text_app1 "just"
	maybe = repr_text_app3 "maybe"
instance Sym_If Repr_Text 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 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 where
	(==) (Repr_Text x) (Repr_Text y) =
		Repr_Text $ \p v ->
			let p' = precedence_Eq in
			paren p p' $
			x p' v <> " == " <> y p' v
instance Sym_Ord Repr_Text where
	compare (Repr_Text x) (Repr_Text y) =
		Repr_Text $ \p v ->
			let p' = precedence_Eq in
			paren p p' $
			"compare " <> x p' v <> " " <> y p' v
instance Sym_List Repr_Text where
	list_empty = Repr_Text $ \_p _v ->
		"[]"
	list_cons (Repr_Text x) (Repr_Text xs) =
		Repr_Text $ \p v ->
			let p' = precedence_List_Cons in
			paren p p' $ x p' v <> ":" <> xs p' v
	list l = Repr_Text $ \_p v ->
		let p' = precedence_Toplevel in
		"[" <> Text.intercalate ", " ((\(Repr_Text a) -> a p' v) Prelude.<$> l) <> "]"
	list_filter  = repr_text_app2 "list_filter"
	list_zipWith = repr_text_app3 "list_zipWith"
	list_reverse = repr_text_app1 "list_reverse"
instance Sym_Tuple2 Repr_Text where
	tuple2 (Repr_Text a) (Repr_Text b) =
		Repr_Text $ \_p v ->
			let p' = precedence_Toplevel in
			"(" <> a p' v <> ", " <> b p' v <> ")"
	fst = repr_text_app1 "fst"
	snd = repr_text_app1 "snd"
instance Sym_Map Repr_Text where
	map_from_list    = repr_text_app1 "map_from_list"
	mapWithKey       = repr_text_app2 "mapWithKey"
	map_lookup       = repr_text_app2 "map_lookup"
	map_keys         = repr_text_app1 "map_keys"
	map_member       = repr_text_app2 "map_member"
	map_insert       = repr_text_app3 "map_insert"
	map_delete       = repr_text_app2 "map_delete"
	map_difference   = repr_text_app2 "map_difference"
	map_foldrWithKey = repr_text_app3 "map_foldrWithKey"
instance Sym_Functor Repr_Text where
	fmap = repr_text_app2 "fmap"
instance Sym_Applicative Repr_Text where
	pure = repr_text_app1 "pure"
	(<*>) (Repr_Text fg) (Repr_Text fa) =
		Repr_Text $ \p v ->
			let p' = precedence_LtStarGt in
			paren p p' $ fg p' v <> " <*> " <> fa p' v
instance Sym_Traversable Repr_Text where
	traverse = repr_text_app2 "traverse"
instance Sym_Monad Repr_Text where
	return = repr_text_app1 "return"
	(>>=) (Repr_Text g) (Repr_Text ma) =
		Repr_Text $ \p v ->
			let p' = precedence_Bind in
			paren p p' $ g p' v <> " >>= " <> ma p' v
instance Sym_Either Repr_Text where
	right = repr_text_app1 "right"
	left  = repr_text_app1 "left"
instance Sym_IO Repr_Text where
	io_hClose   = repr_text_app1 "io_hClose"
	io_openFile = repr_text_app2 "io_openFile"
instance Sym_Foldable Repr_Text where
	foldMap = repr_text_app2 "foldMap"
	null    = repr_text_app1 "null"
	length  = repr_text_app1 "length"
	minimum = repr_text_app1 "minimum"
	maximum = repr_text_app1 "maximum"
	elem    = repr_text_app2 "elem"
instance Sym_Monoid Repr_Text where
	mempty = Repr_Text $ \_p _v -> "mempty"
	mappend = repr_text_app2 "mappend"

-- * Helpers

-- ** Helpers for lambda applications
repr_text_app1
 :: Text
 -> Repr_Text a1
 -> Repr_Text h
repr_text_app1 name (Repr_Text a1) =
	Repr_Text $ \p v ->
		let p' = precedence_App in
		paren p p' $ name
		 <> " " <> a1 p' v
repr_text_app2
 :: Text
 -> Repr_Text a1
 -> Repr_Text a2
 -> Repr_Text h
repr_text_app2 name (Repr_Text a1) (Repr_Text a2) =
	Repr_Text $ \p v ->
		let p' = precedence_App in
		paren p p' $ name
		 <> " " <> a1 p' v
		 <> " " <> a2 p' v
repr_text_app3
 :: Text
 -> Repr_Text a1
 -> Repr_Text a2
 -> Repr_Text a3
 -> Repr_Text h
repr_text_app3 name (Repr_Text a1) (Repr_Text a2) (Repr_Text a3) =
	Repr_Text $ \p v ->
		let p' = precedence_App in
		paren p p' $ name
		 <> " " <> a1 p' v
		 <> " " <> a2 p' v
		 <> " " <> a3 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_Bind      :: Precedence
precedence_Bind       = precedence_Lambda
precedence_If        :: Precedence
precedence_If         = Precedence 2
precedence_Let       :: Precedence
precedence_Let        = Precedence 3
precedence_Eq        :: Precedence
precedence_Eq         = Precedence 4
precedence_LtStarGt  :: Precedence
precedence_LtStarGt   = precedence_Eq
precedence_Or        :: Precedence
precedence_Or         = Precedence 5
precedence_List_Cons :: Precedence
precedence_List_Cons  = Precedence 5
precedence_Xor       :: Precedence
precedence_Xor        = precedence_Or
precedence_And       :: Precedence
precedence_And        = Precedence 6
precedence_Add       :: Precedence
precedence_Add        = precedence_And
precedence_Sub       :: Precedence
precedence_Sub        = precedence_Add
precedence_Mul       :: Precedence
precedence_Mul        = Precedence 7
precedence_Mod       :: Precedence
precedence_Mod        = precedence_Mul
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