{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Language.Symantic.Typing.Syntax where

import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.List as List

-- * Class 'AST'
class AST node where
	type Lexem node
	ast_lexem :: node -> Lexem node
	ast_nodes :: node -> [node]

-- ** Type 'At'
-- | Attach a location.
data At ast a
 =   At (Maybe ast) a
 deriving (Eq, Show)
instance Functor (At ast) where
	fmap f (At ast a) = At ast (f a)

data Error_Syntax ast
 = Error_Syntax_more_arguments_needed (At ast Int)
 -- ^ Total minimal number of arguments.
 | Error_Syntax_read (At ast Text)
 deriving (Eq, Show)

class Lift_Error_Syntax err where
	lift_error_syntax :: Error_Syntax ast -> err ast

from_lex
 :: ( AST ast, Lexem ast ~ Text
    , Read ty, Lift_Error_Syntax err )
 => Text -> ast
 -> (ty -> [ast] -> Either (err ast) ret)
 -> Either (err ast) ret
from_lex msg ast_x k =
	from_ast0 ast_x $ \lex_x as ->
	case reads $ Text.unpack lex_x of
	 [(x, "")] -> k x as
	 _ -> Left $ lift_error_syntax $
		Error_Syntax_read $
		At (Just ast_x) msg
from_ast0
 :: AST ast => ast
 -> (Lexem ast -> [ast] -> Either (err ast) ret)
 -> Either (err ast) ret
from_ast0 ast k =
	case ast_nodes ast of
	 as -> k (ast_lexem ast) as
from_ast1
 :: (AST ast, Lift_Error_Syntax err) => ast
 -> (ast -> [ast] -> Either (err ast) ret)
 -> Either (err ast) ret
from_ast1 ast k =
	case ast_nodes ast of
	 [] ->
		Left $ lift_error_syntax $
		Error_Syntax_more_arguments_needed $
		At (Just ast) 1
	 a1:as -> k a1 as
from_ast2
 :: (AST ast, Lift_Error_Syntax err) => ast
 -> (ast -> ast -> [ast] -> Either (err ast) ret)
 -> Either (err ast) ret
from_ast2 ast k =
	case ast_nodes ast of
	 a1:a2:as -> k a1 a2 as
	 _as ->
		Left $ lift_error_syntax $
		Error_Syntax_more_arguments_needed $
		At (Just ast) 2
from_ast3
 :: (AST ast, Lift_Error_Syntax err) => ast
 -> (ast -> ast -> ast -> [ast] -> Either (err ast) ret)
 -> Either (err ast) ret
from_ast3 ast k =
	case ast_nodes ast of
	 a1:a2:a3:as -> k a1 a2 a3 as
	 _as ->
		Left $ lift_error_syntax $
		Error_Syntax_more_arguments_needed $
		At (Just ast) 3

-- * Type 'Syntax'
data Syntax a
 =   Syntax a [Syntax a]
 deriving (Eq)
instance AST (Syntax a) where
	type Lexem (Syntax a) = a
	ast_lexem (Syntax x _)  = x
	ast_nodes (Syntax _ ns) = ns

-- | Custom 'Show' instance a little bit more readable
-- than the automatically derived one.
instance Show (Syntax Text) where
	showsPrec p ast@(Syntax name args) =
		let n = Text.unpack name in
		case ast of
		 Syntax _ [] -> showString n
		 Syntax "(->)" [a] ->
			showParen (p <= prec_arrow) $
			showString (""++n++" ") .
			showsPrec prec_arrow a
		 Syntax "(->)" [a, b] ->
			showParen (p <= prec_arrow) $
			showsPrec prec_arrow a .
			showString (" -> ") .
			showsPrec (prec_arrow + 1) b
		 Syntax "\\" [var, ty, body] ->
			showParen (p <= prec_lambda) $
			showString ("\\(") .
			showsPrec prec_lambda var .
			showString (":") .
			showsPrec prec_lambda ty .
			showString (") -> ") .
			showsPrec prec_lambda body
		 Syntax " " [fun, arg] ->
			showParen (p <= prec_app) $
			showsPrec prec_dollar fun .
			showString (" ") .
			showsPrec prec_dollar arg
		 Syntax "$" [fun, arg] ->
			showParen (p <= prec_dollar) $
			showsPrec prec_dollar fun .
			showString (" $ ") .
			showsPrec prec_dollar arg
		 _ ->
			showParen (p <= prec_app) $
			showString n .
			showString " " .
			showString (List.unwords $ show <$> args)
		where
		prec_arrow  = 1
		prec_lambda = 1
		prec_dollar = 1
		prec_app    = 10