]> Git — Sourcephile - haskell/symantic.git/blob - Language/Symantic/Typing/Syntax.hs
Add Typing.Family and Compiling.MonoFunctor.
[haskell/symantic.git] / 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 -> 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, "")] | null as -> k x
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