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         -- | @('indent' f)@ write @f@ applied to the current 'Indent'.
 137         indent :: (Indent -> d) -> d
 138         -- | @('endToEndWidth' d f)@ write @d@ then
 139         -- @f@ applied to the difference between
 140         -- the end 'Column' and start 'Column' of @d@.
 141         --
 142         -- Note that @f@ is given the end-to-end width,
 143         -- which is not necessarily the maximal width.
 144         endToEndWidth :: d -> (Column -> d) -> d
 145         endToEndWidth d f = column $ \c1 -> (d <>) $ column $ \c2 -> f $ c2 - c1
 146
 147         -- | @'spaces' ind = 'replicate' ind 'space'@
 148         spaces :: Indent -> d
 149         spaces i = replicate (fromIntegral i) space
 150
 151         -- | @('fill' ind d)@ write @d@,
 152         -- then if @d@ is not wider than @ind@,
 153         -- write the difference with 'spaces'.
 154         fill :: Indent -> d -> d
 155         fill m d =
 156                 endToEndWidth d $ \w ->
 157                         case w`compare`m of
 158                          LT -> spaces $ m - w
 159                          _  -> empty
 160
 161         -- | @('breakableFill' ind d)@ write @d@,
 162         -- then if @d@ is not wider than @ind@, write the difference with 'spaces'
 163         -- otherwise write a 'newline' indented to to the start 'Column' of @d@ plus @ind@.
 164         breakableFill :: Indent -> d -> d
 165         breakableFill m d =
 166                 column $ \c ->
 167                 endToEndWidth d $ \w ->
 168                         case w`compare`m of
 169                          LT -> spaces (m - w) <> empty
 170                          EQ -> empty
 171                          GT -> withIndent (c + m) newline
 172
 173 -- * Class 'Wrapable'
 174 class (Textable d, Alignable d) => Wrapable d where
 175         -- | @('ifWrap' onWrap onNoWrap)@
 176         -- write @onWrap@ if @onNoWrap@ leads to a 'Column'
 177         -- greater or equal to the one sets with 'withWrapColumn',
 178         -- otherwise write @onNoWrap@.
 179         ifWrap :: d -> d -> d
 180         -- | @('breakpoint' onNoBreak onBreak d)@
 181         -- write @onNoBreak@ then @d@ if they fit,
 182         -- @onBreak@ otherwise.
 183         breakpoint :: d -> d -> d -> d
 184         -- | @('breakableEmpty' d)@ write @d@ if it fits, 'newline' then @d@ otherwise.
 185         breakableEmpty :: d -> d
 186         breakableEmpty = breakpoint empty newline
 187         -- | @x '><' y = x '<>' 'breakableEmpty' y@
 188         (><) :: d -> d -> d
 189         x >< y = x <> breakableEmpty y
 190         -- | @('breakableSpace' d)@ write 'space' then @d@ it they fit,
 191         -- 'newline' then @d@ otherwise.
 192         breakableSpace :: d -> d
 193         breakableSpace = breakpoint space newline
 194         -- | @x '>+<' y = x '<>' 'breakableSpace' y@
 195         (>+<) :: d -> d -> d
 196         x >+< y = x <> breakableSpace y
 197         -- | @'breakableSpaces' ds@ intercalate a 'breakableSpace'
 198         -- between items of @ds@.
 199         breakableSpaces :: Foldable f => f d -> d
 200         breakableSpaces = foldWith breakableSpace
 201         -- | @'withWrapColumn' col d@ set the 'Column' triggering wrapping to @col@ within @d@.
 202         withWrapColumn :: Column -> d -> d
 203         -- | @('intercalateHorV' sep ds)@
 204         -- write @ds@ with @sep@ intercalated if the whole fits,
 205         -- otherwise write 'align' of @ds@ with 'newline' and @sep@ intercalated.
 206         intercalateHorV :: Foldable f => d -> f d -> d
 207         intercalateHorV sep xs =
 208                 ifWrap
 209                  (align $ foldWith ((newline <> sep) <>) xs)
 210                  (foldWith (sep <>) xs)
 211
 212 -- * Class 'Colorable'
 213 class Colorable d where
 214         -- | @('colorable' f)@ write @f@ applied to whether colors are activated or not.
 215         colorable :: (Bool -> d) -> d
 216         -- | @('withColor' b d)@ whether to active colors or not within @d@.
 217         withColorable :: Bool -> d -> d
 218
 219         reverse :: d -> d
 220
 221         -- Foreground colors
 222         -- Dull
 223         black   :: d -> d
 224         red     :: d -> d
 225         green   :: d -> d
 226         yellow  :: d -> d
 227         blue    :: d -> d
 228         magenta :: d -> d
 229         cyan    :: d -> d
 230         white   :: d -> d
 231
 232         -- Vivid
 233         blacker   :: d -> d
 234         redder    :: d -> d
 235         greener   :: d -> d
 236         yellower  :: d -> d
 237         bluer     :: d -> d
 238         magentaer :: d -> d
 239         cyaner    :: d -> d
 240         whiter    :: d -> d
 241
 242         -- Background colors
 243         -- Dull
 244         onBlack   :: d -> d
 245         onRed     :: d -> d
 246         onGreen   :: d -> d
 247         onYellow  :: d -> d
 248         onBlue    :: d -> d
 249         onMagenta :: d -> d
 250         onCyan    :: d -> d
 251         onWhite   :: d -> d
 252
 253         -- Vivid
 254         onBlacker   :: d -> d
 255         onRedder    :: d -> d
 256         onGreener   :: d -> d
 257         onYellower  :: d -> d
 258         onBluer     :: d -> d
 259         onMagentaer :: d -> d
 260         onCyaner    :: d -> d
 261         onWhiter    :: d -> d
 262
 263         default reverse     :: Colorable (ReprOf d) => Trans d => d -> d
 264         default black       :: Colorable (ReprOf d) => Trans d => d -> d
 265         default red         :: Colorable (ReprOf d) => Trans d => d -> d
 266         default green       :: Colorable (ReprOf d) => Trans d => d -> d
 267         default yellow      :: Colorable (ReprOf d) => Trans d => d -> d
 268         default blue        :: Colorable (ReprOf d) => Trans d => d -> d
 269         default magenta     :: Colorable (ReprOf d) => Trans d => d -> d
 270         default cyan        :: Colorable (ReprOf d) => Trans d => d -> d
 271         default white       :: Colorable (ReprOf d) => Trans d => d -> d
 272         default blacker     :: Colorable (ReprOf d) => Trans d => d -> d
 273         default redder      :: Colorable (ReprOf d) => Trans d => d -> d
 274         default greener     :: Colorable (ReprOf d) => Trans d => d -> d
 275         default yellower    :: Colorable (ReprOf d) => Trans d => d -> d
 276         default bluer       :: Colorable (ReprOf d) => Trans d => d -> d
 277         default magentaer   :: Colorable (ReprOf d) => Trans d => d -> d
 278         default cyaner      :: Colorable (ReprOf d) => Trans d => d -> d
 279         default whiter      :: Colorable (ReprOf d) => Trans d => d -> d
 280         default onBlack     :: Colorable (ReprOf d) => Trans d => d -> d
 281         default onRed       :: Colorable (ReprOf d) => Trans d => d -> d
 282         default onGreen     :: Colorable (ReprOf d) => Trans d => d -> d
 283         default onYellow    :: Colorable (ReprOf d) => Trans d => d -> d
 284         default onBlue      :: Colorable (ReprOf d) => Trans d => d -> d
 285         default onMagenta   :: Colorable (ReprOf d) => Trans d => d -> d
 286         default onCyan      :: Colorable (ReprOf d) => Trans d => d -> d
 287         default onWhite     :: Colorable (ReprOf d) => Trans d => d -> d
 288         default onBlacker   :: Colorable (ReprOf d) => Trans d => d -> d
 289         default onRedder    :: Colorable (ReprOf d) => Trans d => d -> d
 290         default onGreener   :: Colorable (ReprOf d) => Trans d => d -> d
 291         default onYellower  :: Colorable (ReprOf d) => Trans d => d -> d
 292         default onBluer     :: Colorable (ReprOf d) => Trans d => d -> d
 293         default onMagentaer :: Colorable (ReprOf d) => Trans d => d -> d
 294         default onCyaner    :: Colorable (ReprOf d) => Trans d => d -> d
 295         default onWhiter    :: Colorable (ReprOf d) => Trans d => d -> d
 296
 297         reverse     = trans1 reverse
 298         black       = trans1 black
 299         red         = trans1 red
 300         green       = trans1 green
 301         yellow      = trans1 yellow
 302         blue        = trans1 blue
 303         magenta     = trans1 magenta
 304         cyan        = trans1 cyan
 305         white       = trans1 white
 306         blacker     = trans1 blacker
 307         redder      = trans1 redder
 308         greener     = trans1 greener
 309         yellower    = trans1 yellower
 310         bluer       = trans1 bluer
 311         magentaer   = trans1 magentaer
 312         cyaner      = trans1 cyaner
 313         whiter      = trans1 whiter
 314         onBlack     = trans1 onBlack
 315         onRed       = trans1 onRed
 316         onGreen     = trans1 onGreen
 317         onYellow    = trans1 onYellow
 318         onBlue      = trans1 onBlue
 319         onMagenta   = trans1 onMagenta
 320         onCyan      = trans1 onCyan
 321         onWhite     = trans1 onWhite
 322         onBlacker   = trans1 onBlacker
 323         onRedder    = trans1 onRedder
 324         onGreener   = trans1 onGreener
 325         onYellower  = trans1 onYellower
 326         onBluer     = trans1 onBluer
 327         onMagentaer = trans1 onMagentaer
 328         onCyaner    = trans1 onCyaner
 329         onWhiter    = trans1 onWhiter
 330
 331 -- * Class 'Decorable'
 332 class Decorable d where
 333         -- | @('decorable' f)@ write @f@ applied to whether decorations are activated or not.
 334         decorable :: (Bool -> d) -> d
 335         -- | @('withColor' b d)@ whether to active decorations or not within @d@.
 336         withDecorable :: Bool -> d -> d
 337
 338         bold      :: d -> d
 339         underline :: d -> d
 340         italic    :: d -> d
 341         default bold      :: Decorable (ReprOf d) => Trans d => d -> d
 342         default underline :: Decorable (ReprOf d) => Trans d => d -> d
 343         default italic    :: Decorable (ReprOf d) => Trans d => d -> d
 344         bold      = trans1 bold
 345         underline = trans1 underline
 346         italic    = trans1 italic
 347
 348 -- * Class 'Trans'
 349 class Trans tr where
 350         -- | Return the underlying @tr@ of the transformer.
 351         type ReprOf tr :: *
 352
 353         -- | Lift a tr to the transformer's.
 354         trans :: ReprOf tr -> tr
 355         -- | Unlift a tr from the transformer's.
 356         unTrans :: tr -> ReprOf tr
 357
 358         -- | Identity transformation for a unary symantic method.
 359         trans1 :: (ReprOf tr -> ReprOf tr) -> (tr -> tr)
 360         trans1 f = trans . f . unTrans
 361
 362         -- | Identity transformation for a binary symantic method.
 363         trans2
 364          :: (ReprOf tr -> ReprOf tr -> ReprOf tr)
 365          -> (tr -> tr -> tr)
 366         trans2 f t1 t2 = trans (f (unTrans t1) (unTrans t2))
 367
 368         -- | Identity transformation for a ternary symantic method.
 369         trans3
 370          :: (ReprOf tr -> ReprOf tr -> ReprOf tr -> ReprOf tr)
 371          -> (tr -> tr -> tr -> tr)
 372         trans3 f t1 t2 t3 = trans (f (unTrans t1) (unTrans t2) (unTrans t3))
 373
 374 -- | Break a 'String' into lines while preserving all empty lines.
 375 lines :: String -> [String]
 376 lines cs =
 377         case List.break (== '\n') cs of
 378          (chunk, _:rest) -> chunk : lines rest
 379          (chunk, []) -> [chunk]