Language/Symantic/Typing/Syntax.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE NoMonomorphismRestriction #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# LANGUAGE UndecidableInstances #-}
   7 module Language.Symantic.Typing.Syntax where
   8
   9 import Data.Text (Text)
  10 import qualified Data.Text as Text
  11 import qualified Data.List as List
  12
  13 -- * Class 'AST'
  14 class AST node where
  15         type Lexem node
  16         ast_lexem :: node -> Lexem node
  17         ast_nodes :: node -> [node]
  18
  19 -- ** Type 'At'
  20 -- | Attach a location.
  21 data At ast a
  22  =   At (Maybe ast) a
  23  deriving (Eq, Show)
  24 instance Functor (At ast) where
  25         fmap f (At ast a) = At ast (f a)
  26
  27 data Error_Syntax ast
  28  = Error_Syntax_more_arguments_needed (At ast Int)
  29  -- ^ Minimal number of arguments.
  30  | Error_Syntax_too_many_arguments (At ast Int)
  31  -- ^ Maximal number of arguments.
  32  | Error_Syntax_read (At ast Text)
  33  deriving (Eq, Show)
  34
  35 class Lift_Error_Syntax err where
  36         lift_error_syntax :: Error_Syntax ast -> err ast
  37
  38 from_lex
  39  :: ( AST ast, Lexem ast ~ Text
  40     , Read ty, Lift_Error_Syntax err )
  41  => Text -> ast
  42  -> (ty -> Either (err ast) ret)
  43  -> Either (err ast) ret
  44 from_lex msg ast_x k =
  45         from_ast0 ast_x $ \lex_x ->
  46         case reads $ Text.unpack lex_x of
  47          [(x, "")] -> k x
  48          _ -> Left $ lift_error_syntax $
  49                 Error_Syntax_read $
  50                 At (Just ast_x) msg
  51 from_ast0
  52  :: (AST ast, Lift_Error_Syntax err) => ast
  53  -> (Lexem ast -> Either (err ast) ret)
  54  -> Either (err ast) ret
  55 from_ast0 ast k =
  56         case ast_nodes ast of
  57          [] -> k (ast_lexem ast)
  58          _ -> Left $ lift_error_syntax $
  59                 Error_Syntax_too_many_arguments $
  60                 At (Just ast) 0
  61 from_ast1
  62  :: (AST ast, Lift_Error_Syntax err) => ast
  63  -> (ast -> Either (err ast) ret)
  64  -> Either (err ast) ret
  65 from_ast1 ast k =
  66         case ast_nodes ast of
  67          [a1] -> k a1
  68          args | length args < 1 ->
  69                 Left $ lift_error_syntax $
  70                 Error_Syntax_more_arguments_needed $
  71                 At (Just ast) 1
  72          _ -> Left $ lift_error_syntax $
  73                 Error_Syntax_too_many_arguments $
  74                 At (Just ast) 1
  75 from_ast2
  76  :: (AST ast, Lift_Error_Syntax err) => ast
  77  -> (ast -> ast -> Either (err ast) ret)
  78  -> Either (err ast) ret
  79 from_ast2 ast k =
  80         case ast_nodes ast of
  81          [a1, a2] -> k a1 a2
  82          args | length args < 2 ->
  83                 Left $ lift_error_syntax $
  84                 Error_Syntax_more_arguments_needed $
  85                 At (Just ast) 2
  86          _ -> Left $ lift_error_syntax $
  87                 Error_Syntax_too_many_arguments $
  88                 At (Just ast) 2
  89 from_ast3
  90  :: (AST ast, Lift_Error_Syntax err) => ast
  91  -> (ast -> ast -> ast -> Either (err ast) ret)
  92  -> Either (err ast) ret
  93 from_ast3 ast k =
  94         case ast_nodes ast of
  95          [a1, a2, a3] -> k a1 a2 a3
  96          args | length args < 3 ->
  97                 Left $ lift_error_syntax $
  98                 Error_Syntax_more_arguments_needed $
  99                 At (Just ast) 3
 100          _ -> Left $ lift_error_syntax $
 101                 Error_Syntax_too_many_arguments $
 102                 At (Just ast) 3
 103
 104 -- * Type 'Syntax'
 105 data Syntax a
 106  =   Syntax a [Syntax a]
 107  deriving (Eq)
 108 instance AST (Syntax a) where
 109         type Lexem (Syntax a) = a
 110         ast_lexem (Syntax x _)  = x
 111         ast_nodes (Syntax _ ns) = ns
 112
 113 -- | Custom 'Show' instance a little bit more readable
 114 -- than the automatically derived one.
 115 instance Show (Syntax Text) where
 116         showsPrec p ast@(Syntax name args) =
 117                 let n = Text.unpack name in
 118                 case ast of
 119                  Syntax _ [] -> showString n
 120                  Syntax "(->)" [a] ->
 121                         showParen (p <= prec_arrow) $
 122                         showString (""++n++" ") .
 123                         showsPrec prec_arrow a
 124                  Syntax "(->)" [a, b] ->
 125                         showParen (p <= prec_arrow) $
 126                         showsPrec prec_arrow a .
 127                         showString (" -> ") .
 128                         showsPrec (prec_arrow + 1) b
 129                  Syntax "\\" [var, ty, body] ->
 130                         showParen (p <= prec_lambda) $
 131                         showString ("\\(") .
 132                         showsPrec prec_lambda var .
 133                         showString (":") .
 134                         showsPrec prec_lambda ty .
 135                         showString (") -> ") .
 136                         showsPrec prec_lambda body
 137                  Syntax " " [fun, arg] ->
 138                         showParen (p <= prec_app) $
 139                         showsPrec prec_dollar fun .
 140                         showString (" ") .
 141                         showsPrec prec_dollar arg
 142                  Syntax "$" [fun, arg] ->
 143                         showParen (p <= prec_dollar) $
 144                         showsPrec prec_dollar fun .
 145                         showString (" $ ") .
 146                         showsPrec prec_dollar arg
 147                  _ ->
 148                         showParen (p <= prec_app) $
 149                         showString n .
 150                         showString " " .
 151                         showString (List.unwords $ show <$> args)
 152                 where
 153                 prec_arrow  = 1
 154                 prec_lambda = 1
 155                 prec_dollar = 1
 156                 prec_app    = 10