{-# 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)
 -- ^ Minimal number of arguments.
 | Error_Syntax_too_many_arguments (At ast Int)
 -- ^ Maximal 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 -> Either (err ast) ret)
 -> Either (err ast) ret
from_lex msg ast_x k =
	from_ast0 ast_x $ \lex_x ->
	case reads $ Text.unpack lex_x of
	 [(x, "")] -> k x
	 _ -> Left $ lift_error_syntax $
		Error_Syntax_read $
		At (Just ast_x) msg
from_ast0
 :: (AST ast, Lift_Error_Syntax err) => ast
 -> (Lexem ast -> Either (err ast) ret)
 -> Either (err ast) ret
from_ast0 ast k =
	case ast_nodes ast of
	 [] -> k (ast_lexem ast)
	 _ -> Left $ lift_error_syntax $
		Error_Syntax_too_many_arguments $
		At (Just ast) 0
from_ast1
 :: (AST ast, Lift_Error_Syntax err) => ast
 -> (ast -> Either (err ast) ret)
 -> Either (err ast) ret
from_ast1 ast k =
	case ast_nodes ast of
	 [a1] -> k a1
	 args | length args < 1 ->
		Left $ lift_error_syntax $
		Error_Syntax_more_arguments_needed $
		At (Just ast) 1
	 _ -> Left $ lift_error_syntax $
		Error_Syntax_too_many_arguments $
		At (Just ast) 1
from_ast2
 :: (AST ast, Lift_Error_Syntax err) => ast
 -> (ast -> ast -> Either (err ast) ret)
 -> Either (err ast) ret
from_ast2 ast k =
	case ast_nodes ast of
	 [a1, a2] -> k a1 a2
	 args | length args < 2 ->
		Left $ lift_error_syntax $
		Error_Syntax_more_arguments_needed $
		At (Just ast) 2
	 _ -> Left $ lift_error_syntax $
		Error_Syntax_too_many_arguments $
		At (Just ast) 2
from_ast3
 :: (AST ast, Lift_Error_Syntax err) => ast
 -> (ast -> ast -> ast -> Either (err ast) ret)
 -> Either (err ast) ret
from_ast3 ast k =
	case ast_nodes ast of
	 [a1, a2, a3] -> k a1 a2 a3
	 args | length args < 3 ->
		Left $ lift_error_syntax $
		Error_Syntax_more_arguments_needed $
		At (Just ast) 3
	 _ -> Left $ lift_error_syntax $
		Error_Syntax_too_many_arguments $
		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