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 Data.Text (Text)
  14 import Prelude (Integer, toInteger, fromIntegral, Num(..))
  15 import qualified Data.List as List
  16 import qualified Data.Text as Text
  17 import qualified Data.Text.Lazy as TL
  18
  19 -- * Type family 'Column'
  20 type family Column (d:: *) :: *
  21
  22 -- * Type family 'Indent'
  23 type family Indent (d:: *) :: *
  24
  25 -- * Class 'Doc_Text'
  26 class (IsString d, Semigroup d) => Doc_Text d where
  27         charH     :: Char -- ^ XXX: MUST NOT be '\n'
  28                   -> d
  29         stringH   :: String -- ^ XXX: MUST NOT contain '\n'
  30                   -> d
  31         textH     :: Text -- ^ XXX: MUST NOT contain '\n'
  32                   -> d
  33         ltextH    :: TL.Text -- ^ XXX: MUST NOT contain '\n'
  34                   -> d
  35         replicate :: Int -> d -> d
  36         integer   :: Integer -> d
  37         default replicate :: Doc_Text (ReprOf d) => Trans d => Int -> d -> d
  38         default integer   :: Doc_Text (ReprOf d) => Trans d => Integer -> d
  39         default charH     :: Doc_Text (ReprOf d) => Trans d => Char -> d
  40         default stringH   :: Doc_Text (ReprOf d) => Trans d => String -> d
  41         default textH     :: Doc_Text (ReprOf d) => Trans d => Text -> d
  42         default ltextH    :: Doc_Text (ReprOf d) => Trans d => TL.Text -> d
  43         charH     = trans . charH
  44         stringH   = trans . stringH
  45         textH     = trans . textH
  46         ltextH    = trans . ltextH
  47         replicate = trans1 . replicate
  48         integer   = trans . integer
  49
  50         empty       :: d
  51         newline     :: d
  52         space       :: d
  53         -- | @x '<+>' y = x '<>' 'space' '<>' y@
  54         (<+>)       :: d -> d -> d
  55         -- | @x '</>' y = x '<>' 'newline' '<>' y@
  56         (</>)       :: d -> d -> d
  57         int         :: Int -> d
  58         char        :: Char    -> d
  59         string      :: String  -> d
  60         text        :: Text    -> d
  61         ltext       :: TL.Text -> d
  62         catH        :: Foldable f => f d -> d
  63         catV        :: Foldable f => f d -> d
  64         foldrWith   :: Foldable f => (d -> d -> d) -> f d -> d
  65         foldWith    :: Foldable f => (d -> d) -> f d -> d
  66         intercalate :: Foldable f => d -> f d -> d
  67         between     :: d -> d -> d -> d
  68
  69         newline  = "\n"
  70         space    = char ' '
  71         x <+> y  = x <> space <> y
  72         x </> y  = x <> newline <> y
  73         int      = integer . toInteger
  74         char     = \case '\n' -> newline; c -> charH c
  75         string   = catV . fmap stringH . lines
  76         text     = catV . fmap textH   . Text.lines
  77         ltext    = catV . fmap ltextH  . TL.lines
  78         catH     = foldr (<>) empty
  79         catV     = foldrWith (\x y -> x<>newline<>y)
  80         foldrWith f ds  = if null ds then empty else foldr1 f ds
  81         foldWith  f     = foldrWith $ \a acc -> a <> f acc
  82         intercalate sep = foldrWith (\x y -> x<>sep<>y)
  83         between o c d = o<>d<>c
  84         -- default catH :: Doc_Text (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
  85         -- default catV :: Doc_Text (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
  86         -- catH  l = trans (catH (fmap unTrans l))
  87         -- catV  l = trans (catV (fmap unTrans l))
  88
  89 -- * Class 'Doc_Align'
  90 class Doc_Text d => Doc_Align d where
  91         -- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
  92         align :: d -> d
  93         -- | @('hang' ind d)@ make @d@ uses current 'Column' plus @ind@ as 'Indent' level.
  94         hang :: Indent d -> d -> d
  95         hang ind = align . incrIndent ind
  96         -- | @('incrIndent' ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
  97         incrIndent  :: Indent d -> d -> d
  98         -- | @('withIndent' ind d)@ make @d@ uses @ind@ as 'Indent' level.
  99         withIndent  :: Indent d -> d -> d
 100         -- | @('withNewline' nl d)@ make @d@ uses @nl@ as 'newline'.
 101         --
 102         -- Useful values for @nl@ are: 'empty', 'newlineWithIndent', 'newlineWithoutIndent'.
 103         withNewline :: d -> d -> d
 104         newlineWithoutIndent :: d
 105         newlineWithIndent    :: d
 106         -- | @('column' f)@ returns @f@ applied to the current 'Column'.
 107         column :: (Column d -> d) -> d
 108         -- | @('endToEndWidth' d f)@ returns @d@ concatenated to
 109         -- @f@ applied to the difference between the end 'Column' and start 'Column' of @d@.
 110         --
 111         -- Note that @f@ is given the end-to-end width,
 112         -- which is not necessarily the maximal width.
 113         default endToEndWidth ::
 114          Semigroup d =>
 115          Num (Column d) =>
 116          d -> (Column d -> d) -> d
 117         endToEndWidth :: d -> (Column d -> d) -> d
 118         endToEndWidth d f = column $ \c1 -> (d <>) $ column $ \c2 -> f $ c2 - c1
 119
 120         -- | @'spaces' ind = 'replicate' ind 'space'@
 121         default spaces :: Indent d ~ Int => Indent d -> d
 122         spaces :: Indent d -> d
 123         spaces i = replicate i space
 124
 125         -- | @('fill' ind d)@ returns @d@ then as many 'space's as needed
 126         -- so that the whole is @ind@ 'Column's wide.
 127         default fill ::
 128          Indent d ~ Int =>
 129          Column d ~ Int =>
 130          Indent d -> d -> d
 131         fill :: Indent d -> d -> d
 132         fill m d =
 133                 endToEndWidth d $ \w ->
 134                         case w`compare`m of
 135                          LT -> spaces $ m - w
 136                          _  -> empty
 137
 138         -- | @('breakableFill' ind f d)@ returns @f@ then as many 'space's as needed
 139         -- so that the whole is @ind@ 'Column's wide,
 140         -- then, if @f@ is not wider than @ind@, appends @d@,
 141         -- otherwise appends a 'newline' and @d@,
 142         -- with an 'Indent' level set to the start 'Column' of @f@ plus @ind@.
 143         default breakableFill ::
 144          Indent d ~ Int =>
 145          Column d ~ Int =>
 146          Indent d -> d -> d -> d
 147         breakableFill :: Indent d -> d -> d -> d
 148         breakableFill m f d =
 149                 column $ \c ->
 150                 endToEndWidth f $ \w ->
 151                         case w`compare`m of
 152                          LT -> spaces (m - w) <> d
 153                          EQ -> d
 154                          GT -> withIndent (c + m) (newline <> d)
 155
 156 -- * Class 'Doc_Wrap'
 157 class (Doc_Text d, Doc_Align d) => Doc_Wrap d where
 158         -- | @('ifFit' onFit onNoFit)@
 159         -- return @onFit@ if @onFit@ leads to a 'Column'
 160         -- lower or equal to the one sets with 'withWrapColumn',
 161         -- otherwise return @onNoFit@.
 162         ifFit :: d -> d -> d
 163         -- | @('breakpoint' onNoBreak onBreak d)@
 164         -- return @onNoBreak@ then @d@ if they fit,
 165         -- @onBreak@ otherwise.
 166         breakpoint :: d -> d -> d -> d
 167         -- | @('breakableEmpty' d)@ returns @d@ if it fits, 'newline' then @d@ otherwise.
 168         breakableEmpty :: d -> d
 169         breakableEmpty = breakpoint empty newline
 170         -- | @x '><' y = x '<>' 'breakableEmpty' y@
 171         (><) :: d -> d -> d
 172         x >< y = x <> breakableEmpty y
 173         -- | @('breakableSpace' d)@ returns 'space' then @d@ it they fit,
 174         -- 'newline' then @d@ otherwise.
 175         breakableSpace :: d -> d
 176         breakableSpace = breakpoint space newline
 177         -- | @x '>+<' y = x '<>' 'breakableSpace' y@
 178         (>+<) :: d -> d -> d
 179         x >+< y = x <> breakableSpace y
 180         -- | @'breakableSpaces' ds@ intercalate a 'breakableSpace'
 181         -- between items of @ds@.
 182         breakableSpaces :: Foldable f => f d -> d
 183         breakableSpaces = foldWith breakableSpace
 184         -- | @'withWrapColumn' col d@ set the 'Column' triggering wrapping to @col@ within @d@.
 185         withWrapColumn :: Column d -> d -> d
 186         -- | @('intercalateHorV' sep ds)@
 187         -- return @ds@ with @sep@ intercalated if the whole fits,
 188         -- otherwise return 'align' of @ds@ with 'newline' and @sep@ intercalated.
 189         intercalateHorV :: Foldable f => d -> f d -> d
 190         intercalateHorV sep xs =
 191                 ifFit (foldWith (sep <>) xs)
 192                  (align $ foldWith ((newline <> sep) <>) xs)
 193
 194 -- * Class 'Doc_Color'
 195 class Doc_Color d where
 196         -- | @('colorable' f)@ returns @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     :: Doc_Color (ReprOf d) => Trans d => d -> d
 246         default black       :: Doc_Color (ReprOf d) => Trans d => d -> d
 247         default red         :: Doc_Color (ReprOf d) => Trans d => d -> d
 248         default green       :: Doc_Color (ReprOf d) => Trans d => d -> d
 249         default yellow      :: Doc_Color (ReprOf d) => Trans d => d -> d
 250         default blue        :: Doc_Color (ReprOf d) => Trans d => d -> d
 251         default magenta     :: Doc_Color (ReprOf d) => Trans d => d -> d
 252         default cyan        :: Doc_Color (ReprOf d) => Trans d => d -> d
 253         default white       :: Doc_Color (ReprOf d) => Trans d => d -> d
 254         default blacker     :: Doc_Color (ReprOf d) => Trans d => d -> d
 255         default redder      :: Doc_Color (ReprOf d) => Trans d => d -> d
 256         default greener     :: Doc_Color (ReprOf d) => Trans d => d -> d
 257         default yellower    :: Doc_Color (ReprOf d) => Trans d => d -> d
 258         default bluer       :: Doc_Color (ReprOf d) => Trans d => d -> d
 259         default magentaer   :: Doc_Color (ReprOf d) => Trans d => d -> d
 260         default cyaner      :: Doc_Color (ReprOf d) => Trans d => d -> d
 261         default whiter      :: Doc_Color (ReprOf d) => Trans d => d -> d
 262         default onBlack     :: Doc_Color (ReprOf d) => Trans d => d -> d
 263         default onRed       :: Doc_Color (ReprOf d) => Trans d => d -> d
 264         default onGreen     :: Doc_Color (ReprOf d) => Trans d => d -> d
 265         default onYellow    :: Doc_Color (ReprOf d) => Trans d => d -> d
 266         default onBlue      :: Doc_Color (ReprOf d) => Trans d => d -> d
 267         default onMagenta   :: Doc_Color (ReprOf d) => Trans d => d -> d
 268         default onCyan      :: Doc_Color (ReprOf d) => Trans d => d -> d
 269         default onWhite     :: Doc_Color (ReprOf d) => Trans d => d -> d
 270         default onBlacker   :: Doc_Color (ReprOf d) => Trans d => d -> d
 271         default onRedder    :: Doc_Color (ReprOf d) => Trans d => d -> d
 272         default onGreener   :: Doc_Color (ReprOf d) => Trans d => d -> d
 273         default onYellower  :: Doc_Color (ReprOf d) => Trans d => d -> d
 274         default onBluer     :: Doc_Color (ReprOf d) => Trans d => d -> d
 275         default onMagentaer :: Doc_Color (ReprOf d) => Trans d => d -> d
 276         default onCyaner    :: Doc_Color (ReprOf d) => Trans d => d -> d
 277         default onWhiter    :: Doc_Color (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 'Doc_Decoration'
 314 class Doc_Decoration d where
 315         -- | @('decorable' f)@ returns @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      :: Doc_Decoration (ReprOf d) => Trans d => d -> d
 324         default underline :: Doc_Decoration (ReprOf d) => Trans d => d -> d
 325         default italic    :: Doc_Decoration (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]