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

   1 module Language.Symantic.Document.Sym where
   2
   3 import Data.Char (Char)
   4 import Data.Eq (Eq(..))
   5 import Data.Foldable (Foldable(..))
   6 import Data.Function ((.), ($))
   7 import Data.Functor (Functor(..))
   8 import Data.Int (Int, Int64)
   9 import Data.Ord (Ord(..), Ordering(..))
  10 import Data.Semigroup (Semigroup(..))
  11 import Data.String (String, IsString)
  12 import Data.Text (Text)
  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 'Doc_Text'
  25 class (IsString d, Semigroup d) => Doc_Text 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 -- ^ 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 :: Doc_Text (ReprOf d) => Trans d => Int -> d -> d
  37         default integer   :: Doc_Text (ReprOf d) => Trans d => Integer -> d
  38         default charH     :: Doc_Text (ReprOf d) => Trans d => Char -> d
  39         default stringH   :: Doc_Text (ReprOf d) => Trans d => String -> d
  40         default textH     :: Doc_Text (ReprOf d) => Trans d => Text -> d
  41         default ltextH    :: Doc_Text (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    -> 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 :: Doc_Text (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
  84         -- default catV :: Doc_Text (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 'Doc_Align'
  89 class Doc_Text d => Doc_Align 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)@ returns @f@ applied to the current 'Column'.
 106         column :: (Column d -> d) -> d
 107         -- | @('endToEndWidth' d f)@ returns @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)@ returns @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)@ returns @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 'Doc_Wrap'
 156 class (Doc_Text d, Doc_Align d) => Doc_Wrap d where
 157         -- | @('ifFit' onFit onNoFit)@
 158         -- return @onFit@ if @onFit@ leads to a 'Column'
 159         -- lower or equal to the one sets with 'withWrapColumn',
 160         -- otherwise return @onNoFit@.
 161         ifFit :: 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)@ returns @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)@ returns '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                 ifFit (foldWith (sep <>) xs)
 191                  (align $ foldWith ((newline <> sep) <>) xs)
 192
 193 -- * Class 'Doc_Color'
 194 class Doc_Color d where
 195         reverse :: d -> d
 196
 197         -- Foreground colors
 198         -- Dull
 199         black   :: d -> d
 200         red     :: d -> d
 201         green   :: d -> d
 202         yellow  :: d -> d
 203         blue    :: d -> d
 204         magenta :: d -> d
 205         cyan    :: d -> d
 206         white   :: d -> d
 207
 208         -- Vivid
 209         blacker   :: d -> d
 210         redder    :: d -> d
 211         greener   :: d -> d
 212         yellower  :: d -> d
 213         bluer     :: d -> d
 214         magentaer :: d -> d
 215         cyaner    :: d -> d
 216         whiter    :: d -> d
 217
 218         -- Background colors
 219         -- Dull
 220         onBlack   :: d -> d
 221         onRed     :: d -> d
 222         onGreen   :: d -> d
 223         onYellow  :: d -> d
 224         onBlue    :: d -> d
 225         onMagenta :: d -> d
 226         onCyan    :: d -> d
 227         onWhite   :: d -> d
 228
 229         -- Vivid
 230         onBlacker   :: d -> d
 231         onRedder    :: d -> d
 232         onGreener   :: d -> d
 233         onYellower  :: d -> d
 234         onBluer     :: d -> d
 235         onMagentaer :: d -> d
 236         onCyaner    :: d -> d
 237         onWhiter    :: d -> d
 238
 239         default reverse     :: Doc_Color (ReprOf d) => Trans d => d -> d
 240         default black       :: Doc_Color (ReprOf d) => Trans d => d -> d
 241         default red         :: Doc_Color (ReprOf d) => Trans d => d -> d
 242         default green       :: Doc_Color (ReprOf d) => Trans d => d -> d
 243         default yellow      :: Doc_Color (ReprOf d) => Trans d => d -> d
 244         default blue        :: Doc_Color (ReprOf d) => Trans d => d -> d
 245         default magenta     :: Doc_Color (ReprOf d) => Trans d => d -> d
 246         default cyan        :: Doc_Color (ReprOf d) => Trans d => d -> d
 247         default white       :: Doc_Color (ReprOf d) => Trans d => d -> d
 248         default blacker     :: Doc_Color (ReprOf d) => Trans d => d -> d
 249         default redder      :: Doc_Color (ReprOf d) => Trans d => d -> d
 250         default greener     :: Doc_Color (ReprOf d) => Trans d => d -> d
 251         default yellower    :: Doc_Color (ReprOf d) => Trans d => d -> d
 252         default bluer       :: Doc_Color (ReprOf d) => Trans d => d -> d
 253         default magentaer   :: Doc_Color (ReprOf d) => Trans d => d -> d
 254         default cyaner      :: Doc_Color (ReprOf d) => Trans d => d -> d
 255         default whiter      :: Doc_Color (ReprOf d) => Trans d => d -> d
 256         default onBlack     :: Doc_Color (ReprOf d) => Trans d => d -> d
 257         default onRed       :: Doc_Color (ReprOf d) => Trans d => d -> d
 258         default onGreen     :: Doc_Color (ReprOf d) => Trans d => d -> d
 259         default onYellow    :: Doc_Color (ReprOf d) => Trans d => d -> d
 260         default onBlue      :: Doc_Color (ReprOf d) => Trans d => d -> d
 261         default onMagenta   :: Doc_Color (ReprOf d) => Trans d => d -> d
 262         default onCyan      :: Doc_Color (ReprOf d) => Trans d => d -> d
 263         default onWhite     :: Doc_Color (ReprOf d) => Trans d => d -> d
 264         default onBlacker   :: Doc_Color (ReprOf d) => Trans d => d -> d
 265         default onRedder    :: Doc_Color (ReprOf d) => Trans d => d -> d
 266         default onGreener   :: Doc_Color (ReprOf d) => Trans d => d -> d
 267         default onYellower  :: Doc_Color (ReprOf d) => Trans d => d -> d
 268         default onBluer     :: Doc_Color (ReprOf d) => Trans d => d -> d
 269         default onMagentaer :: Doc_Color (ReprOf d) => Trans d => d -> d
 270         default onCyaner    :: Doc_Color (ReprOf d) => Trans d => d -> d
 271         default onWhiter    :: Doc_Color (ReprOf d) => Trans d => d -> d
 272
 273         reverse     = trans1 reverse
 274         black       = trans1 black
 275         red         = trans1 red
 276         green       = trans1 green
 277         yellow      = trans1 yellow
 278         blue        = trans1 blue
 279         magenta     = trans1 magenta
 280         cyan        = trans1 cyan
 281         white       = trans1 white
 282         blacker     = trans1 blacker
 283         redder      = trans1 redder
 284         greener     = trans1 greener
 285         yellower    = trans1 yellower
 286         bluer       = trans1 bluer
 287         magentaer   = trans1 magentaer
 288         cyaner      = trans1 cyaner
 289         whiter      = trans1 whiter
 290         onBlack     = trans1 onBlack
 291         onRed       = trans1 onRed
 292         onGreen     = trans1 onGreen
 293         onYellow    = trans1 onYellow
 294         onBlue      = trans1 onBlue
 295         onMagenta   = trans1 onMagenta
 296         onCyan      = trans1 onCyan
 297         onWhite     = trans1 onWhite
 298         onBlacker   = trans1 onBlacker
 299         onRedder    = trans1 onRedder
 300         onGreener   = trans1 onGreener
 301         onYellower  = trans1 onYellower
 302         onBluer     = trans1 onBluer
 303         onMagentaer = trans1 onMagentaer
 304         onCyaner    = trans1 onCyaner
 305         onWhiter    = trans1 onWhiter
 306
 307 -- * Class 'Doc_Decoration'
 308 class Doc_Decoration d where
 309         bold      :: d -> d
 310         underline :: d -> d
 311         italic    :: d -> d
 312         default bold      :: Doc_Decoration (ReprOf d) => Trans d => d -> d
 313         default underline :: Doc_Decoration (ReprOf d) => Trans d => d -> d
 314         default italic    :: Doc_Decoration (ReprOf d) => Trans d => d -> d
 315         bold      = trans1 bold
 316         underline = trans1 underline
 317         italic    = trans1 italic
 318
 319 -- * Class 'Trans'
 320 class Trans tr where
 321         -- | Return the underlying @tr@ of the transformer.
 322         type ReprOf tr :: *
 323
 324         -- | Lift a tr to the transformer's.
 325         trans :: ReprOf tr -> tr
 326         -- | Unlift a tr from the transformer's.
 327         unTrans :: tr -> ReprOf tr
 328
 329         -- | Identity transformation for a unary symantic method.
 330         trans1 :: (ReprOf tr -> ReprOf tr) -> (tr -> tr)
 331         trans1 f = trans . f . unTrans
 332
 333         -- | Identity transformation for a binary symantic method.
 334         trans2
 335          :: (ReprOf tr -> ReprOf tr -> ReprOf tr)
 336          -> (tr -> tr -> tr)
 337         trans2 f t1 t2 = trans (f (unTrans t1) (unTrans t2))
 338
 339         -- | Identity transformation for a ternary symantic method.
 340         trans3
 341          :: (ReprOf tr -> ReprOf tr -> ReprOf tr -> ReprOf tr)
 342          -> (tr -> tr -> tr -> tr)
 343         trans3 f t1 t2 t3 = trans (f (unTrans t1) (unTrans t2) (unTrans t3))
 344
 345 int64OfInt :: Int -> Int64
 346 int64OfInt = fromIntegral
 347
 348 intOfInt64 :: Int64 -> Int
 349 intOfInt64 = fromIntegral
 350
 351 -- | Break a 'String' into lines while preserving all empty lines.
 352 lines :: String -> [String]
 353 lines cs =
 354         case List.break (== '\n') cs of
 355          (chunk, _:rest) -> chunk : lines rest
 356          (chunk, []) -> [chunk]