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  -- ^ Total minimal number of arguments.
  30  | Error_Syntax_read (At ast Text)
  31  deriving (Eq, Show)
  32
  33 class Lift_Error_Syntax err where
  34         lift_error_syntax :: Error_Syntax ast -> err ast
  35
  36 from_lex
  37  :: ( AST ast, Lexem ast ~ Text
  38     , Read ty, Lift_Error_Syntax err )
  39  => Text -> ast
  40  -> (ty -> [ast] -> Either (err ast) ret)
  41  -> Either (err ast) ret
  42 from_lex msg ast_x k =
  43         from_ast0 ast_x $ \lex_x as ->
  44         case reads $ Text.unpack lex_x of
  45          [(x, "")] -> k x as
  46          _ -> Left $ lift_error_syntax $
  47                 Error_Syntax_read $
  48                 At (Just ast_x) msg
  49 from_ast0
  50  :: AST ast => ast
  51  -> (Lexem ast -> [ast] -> Either (err ast) ret)
  52  -> Either (err ast) ret
  53 from_ast0 ast k =
  54         case ast_nodes ast of
  55          as -> k (ast_lexem ast) as
  56 from_ast1
  57  :: (AST ast, Lift_Error_Syntax err) => ast
  58  -> (ast -> [ast] -> Either (err ast) ret)
  59  -> Either (err ast) ret
  60 from_ast1 ast k =
  61         case ast_nodes ast of
  62          [] ->
  63                 Left $ lift_error_syntax $
  64                 Error_Syntax_more_arguments_needed $
  65                 At (Just ast) 1
  66          a1:as -> k a1 as
  67 from_ast2
  68  :: (AST ast, Lift_Error_Syntax err) => ast
  69  -> (ast -> ast -> [ast] -> Either (err ast) ret)
  70  -> Either (err ast) ret
  71 from_ast2 ast k =
  72         case ast_nodes ast of
  73          a1:a2:as -> k a1 a2 as
  74          _as ->
  75                 Left $ lift_error_syntax $
  76                 Error_Syntax_more_arguments_needed $
  77                 At (Just ast) 2
  78 from_ast3
  79  :: (AST ast, Lift_Error_Syntax err) => ast
  80  -> (ast -> ast -> ast -> [ast] -> Either (err ast) ret)
  81  -> Either (err ast) ret
  82 from_ast3 ast k =
  83         case ast_nodes ast of
  84          a1:a2:a3:as -> k a1 a2 a3 as
  85          _as ->
  86                 Left $ lift_error_syntax $
  87                 Error_Syntax_more_arguments_needed $
  88                 At (Just ast) 3
  89
  90 -- * Type 'Syntax'
  91 data Syntax a
  92  =   Syntax a [Syntax a]
  93  deriving (Eq)
  94 instance AST (Syntax a) where
  95         type Lexem (Syntax a) = a
  96         ast_lexem (Syntax x _)  = x
  97         ast_nodes (Syntax _ ns) = ns
  98
  99 -- | Custom 'Show' instance a little bit more readable
 100 -- than the automatically derived one.
 101 instance Show (Syntax Text) where
 102         showsPrec p ast@(Syntax name args) =
 103                 let n = Text.unpack name in
 104                 case ast of
 105                  Syntax _ [] -> showString n
 106                  Syntax "(->)" [a] ->
 107                         showParen (p <= prec_arrow) $
 108                         showString (""++n++" ") .
 109                         showsPrec prec_arrow a
 110                  Syntax "(->)" [a, b] ->
 111                         showParen (p <= prec_arrow) $
 112                         showsPrec prec_arrow a .
 113                         showString (" -> ") .
 114                         showsPrec (prec_arrow + 1) b
 115                  Syntax "\\" [var, ty, body] ->
 116                         showParen (p <= prec_lambda) $
 117                         showString ("\\(") .
 118                         showsPrec prec_lambda var .
 119                         showString (":") .
 120                         showsPrec prec_lambda ty .
 121                         showString (") -> ") .
 122                         showsPrec prec_lambda body
 123                  Syntax " " [fun, arg] ->
 124                         showParen (p <= prec_app) $
 125                         showsPrec prec_dollar fun .
 126                         showString (" ") .
 127                         showsPrec prec_dollar arg
 128                  Syntax "$" [fun, arg] ->
 129                         showParen (p <= prec_dollar) $
 130                         showsPrec prec_dollar fun .
 131                         showString (" $ ") .
 132                         showsPrec prec_dollar arg
 133                  _ ->
 134                         showParen (p <= prec_app) $
 135                         showString n .
 136                         showString " " .
 137                         showString (List.unwords $ show <$> args)
 138                 where
 139                 prec_arrow  = 1
 140                 prec_lambda = 1
 141                 prec_dollar = 1
 142                 prec_app    = 10