{-# 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 Prelude hiding (Integral(..))

-- * 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
instance Show (Repr_Text h) where
	show = Text.unpack . text_from_expr

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

-- * 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_Integral  :: Precedence
precedence_Integral   = 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