]> Git — Sourcephile - haskell/symantic.git/blob - Language/Symantic/Compiling/Show.hs
Add Parsing.Grammar.
[haskell/symantic.git] / Language / Symantic / Compiling / Show.hs
1 {-# LANGUAGE UndecidableInstances #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 -- | Symantic for 'Show'.
4 module Language.Symantic.Compiling.Show where
5
6 import Control.Monad
7 import Data.Proxy (Proxy(..))
8 import Data.Text (Text)
9 import Data.Type.Equality ((:~:)(Refl))
10 import Prelude hiding (Show(..))
11 import Text.Show (Show)
12 import qualified Text.Show as Show
13
14 import Language.Symantic.Parsing
15 import Language.Symantic.Typing
16 import Language.Symantic.Compiling.Term
17 import Language.Symantic.Interpreting
18 import Language.Symantic.Transforming.Trans
19
20 -- * Class 'Sym_Show'
21 class Sym_Show term where
22 showsPrec :: Show a => term Int -> term a -> term ShowS
23 show :: Show a => term a -> term String
24 showList :: Show a => term [a] -> term ShowS
25
26 default showsPrec :: (Trans t term, Show a) => t term Int -> t term a -> t term ShowS
27 default show :: (Trans t term, Show a) => t term a -> t term String
28 default showList :: (Trans t term, Show a) => t term [a] -> t term ShowS
29
30 showsPrec = trans_map2 showsPrec
31 show = trans_map1 show
32 showList = trans_map1 showList
33
34 type instance Sym_of_Iface (Proxy Show) = Sym_Show
35 type instance Consts_of_Iface (Proxy Show) = Proxy Show ': Consts_imported_by Show
36 type instance Consts_imported_by Show =
37 [ Proxy []
38 , Proxy (->)
39 , Proxy Char
40 , Proxy Int
41 ]
42
43 instance Sym_Show HostI where
44 showsPrec = liftM2 Show.showsPrec
45 show = liftM Show.show
46 showList = liftM Show.showList
47 instance Sym_Show TextI where
48 showsPrec = textI2 "showsPrec"
49 show = textI1 "show"
50 showList = textI1 "showList"
51 instance (Sym_Show r1, Sym_Show r2) => Sym_Show (DupI r1 r2) where
52 showsPrec = dupI2 (Proxy @Sym_Show) showsPrec
53 show = dupI1 (Proxy @Sym_Show) show
54 showList = dupI1 (Proxy @Sym_Show) showList
55
56 instance
57 ( Read_TypeNameR Text cs rs
58 , Inj_Const cs Show
59 ) => Read_TypeNameR Text cs (Proxy Show ': rs) where
60 read_typenameR _cs "Show" k = k (ty @Show)
61 read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k
62 instance Show_Const cs => Show_Const (Proxy Show ': cs) where
63 show_const ConstZ{} = "Show"
64 show_const (ConstS c) = show_const c
65
66 instance Proj_ConC cs (Proxy Show)
67 data instance TokenT meta (ts::[*]) (Proxy Show)
68 = Token_Term_Show_showsPrec (EToken meta ts) (EToken meta ts)
69 | Token_Term_Show_show (EToken meta ts)
70 | Token_Term_Show_showList (EToken meta ts)
71 deriving instance Eq_Token meta ts => Eq (TokenT meta ts (Proxy Show))
72 deriving instance Show_Token meta ts => Show (TokenT meta ts (Proxy Show))
73 instance -- CompileI
74 ( Inj_Const (Consts_of_Ifaces is) (->)
75 , Inj_Const (Consts_of_Ifaces is) Char
76 , Inj_Const (Consts_of_Ifaces is) Int
77 , Inj_Const (Consts_of_Ifaces is) Show
78 , Inj_Const (Consts_of_Ifaces is) []
79 , Proj_Con (Consts_of_Ifaces is)
80 , Compile is
81 ) => CompileI is (Proxy Show) where
82 compileI tok ctx k =
83 case tok of
84 Token_Term_Show_showsPrec tok_p tok_a ->
85 compileO tok_p ctx $ \ty_p (TermO p) ->
86 compileO tok_a ctx $ \ty_a (TermO a) ->
87 check_type (At Nothing (ty @Int)) (At (Just tok_p) ty_p) $ \Refl ->
88 check_con (At (Just tok_a) (ty @Show :$ ty_a)) $ \Con ->
89 k tyShowS $ TermO $
90 \c -> showsPrec (p c) (a c)
91 Token_Term_Show_show tok_a ->
92 compileO tok_a ctx $ \ty_a (TermO a) ->
93 check_con (At (Just tok_a) (ty @Show :$ ty_a)) $ \Con ->
94 k tyString $ TermO $
95 \c -> show (a c)
96 Token_Term_Show_showList tok_as ->
97 compileO tok_as ctx $ \ty_as (TermO as) ->
98 check_type1 (ty @[]) (At (Just tok_as) ty_as) $ \Refl ty_a ->
99 check_con (At (Just tok_as) (ty @Show :$ ty_a)) $ \Con ->
100 k tyShowS $ TermO $
101 \c -> showList (as c)
102 where
103 tyString = ty @[] :$ ty @Char
104 tyShowS = tyString ~> tyString