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