symantic-document/Language/Symantic/Document/Sym.hs

   1 {-# LANGUAGE PolyKinds #-}
   2 module Language.Symantic.Document.Sym where
   3
   4 import Data.Char (Char)
   5 import Data.Foldable (Foldable(..))
   6 import Data.Function ((.))
   7 import Data.Functor (Functor(..))
   8 import Data.Int (Int, Int64)
   9 import Data.Semigroup (Semigroup(..))
  10 import Data.String (String, IsString)
  11 import Data.Text (Text)
  12 import Prelude (Integer, fromInteger, toInteger)
  13 import qualified Data.List as L
  14 import qualified Data.Text as T
  15 import qualified Data.Text.Lazy as TL
  16
  17 -- * Class 'Doc_Text'
  18 class (IsString d, Semigroup d) => Doc_Text d where
  19         charH     :: Char    -> d -- ^ XXX: MUST NOT be '\n'
  20         stringH   :: String  -> d -- ^ XXX: MUST NOT contain '\n'
  21         textH     :: Text    -> d -- ^ XXX: MUST NOT contain '\n'
  22         ltextH    :: TL.Text -> d -- ^ XXX: MUST NOT contain '\n'
  23         replicate :: Int -> d -> d
  24         integer   :: Integer -> d
  25         default charH     :: Doc_Text (ReprOf d) => Trans d => Char -> d
  26         default stringH   :: Doc_Text (ReprOf d) => Trans d => String -> d
  27         default textH     :: Doc_Text (ReprOf d) => Trans d => Text -> d
  28         default ltextH    :: Doc_Text (ReprOf d) => Trans d => TL.Text -> d
  29         default replicate :: Doc_Text (ReprOf d) => Trans d => Int -> d -> d
  30         default integer   :: Doc_Text (ReprOf d) => Trans d => Integer -> d
  31         charH     = trans . charH
  32         stringH   = trans . stringH
  33         textH     = trans . textH
  34         ltextH    = trans . ltextH
  35         replicate = trans1 . replicate
  36         integer   = trans . integer
  37
  38         empty     :: d
  39         eol       :: d
  40         space     :: d
  41         spaces    :: Int -> d
  42         int       :: Int -> d
  43         char      :: Char    -> d
  44         string    :: String  -> d
  45         text      :: Text    -> d
  46         ltext     :: TL.Text -> d
  47         catH      :: Foldable f => f d -> d
  48         catV      :: Foldable f => f d -> d
  49         paren     :: d -> d
  50         brace     :: d -> d
  51         bracket   :: d -> d
  52         bquote    :: d -> d
  53         dquote    :: d -> d
  54         fquote    :: d -> d
  55         squote    :: d -> d
  56
  57         empty     = ""
  58         eol       = "\n"
  59         space     = char ' '
  60         spaces i  = replicate i space
  61         int       = integer . toInteger
  62         char      = \case '\n' -> eol; c -> charH c
  63         string    = catV . fmap stringH . L.lines
  64         text      = catV . fmap textH   . T.lines
  65         ltext     = catV . fmap ltextH  . TL.lines
  66         catH      = foldr (<>) empty
  67         catV l    = if null l then empty else foldr1 (\a acc -> a <> eol <> acc) l
  68         paren   d = charH '('   <> d <> charH ')'
  69         brace   d = charH '{'   <> d <> charH '}'
  70         bracket d = charH '['   <> d <> charH ']'
  71         bquote  d = charH '`'   <> d <> charH '`'
  72         dquote  d = charH '\"'  <> d <> charH '\"'
  73         fquote  d =       "« "  <> d <>       " »"
  74         squote  d = charH '\''  <> d <> charH '\''
  75         -- default catH :: Doc_Text (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
  76         -- default catV :: Doc_Text (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
  77         -- catH  l = trans (catH (fmap unTrans l))
  78         -- catV  l = trans (catV (fmap unTrans l))
  79
  80 -- * Class 'Doc_Color'
  81 class Doc_Color d where
  82         reverse :: d -> d
  83
  84         -- Foreground colors
  85         -- Dull
  86         black   :: d -> d
  87         red     :: d -> d
  88         green   :: d -> d
  89         yellow  :: d -> d
  90         blue    :: d -> d
  91         magenta :: d -> d
  92         cyan    :: d -> d
  93         white   :: d -> d
  94
  95         -- Vivid
  96         blacker   :: d -> d
  97         redder    :: d -> d
  98         greener   :: d -> d
  99         yellower  :: d -> d
 100         bluer     :: d -> d
 101         magentaer :: d -> d
 102         cyaner    :: d -> d
 103         whiter    :: d -> d
 104
 105         -- Background colors
 106         -- Dull
 107         onBlack   :: d -> d
 108         onRed     :: d -> d
 109         onGreen   :: d -> d
 110         onYellow  :: d -> d
 111         onBlue    :: d -> d
 112         onMagenta :: d -> d
 113         onCyan    :: d -> d
 114         onWhite   :: d -> d
 115
 116         -- Vivid
 117         onBlacker   :: d -> d
 118         onRedder    :: d -> d
 119         onGreener   :: d -> d
 120         onYellower  :: d -> d
 121         onBluer     :: d -> d
 122         onMagentaer :: d -> d
 123         onCyaner    :: d -> d
 124         onWhiter    :: d -> d
 125
 126         default reverse     :: Doc_Color (ReprOf d) => Trans d => d -> d
 127         default black       :: Doc_Color (ReprOf d) => Trans d => d -> d
 128         default red         :: Doc_Color (ReprOf d) => Trans d => d -> d
 129         default green       :: Doc_Color (ReprOf d) => Trans d => d -> d
 130         default yellow      :: Doc_Color (ReprOf d) => Trans d => d -> d
 131         default blue        :: Doc_Color (ReprOf d) => Trans d => d -> d
 132         default magenta     :: Doc_Color (ReprOf d) => Trans d => d -> d
 133         default cyan        :: Doc_Color (ReprOf d) => Trans d => d -> d
 134         default white       :: Doc_Color (ReprOf d) => Trans d => d -> d
 135         default blacker     :: Doc_Color (ReprOf d) => Trans d => d -> d
 136         default redder      :: Doc_Color (ReprOf d) => Trans d => d -> d
 137         default greener     :: Doc_Color (ReprOf d) => Trans d => d -> d
 138         default yellower    :: Doc_Color (ReprOf d) => Trans d => d -> d
 139         default bluer       :: Doc_Color (ReprOf d) => Trans d => d -> d
 140         default magentaer   :: Doc_Color (ReprOf d) => Trans d => d -> d
 141         default cyaner      :: Doc_Color (ReprOf d) => Trans d => d -> d
 142         default whiter      :: Doc_Color (ReprOf d) => Trans d => d -> d
 143         default onBlack     :: Doc_Color (ReprOf d) => Trans d => d -> d
 144         default onRed       :: Doc_Color (ReprOf d) => Trans d => d -> d
 145         default onGreen     :: Doc_Color (ReprOf d) => Trans d => d -> d
 146         default onYellow    :: Doc_Color (ReprOf d) => Trans d => d -> d
 147         default onBlue      :: Doc_Color (ReprOf d) => Trans d => d -> d
 148         default onMagenta   :: Doc_Color (ReprOf d) => Trans d => d -> d
 149         default onCyan      :: Doc_Color (ReprOf d) => Trans d => d -> d
 150         default onWhite     :: Doc_Color (ReprOf d) => Trans d => d -> d
 151         default onBlacker   :: Doc_Color (ReprOf d) => Trans d => d -> d
 152         default onRedder    :: Doc_Color (ReprOf d) => Trans d => d -> d
 153         default onGreener   :: Doc_Color (ReprOf d) => Trans d => d -> d
 154         default onYellower  :: Doc_Color (ReprOf d) => Trans d => d -> d
 155         default onBluer     :: Doc_Color (ReprOf d) => Trans d => d -> d
 156         default onMagentaer :: Doc_Color (ReprOf d) => Trans d => d -> d
 157         default onCyaner    :: Doc_Color (ReprOf d) => Trans d => d -> d
 158         default onWhiter    :: Doc_Color (ReprOf d) => Trans d => d -> d
 159
 160         reverse     = trans1 reverse
 161         black       = trans1 black
 162         red         = trans1 red
 163         green       = trans1 green
 164         yellow      = trans1 yellow
 165         blue        = trans1 blue
 166         magenta     = trans1 magenta
 167         cyan        = trans1 cyan
 168         white       = trans1 white
 169         blacker     = trans1 blacker
 170         redder      = trans1 redder
 171         greener     = trans1 greener
 172         yellower    = trans1 yellower
 173         bluer       = trans1 bluer
 174         magentaer   = trans1 magentaer
 175         cyaner      = trans1 cyaner
 176         whiter      = trans1 whiter
 177         onBlack     = trans1 onBlack
 178         onRed       = trans1 onRed
 179         onGreen     = trans1 onGreen
 180         onYellow    = trans1 onYellow
 181         onBlue      = trans1 onBlue
 182         onMagenta   = trans1 onMagenta
 183         onCyan      = trans1 onCyan
 184         onWhite     = trans1 onWhite
 185         onBlacker   = trans1 onBlacker
 186         onRedder    = trans1 onRedder
 187         onGreener   = trans1 onGreener
 188         onYellower  = trans1 onYellower
 189         onBluer     = trans1 onBluer
 190         onMagentaer = trans1 onMagentaer
 191         onCyaner    = trans1 onCyaner
 192         onWhiter    = trans1 onWhiter
 193
 194 -- * Class 'Doc_Decoration'
 195 class Doc_Decoration d where
 196         bold      :: d -> d
 197         underline :: d -> d
 198         italic    :: d -> d
 199         default bold      :: Doc_Decoration (ReprOf d) => Trans d => d -> d
 200         default underline :: Doc_Decoration (ReprOf d) => Trans d => d -> d
 201         default italic    :: Doc_Decoration (ReprOf d) => Trans d => d -> d
 202         bold      = trans1 bold
 203         underline = trans1 underline
 204         italic    = trans1 italic
 205
 206 -- * Class 'Trans'
 207 class Trans tr where
 208         -- | Return the underlying @tr@ of the transformer.
 209         type ReprOf tr :: *
 210
 211         -- | Lift a tr to the transformer's.
 212         trans :: ReprOf tr -> tr
 213         -- | Unlift a tr from the transformer's.
 214         unTrans :: tr -> ReprOf tr
 215
 216         -- | Identity transformation for a unary symantic method.
 217         trans1 :: (ReprOf tr -> ReprOf tr) -> (tr -> tr)
 218         trans1 f = trans . f . unTrans
 219
 220         -- | Identity transformation for a binary symantic method.
 221         trans2
 222          :: (ReprOf tr -> ReprOf tr -> ReprOf tr)
 223          -> (tr -> tr -> tr)
 224         trans2 f t1 t2 = trans (f (unTrans t1) (unTrans t2))
 225
 226         -- | Identity transformation for a ternary symantic method.
 227         trans3
 228          :: (ReprOf tr -> ReprOf tr -> ReprOf tr -> ReprOf tr)
 229          -> (tr -> tr -> tr -> tr)
 230         trans3 f t1 t2 t3 = trans (f (unTrans t1) (unTrans t2) (unTrans t3))
 231
 232 int64OfInt :: Int -> Int64
 233 int64OfInt = fromInteger . toInteger