{-# 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