Language/Symantic/Compiling/Text.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE DefaultSignatures #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE Rank2Types #-}
   8 {-# LANGUAGE ScopedTypeVariables #-}
   9 {-# LANGUAGE TypeFamilies #-}
  10 {-# LANGUAGE TypeOperators #-}
  11 {-# LANGUAGE UndecidableInstances #-}
  12 {-# OPTIONS_GHC -fno-warn-orphans #-}
  13 -- | Symantic for 'Text'.
  14 module Language.Symantic.Compiling.Text where
  15
  16 import qualified Data.Function as Fun
  17 import Data.Proxy
  18 import Data.String (IsString)
  19 import Data.Text (Text)
  20 import qualified Data.Text as Text
  21 import Data.Type.Equality ((:~:)(Refl))
  22
  23 import Language.Symantic.Typing
  24 import Language.Symantic.Compiling.Term
  25 import Language.Symantic.Interpreting
  26 import Language.Symantic.Transforming.Trans
  27
  28 -- * Class 'Sym_Text'
  29 class Sym_Text term where
  30         text :: Text -> term Text
  31         default text :: Trans t term => Text -> t term Text
  32         text = trans_lift . text
  33
  34 type instance Sym_of_Iface (Proxy Text) = Sym_Text
  35 type instance Consts_of_Iface (Proxy Text) = Proxy Text ': Consts_imported_by Text
  36 type instance Consts_imported_by Text =
  37  [ Proxy Eq
  38  , Proxy Monoid
  39  , Proxy Ord
  40  ]
  41
  42 instance Sym_Text HostI where
  43         text = HostI
  44 instance Sym_Text TextI where
  45         text a = TextI $ \_p _v ->
  46                 Text.pack (show a)
  47 instance (Sym_Text r1, Sym_Text r2) => Sym_Text (DupI r1 r2) where
  48         text x = text x `DupI` text x
  49
  50 instance Const_from Text cs => Const_from Text (Proxy Text ': cs) where
  51         const_from "Text" k = k (ConstZ kind)
  52         const_from s k = const_from s $ k . ConstS
  53 instance Show_Const cs => Show_Const (Proxy Text ': cs) where
  54         show_const ConstZ{} = "Text"
  55         show_const (ConstS c) = show_const c
  56
  57 instance -- Proj_ConC
  58  ( Proj_Const cs Text
  59  , Proj_Consts cs (Consts_imported_by Text)
  60  ) => Proj_ConC cs (Proxy Text) where
  61         proj_conC _ (TyConst q :$ TyConst c)
  62          | Just Refl <- eq_skind (kind_of_const c) SKiType
  63          , Just Refl <- proj_const c (Proxy::Proxy Text)
  64          = Just $ case () of
  65                  _ | Just Refl <- proj_const q (Proxy::Proxy Eq)     -> Just Con
  66                    | Just Refl <- proj_const q (Proxy::Proxy Monoid) -> Just Con
  67                    | Just Refl <- proj_const q (Proxy::Proxy Ord)    -> Just Con
  68                  _ -> Nothing
  69         proj_conC _c _q = Nothing
  70 instance -- Term_fromI
  71  ( AST ast
  72  , Lexem ast ~ LamVarName
  73  , Inj_Const (Consts_of_Ifaces is) Text
  74  , Show_Const (Consts_of_Ifaces is)
  75  ) => Term_fromI is (Proxy Text) ast where
  76         term_fromI ast _ctx k =
  77                 case ast_lexem ast of
  78                  "text" -> text_from
  79                  _ -> Left $ Error_Term_unsupported
  80                 where
  81                 text_from =
  82                         let ty = tyText in
  83                         from_ast1 ast $ \ast_lit as ->
  84                         from_lex (Text.pack $ show_type ty) ast_lit $ \(lit::Text) ->
  85                         k as ty $ TermLC $ Fun.const $ text lit
  86
  87 -- | The 'Text' 'Type'
  88 tyText :: Inj_Const cs Text => Type cs Text
  89 tyText = TyConst inj_const
  90
  91 sym_Text :: Proxy Sym_Text
  92 sym_Text = Proxy
  93
  94 syText :: IsString a => Syntax a
  95 syText = Syntax "Text" []