]> Git — Sourcephile - haskell/symantic.git/blob - Language/Symantic/Repr/Text.hs
Repr_Dup helpers
[haskell/symantic.git] / Language / Symantic / Repr / Text.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
4 {-# LANGUAGE MultiParamTypeClasses #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE TypeFamilies #-}
7 {-# LANGUAGE UndecidableInstances #-}
8 -- | Interpreter to serialize an expression into a 'Text'.
9 module Language.Symantic.Repr.Text where
10
11 import Data.Monoid ((<>))
12 import Data.String (IsString(..))
13 import Data.Text (Text)
14 import qualified Data.Text as Text
15 import Prelude hiding (Integral(..))
16
17 -- * Type 'Repr_Text'
18
19 -- | Interpreter's data.
20 newtype Repr_Text h
21 = Repr_Text
22 { unRepr_Text
23 -- Inherited attributes:
24 :: Precedence
25 -> Repr_Text_Lambda_Depth
26 -- Synthetised attributes:
27 -> Text
28 }
29 type Repr_Text_Lambda_Depth = Int
30 instance Show (Repr_Text h) where
31 show = Text.unpack . text_from_expr
32
33 -- | Interpreter.
34 text_from_expr :: Repr_Text h -> Text
35 text_from_expr r = unRepr_Text r precedence_Toplevel 0
36
37 -- * Helpers
38
39 -- ** Helpers for lambda applications
40 repr_text_app0 :: Text -> Repr_Text h
41 repr_text_app0 name = Repr_Text $ \_p _v -> name
42 repr_text_app1
43 :: Text
44 -> Repr_Text a1
45 -> Repr_Text h
46 repr_text_app1 name (Repr_Text a1) =
47 Repr_Text $ \p v ->
48 let p' = precedence_App in
49 paren p p' $ name
50 <> " " <> a1 p' v
51 repr_text_app2
52 :: Text
53 -> Repr_Text a1
54 -> Repr_Text a2
55 -> Repr_Text h
56 repr_text_app2 name (Repr_Text a1) (Repr_Text a2) =
57 Repr_Text $ \p v ->
58 let p' = precedence_App in
59 paren p p' $ name
60 <> " " <> a1 p' v
61 <> " " <> a2 p' v
62 repr_text_app3
63 :: Text
64 -> Repr_Text a1
65 -> Repr_Text a2
66 -> Repr_Text a3
67 -> Repr_Text h
68 repr_text_app3 name (Repr_Text a1) (Repr_Text a2) (Repr_Text a3) =
69 Repr_Text $ \p v ->
70 let p' = precedence_App in
71 paren p p' $ name
72 <> " " <> a1 p' v
73 <> " " <> a2 p' v
74 <> " " <> a3 p' v
75 repr_text_infix
76 :: Text
77 -> Precedence
78 -> Repr_Text a1
79 -> Repr_Text a2
80 -> Repr_Text h
81 repr_text_infix name p' (Repr_Text a1) (Repr_Text a2) =
82 Repr_Text $ \p v ->
83 paren p p' $ a1 p' v <> " " <> name <> " " <> a2 p' v
84
85 -- ** Type 'Precedence'
86
87 newtype Precedence = Precedence Int
88 deriving (Eq, Ord, Show)
89 precedence_pred :: Precedence -> Precedence
90 precedence_pred (Precedence p) = Precedence (pred p)
91 precedence_succ :: Precedence -> Precedence
92 precedence_succ (Precedence p) = Precedence (succ p)
93 paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
94 paren prec prec' x =
95 if prec >= prec'
96 then fromString "(" <> x <> fromString ")"
97 else x
98
99 precedence_Toplevel :: Precedence
100 precedence_Toplevel = Precedence 0
101 precedence_App :: Precedence
102 precedence_App = Precedence 10
103 precedence_Atomic :: Precedence
104 precedence_Atomic = Precedence maxBound