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