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