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

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