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 import Data.String (IsString(..))
  13
  14 -- * Class 'AST'
  15 class AST node where
  16         type Lexem node
  17         ast_lexem :: node -> Lexem node
  18         ast_nodes :: node -> [node]
  19
  20 -- ** Type 'At'
  21 -- | Attach a location.
  22 data At ast a
  23  =   At (Maybe ast) a
  24  deriving (Eq, Show)
  25 instance Functor (At ast) where
  26         fmap f (At ast a) = At ast (f a)
  27
  28 data Error_Syntax ast
  29  = Error_Syntax_more_arguments_needed (At ast Int)
  30  | Error_Syntax_too_many_arguments    (At ast Int)
  31  deriving (Eq, Show)
  32
  33 class Lift_Error_Syntax err where
  34         lift_error_syntax :: Error_Syntax ast -> err ast
  35
  36 from_ast2
  37  :: (AST ast, Lift_Error_Syntax err) => ast
  38  -> (ast -> ast -> Either (err ast) ret)
  39  -> Either (err ast) ret
  40 from_ast2 ast k =
  41         case ast_nodes ast of
  42          [a1, a2] -> k a1 a2
  43          args | length args < 2 ->
  44                 Left $ lift_error_syntax $
  45                 Error_Syntax_more_arguments_needed $
  46                 At (Just ast) $ 2 - length args
  47          args -> Left $ lift_error_syntax $
  48                 Error_Syntax_too_many_arguments $
  49                 At (Just ast) $ length args - 2
  50 from_ast3
  51  :: (AST ast, Lift_Error_Syntax err) => ast
  52  -> (ast -> ast -> ast -> Either (err ast) ret)
  53  -> Either (err ast) ret
  54 from_ast3 ast k =
  55         case ast_nodes ast of
  56          [a1, a2, a3] -> k a1 a2 a3
  57          args | length args < 3 ->
  58                 Left $ lift_error_syntax $
  59                 Error_Syntax_more_arguments_needed $
  60                 At (Just ast) $ 3 - length args
  61          args -> Left $ lift_error_syntax $
  62                 Error_Syntax_too_many_arguments $
  63                 At (Just ast) $ length args - 3
  64
  65 -- * Type 'Syntax'
  66 data Syntax a
  67  =   Syntax a [Syntax a]
  68  deriving (Eq)
  69 instance AST (Syntax a) where
  70         type Lexem (Syntax a) = a
  71         ast_lexem (Syntax x _)  = x
  72         ast_nodes (Syntax _ ns) = ns
  73
  74 -- | Custom 'Show' instance a little bit more readable
  75 -- than the automatically derived one.
  76 instance Show (Syntax Text) where
  77         showsPrec p ast@(Syntax name args) =
  78                 let n = Text.unpack name in
  79                 case ast of
  80                  Syntax _ [] -> showString n
  81                  Syntax "(->)" [a] ->
  82                         showParen (p <= prec_arrow) $
  83                         showString (""++n++" ") .
  84                         showsPrec prec_arrow a
  85                  Syntax "(->)" [a, b] ->
  86                         showParen (p <= prec_arrow) $
  87                         showsPrec prec_arrow a .
  88                         showString (" -> ") .
  89                         showsPrec (prec_arrow + 1) b
  90                  Syntax "\\" [var, ty, body] ->
  91                         showParen (p <= prec_lambda) $
  92                         showString ("\\(") .
  93                         showsPrec prec_lambda var .
  94                         showString (":") .
  95                         showsPrec prec_lambda ty .
  96                         showString (") -> ") .
  97                         showsPrec prec_lambda body
  98                  Syntax " " [fun, arg] ->
  99                         showParen (p <= prec_app) $
 100                         showsPrec prec_dollar fun .
 101                         showString (" ") .
 102                         showsPrec prec_dollar arg
 103                  Syntax "$" [fun, arg] ->
 104                         showParen (p <= prec_dollar) $
 105                         showsPrec prec_dollar fun .
 106                         showString (" $ ") .
 107                         showsPrec prec_dollar arg
 108                  _ ->
 109                         showParen (p <= prec_app) $
 110                         showString n .
 111                         showString " " .
 112                         showString (List.unwords $ show <$> args)
 113                 where
 114                 prec_arrow  = 1
 115                 prec_lambda = 1
 116                 prec_dollar = 1
 117                 prec_app    = 10
 118
 119
 120 syBool :: IsString a => Syntax a
 121 syBool = Syntax "Bool" []
 122 syEq :: IsString a => [Syntax a] -> Syntax a
 123 syEq = Syntax "Eq"
 124 syFun :: IsString a => [Syntax a] -> Syntax a
 125 syFun = Syntax "(->)"
 126 syInt :: IsString a => Syntax a
 127 syInt = Syntax "Int" []
 128 syIO :: IsString a => [Syntax a] -> Syntax a
 129 syIO = Syntax "IO"
 130 syTraversable :: IsString a => [Syntax a] -> Syntax a
 131 syTraversable = Syntax "Traversable"
 132 syMonad :: IsString a => [Syntax a] -> Syntax a
 133 syMonad = Syntax "Monad"
 134 (.>) :: IsString a => Syntax a -> Syntax a -> Syntax a
 135 a .> b = syFun [a, b]
 136 infixr 3 .>