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

   1 module Language.Symantic.Document.Sym where
   2
   3 import Data.Bool
   4 import Data.Char (Char)
   5 import Data.Eq (Eq(..))
   6 import Data.Foldable (Foldable(..))
   7 import Data.Function ((.), ($))
   8 import Data.Functor (Functor(..))
   9 import Data.Int (Int, Int64)
  10 import Data.Ord (Ord(..), Ordering(..))
  11 import Data.Semigroup (Semigroup(..))
  12 import Data.String (String, IsString)
  13 import Prelude (Integer, toInteger, fromIntegral, Num(..))
  14 import qualified Data.List as List
  15 import qualified Data.Text as Text
  16 import qualified Data.Text.Lazy as TL
  17
  18 -- * Type family 'Column'
  19 type family Column (d:: *) :: *
  20
  21 -- * Type family 'Indent'
  22 type family Indent (d:: *) :: *
  23
  24 -- * Class 'Textable'
  25 class (IsString d, Semigroup d) => Textable d where
  26         charH     :: Char -- ^ XXX: MUST NOT be '\n'
  27                   -> d
  28         stringH   :: String -- ^ XXX: MUST NOT contain '\n'
  29                   -> d
  30         textH     :: Text.Text -- ^ XXX: MUST NOT contain '\n'
  31                   -> d
  32         ltextH    :: TL.Text -- ^ XXX: MUST NOT contain '\n'
  33                   -> d
  34         replicate :: Int -> d -> d
  35         integer   :: Integer -> d
  36         default replicate :: Textable (ReprOf d) => Trans d => Int -> d -> d
  37         default integer   :: Textable (ReprOf d) => Trans d => Integer -> d
  38         default charH     :: Textable (ReprOf d) => Trans d => Char -> d
  39         default stringH   :: Textable (ReprOf d) => Trans d => String -> d
  40         default textH     :: Textable (ReprOf d) => Trans d => Text.Text -> d
  41         default ltextH    :: Textable (ReprOf d) => Trans d => TL.Text -> d
  42         charH     = trans . charH
  43         stringH   = trans . stringH
  44         textH     = trans . textH
  45         ltextH    = trans . ltextH
  46         replicate = trans1 . replicate
  47         integer   = trans . integer
  48
  49         empty       :: d
  50         newline     :: d
  51         space       :: d
  52         -- | @x '<+>' y = x '<>' 'space' '<>' y@
  53         (<+>)       :: d -> d -> d
  54         -- | @x '</>' y = x '<>' 'newline' '<>' y@
  55         (</>)       :: d -> d -> d
  56         int         :: Int -> d
  57         char        :: Char    -> d
  58         string      :: String  -> d
  59         text        :: Text.Text  -> d
  60         ltext       :: TL.Text -> d
  61         catH        :: Foldable f => f d -> d
  62         catV        :: Foldable f => f d -> d
  63         foldrWith   :: Foldable f => (d -> d -> d) -> f d -> d
  64         foldWith    :: Foldable f => (d -> d) -> f d -> d
  65         intercalate :: Foldable f => d -> f d -> d
  66         between     :: d -> d -> d -> d
  67
  68         newline  = "\n"
  69         space    = char ' '
  70         x <+> y  = x <> space <> y
  71         x </> y  = x <> newline <> y
  72         int      = integer . toInteger
  73         char     = \case '\n' -> newline; c -> charH c
  74         string   = catV . fmap stringH . lines
  75         text     = catV . fmap textH   . Text.lines
  76         ltext    = catV . fmap ltextH  . TL.lines
  77         catH     = foldr (<>) empty
  78         catV     = foldrWith (\x y -> x<>newline<>y)
  79         foldrWith f ds  = if null ds then empty else foldr1 f ds
  80         foldWith  f     = foldrWith $ \a acc -> a <> f acc
  81         intercalate sep = foldrWith (\x y -> x<>sep<>y)
  82         between o c d = o<>d<>c
  83         -- default catH :: Textable (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
  84         -- default catV :: Textable (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
  85         -- catH  l = trans (catH (fmap unTrans l))
  86         -- catV  l = trans (catV (fmap unTrans l))
  87
  88 -- * Class 'Alignable'
  89 class Textable d => Alignable d where
  90         -- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
  91         align :: d -> d
  92         -- | @('hang' ind d)@ make @d@ uses current 'Column' plus @ind@ as 'Indent' level.
  93         hang :: Indent d -> d -> d
  94         hang ind = align . incrIndent ind
  95         -- | @('incrIndent' ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
  96         incrIndent  :: Indent d -> d -> d
  97         -- | @('withIndent' ind d)@ make @d@ uses @ind@ as 'Indent' level.
  98         withIndent  :: Indent d -> d -> d
  99         -- | @('withNewline' nl d)@ make @d@ uses @nl@ as 'newline'.
 100         --
 101         -- Useful values for @nl@ are: 'empty', 'newlineWithIndent', 'newlineWithoutIndent'.
 102         withNewline :: d -> d -> d
 103         newlineWithoutIndent :: d
 104         newlineWithIndent    :: d
 105         -- | @('column' f)@ return @f@ applied to the current 'Column'.
 106         column :: (Column d -> d) -> d
 107         -- | @('endToEndWidth' d f)@ return @d@ concatenated to
 108         -- @f@ applied to the difference between the end 'Column' and start 'Column' of @d@.
 109         --
 110         -- Note that @f@ is given the end-to-end width,
 111         -- which is not necessarily the maximal width.
 112         default endToEndWidth ::
 113          Semigroup d =>
 114          Num (Column d) =>
 115          d -> (Column d -> d) -> d
 116         endToEndWidth :: d -> (Column d -> d) -> d
 117         endToEndWidth d f = column $ \c1 -> (d <>) $ column $ \c2 -> f $ c2 - c1
 118
 119         -- | @'spaces' ind = 'replicate' ind 'space'@
 120         default spaces :: Indent d ~ Int => Indent d -> d
 121         spaces :: Indent d -> d
 122         spaces i = replicate i space
 123
 124         -- | @('fill' ind d)@ return @d@ then as many 'space's as needed
 125         -- so that the whole is @ind@ 'Column's wide.
 126         default fill ::
 127          Indent d ~ Int =>
 128          Column d ~ Int =>
 129          Indent d -> d -> d
 130         fill :: Indent d -> d -> d
 131         fill m d =
 132                 endToEndWidth d $ \w ->
 133                         case w`compare`m of
 134                          LT -> spaces $ m - w
 135                          _  -> empty
 136
 137         -- | @('breakableFill' ind f d)@ return @f@ then as many 'space's as needed
 138         -- so that the whole is @ind@ 'Column's wide,
 139         -- then, if @f@ is not wider than @ind@, appends @d@,
 140         -- otherwise appends a 'newline' and @d@,
 141         -- with an 'Indent' level set to the start 'Column' of @f@ plus @ind@.
 142         default breakableFill ::
 143          Indent d ~ Int =>
 144          Column d ~ Int =>
 145          Indent d -> d -> d -> d
 146         breakableFill :: Indent d -> d -> d -> d
 147         breakableFill m f d =
 148                 column $ \c ->
 149                 endToEndWidth f $ \w ->
 150                         case w`compare`m of
 151                          LT -> spaces (m - w) <> d
 152                          EQ -> d
 153                          GT -> withIndent (c + m) (newline <> d)
 154
 155 -- * Class 'Wrapable'
 156 class (Textable d, Alignable d) => Wrapable d where
 157         -- | @('ifWrap' onWrap onNoWrap)@
 158         -- return @onWrap@ if @onNoWrap@ leads to a 'Column'
 159         -- greater or equal to the one sets with 'withWrapColumn',
 160         -- otherwise return @onNoWrap@.
 161         ifWrap :: d -> d -> d
 162         -- | @('breakpoint' onNoBreak onBreak d)@
 163         -- return @onNoBreak@ then @d@ if they fit,
 164         -- @onBreak@ otherwise.
 165         breakpoint :: d -> d -> d -> d
 166         -- | @('breakableEmpty' d)@ return @d@ if it fits, 'newline' then @d@ otherwise.
 167         breakableEmpty :: d -> d
 168         breakableEmpty = breakpoint empty newline
 169         -- | @x '><' y = x '<>' 'breakableEmpty' y@
 170         (><) :: d -> d -> d
 171         x >< y = x <> breakableEmpty y
 172         -- | @('breakableSpace' d)@ return 'space' then @d@ it they fit,
 173         -- 'newline' then @d@ otherwise.
 174         breakableSpace :: d -> d
 175         breakableSpace = breakpoint space newline
 176         -- | @x '>+<' y = x '<>' 'breakableSpace' y@
 177         (>+<) :: d -> d -> d
 178         x >+< y = x <> breakableSpace y
 179         -- | @'breakableSpaces' ds@ intercalate a 'breakableSpace'
 180         -- between items of @ds@.
 181         breakableSpaces :: Foldable f => f d -> d
 182         breakableSpaces = foldWith breakableSpace
 183         -- | @'withWrapColumn' col d@ set the 'Column' triggering wrapping to @col@ within @d@.
 184         withWrapColumn :: Column d -> d -> d
 185         -- | @('intercalateHorV' sep ds)@
 186         -- return @ds@ with @sep@ intercalated if the whole fits,
 187         -- otherwise return 'align' of @ds@ with 'newline' and @sep@ intercalated.
 188         intercalateHorV :: Foldable f => d -> f d -> d
 189         intercalateHorV sep xs =
 190                 ifWrap
 191                  (align $ foldWith ((newline <> sep) <>) xs)
 192                  (foldWith (sep <>) xs)
 193
 194 -- * Class 'Colorable'
 195 class Colorable d where
 196         -- | @('colorable' f)@ return @f@ applied to whether colors are activated or not.
 197         colorable :: (Bool -> d) -> d
 198         -- | @('withColor' b d)@ whether to active colors or not within @d@.
 199         withColorable :: Bool -> d -> d
 200
 201         reverse :: d -> d
 202
 203         -- Foreground colors
 204         -- Dull
 205         black   :: d -> d
 206         red     :: d -> d
 207         green   :: d -> d
 208         yellow  :: d -> d
 209         blue    :: d -> d
 210         magenta :: d -> d
 211         cyan    :: d -> d
 212         white   :: d -> d
 213
 214         -- Vivid
 215         blacker   :: d -> d
 216         redder    :: d -> d
 217         greener   :: d -> d
 218         yellower  :: d -> d
 219         bluer     :: d -> d
 220         magentaer :: d -> d
 221         cyaner    :: d -> d
 222         whiter    :: d -> d
 223
 224         -- Background colors
 225         -- Dull
 226         onBlack   :: d -> d
 227         onRed     :: d -> d
 228         onGreen   :: d -> d
 229         onYellow  :: d -> d
 230         onBlue    :: d -> d
 231         onMagenta :: d -> d
 232         onCyan    :: d -> d
 233         onWhite   :: d -> d
 234
 235         -- Vivid
 236         onBlacker   :: d -> d
 237         onRedder    :: d -> d
 238         onGreener   :: d -> d
 239         onYellower  :: d -> d
 240         onBluer     :: d -> d
 241         onMagentaer :: d -> d
 242         onCyaner    :: d -> d
 243         onWhiter    :: d -> d
 244
 245         default reverse     :: Colorable (ReprOf d) => Trans d => d -> d
 246         default black       :: Colorable (ReprOf d) => Trans d => d -> d
 247         default red         :: Colorable (ReprOf d) => Trans d => d -> d
 248         default green       :: Colorable (ReprOf d) => Trans d => d -> d
 249         default yellow      :: Colorable (ReprOf d) => Trans d => d -> d
 250         default blue        :: Colorable (ReprOf d) => Trans d => d -> d
 251         default magenta     :: Colorable (ReprOf d) => Trans d => d -> d
 252         default cyan        :: Colorable (ReprOf d) => Trans d => d -> d
 253         default white       :: Colorable (ReprOf d) => Trans d => d -> d
 254         default blacker     :: Colorable (ReprOf d) => Trans d => d -> d
 255         default redder      :: Colorable (ReprOf d) => Trans d => d -> d
 256         default greener     :: Colorable (ReprOf d) => Trans d => d -> d
 257         default yellower    :: Colorable (ReprOf d) => Trans d => d -> d
 258         default bluer       :: Colorable (ReprOf d) => Trans d => d -> d
 259         default magentaer   :: Colorable (ReprOf d) => Trans d => d -> d
 260         default cyaner      :: Colorable (ReprOf d) => Trans d => d -> d
 261         default whiter      :: Colorable (ReprOf d) => Trans d => d -> d
 262         default onBlack     :: Colorable (ReprOf d) => Trans d => d -> d
 263         default onRed       :: Colorable (ReprOf d) => Trans d => d -> d
 264         default onGreen     :: Colorable (ReprOf d) => Trans d => d -> d
 265         default onYellow    :: Colorable (ReprOf d) => Trans d => d -> d
 266         default onBlue      :: Colorable (ReprOf d) => Trans d => d -> d
 267         default onMagenta   :: Colorable (ReprOf d) => Trans d => d -> d
 268         default onCyan      :: Colorable (ReprOf d) => Trans d => d -> d
 269         default onWhite     :: Colorable (ReprOf d) => Trans d => d -> d
 270         default onBlacker   :: Colorable (ReprOf d) => Trans d => d -> d
 271         default onRedder    :: Colorable (ReprOf d) => Trans d => d -> d
 272         default onGreener   :: Colorable (ReprOf d) => Trans d => d -> d
 273         default onYellower  :: Colorable (ReprOf d) => Trans d => d -> d
 274         default onBluer     :: Colorable (ReprOf d) => Trans d => d -> d
 275         default onMagentaer :: Colorable (ReprOf d) => Trans d => d -> d
 276         default onCyaner    :: Colorable (ReprOf d) => Trans d => d -> d
 277         default onWhiter    :: Colorable (ReprOf d) => Trans d => d -> d
 278
 279         reverse     = trans1 reverse
 280         black       = trans1 black
 281         red         = trans1 red
 282         green       = trans1 green
 283         yellow      = trans1 yellow
 284         blue        = trans1 blue
 285         magenta     = trans1 magenta
 286         cyan        = trans1 cyan
 287         white       = trans1 white
 288         blacker     = trans1 blacker
 289         redder      = trans1 redder
 290         greener     = trans1 greener
 291         yellower    = trans1 yellower
 292         bluer       = trans1 bluer
 293         magentaer   = trans1 magentaer
 294         cyaner      = trans1 cyaner
 295         whiter      = trans1 whiter
 296         onBlack     = trans1 onBlack
 297         onRed       = trans1 onRed
 298         onGreen     = trans1 onGreen
 299         onYellow    = trans1 onYellow
 300         onBlue      = trans1 onBlue
 301         onMagenta   = trans1 onMagenta
 302         onCyan      = trans1 onCyan
 303         onWhite     = trans1 onWhite
 304         onBlacker   = trans1 onBlacker
 305         onRedder    = trans1 onRedder
 306         onGreener   = trans1 onGreener
 307         onYellower  = trans1 onYellower
 308         onBluer     = trans1 onBluer
 309         onMagentaer = trans1 onMagentaer
 310         onCyaner    = trans1 onCyaner
 311         onWhiter    = trans1 onWhiter
 312
 313 -- * Class 'Decorable'
 314 class Decorable d where
 315         -- | @('decorable' f)@ return @f@ applied to whether decorations are activated or not.
 316         decorable :: (Bool -> d) -> d
 317         -- | @('withColor' b d)@ whether to active decorations or not within @d@.
 318         withDecorable :: Bool -> d -> d
 319
 320         bold      :: d -> d
 321         underline :: d -> d
 322         italic    :: d -> d
 323         default bold      :: Decorable (ReprOf d) => Trans d => d -> d
 324         default underline :: Decorable (ReprOf d) => Trans d => d -> d
 325         default italic    :: Decorable (ReprOf d) => Trans d => d -> d
 326         bold      = trans1 bold
 327         underline = trans1 underline
 328         italic    = trans1 italic
 329
 330 -- * Class 'Trans'
 331 class Trans tr where
 332         -- | Return the underlying @tr@ of the transformer.
 333         type ReprOf tr :: *
 334
 335         -- | Lift a tr to the transformer's.
 336         trans :: ReprOf tr -> tr
 337         -- | Unlift a tr from the transformer's.
 338         unTrans :: tr -> ReprOf tr
 339
 340         -- | Identity transformation for a unary symantic method.
 341         trans1 :: (ReprOf tr -> ReprOf tr) -> (tr -> tr)
 342         trans1 f = trans . f . unTrans
 343
 344         -- | Identity transformation for a binary symantic method.
 345         trans2
 346          :: (ReprOf tr -> ReprOf tr -> ReprOf tr)
 347          -> (tr -> tr -> tr)
 348         trans2 f t1 t2 = trans (f (unTrans t1) (unTrans t2))
 349
 350         -- | Identity transformation for a ternary symantic method.
 351         trans3
 352          :: (ReprOf tr -> ReprOf tr -> ReprOf tr -> ReprOf tr)
 353          -> (tr -> tr -> tr -> tr)
 354         trans3 f t1 t2 t3 = trans (f (unTrans t1) (unTrans t2) (unTrans t3))
 355
 356 int64OfInt :: Int -> Int64
 357 int64OfInt = fromIntegral
 358
 359 intOfInt64 :: Int64 -> Int
 360 intOfInt64 = fromIntegral
 361
 362 -- | Break a 'String' into lines while preserving all empty lines.
 363 lines :: String -> [String]
 364 lines cs =
 365         case List.break (== '\n') cs of
 366          (chunk, _:rest) -> chunk : lines rest
 367          (chunk, []) -> [chunk]