{-# 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
import Data.String (IsString(..))

-- * 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)
 | Error_Syntax_too_many_arguments    (At ast Int)
 deriving (Eq, Show)

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

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 - length args
	 args -> Left $ lift_error_syntax $
		Error_Syntax_too_many_arguments $
		At (Just ast) $ length args - 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 - length args
	 args -> Left $ lift_error_syntax $
		Error_Syntax_too_many_arguments $
		At (Just ast) $ length args - 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


syBool :: IsString a => Syntax a
syBool = Syntax "Bool" []
syEq :: IsString a => [Syntax a] -> Syntax a
syEq = Syntax "Eq"
syFun :: IsString a => [Syntax a] -> Syntax a
syFun = Syntax "(->)"
syInt :: IsString a => Syntax a
syInt = Syntax "Int" []
syIO :: IsString a => [Syntax a] -> Syntax a
syIO = Syntax "IO"
syTraversable :: IsString a => [Syntax a] -> Syntax a
syTraversable = Syntax "Traversable"
syMonad :: IsString a => [Syntax a] -> Syntax a
syMonad = Syntax "Monad"
(.>) :: IsString a => Syntax a -> Syntax a -> Syntax a
a .> b = syFun [a, b]
infixr 3 .>