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

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