{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Symantic.Document.API where
import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Foldable (Foldable, foldr, foldr1, null)
import Data.Function ((.), ($), id, const)
import Data.Functor (Functor(..), (<$>))
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import Numeric.Natural (Natural)
import Prelude (Integer, fromIntegral, pred)
import System.Console.ANSI (SGR, setSGRCode)
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
type Column = Natural
type Indent = Column
type Width = Natural
newtype Line d = Line d
deriving (Eq,Show)
unLine :: Line d -> d
unLine (Line d) = d
newtype Word d = Word d
deriving (Eq,Show,Semigroup)
unWord :: Word d -> d
unWord (Word d) = d
instance DocFrom [SGR] d => DocFrom [SGR] (Word d) where
docFrom = Word . docFrom
class DocFrom a d where
docFrom :: a -> d
default docFrom :: DocFrom String d => Show a => a -> d
docFrom = docFrom . show
instance DocFrom (Line String) d => DocFrom Int d where
docFrom = docFrom . Line . show
instance DocFrom (Line String) d => DocFrom Integer d where
docFrom = docFrom . Line . show
instance DocFrom (Line String) d => DocFrom Natural d where
docFrom = docFrom . Line . show
instance DocFrom Char String where
docFrom = pure
instance DocFrom String String where
docFrom = id
instance DocFrom Text String where
docFrom = Text.unpack
instance DocFrom TL.Text String where
docFrom = TL.unpack
instance DocFrom d String => DocFrom (Line d) String where
docFrom = docFrom . unLine
instance DocFrom d String => DocFrom (Word d) String where
docFrom = docFrom . unWord
instance DocFrom [SGR] String where
docFrom = setSGRCode
instance DocFrom Char Text where
docFrom = Text.singleton
instance DocFrom String Text where
docFrom = Text.pack
instance DocFrom Text Text where
docFrom = id
instance DocFrom TL.Text Text where
docFrom = TL.toStrict
instance DocFrom d Text => DocFrom (Line d) Text where
docFrom = docFrom . unLine
instance DocFrom d Text => DocFrom (Word d) Text where
docFrom = docFrom . unWord
instance DocFrom [SGR] Text where
docFrom = docFrom . setSGRCode
instance DocFrom Char TLB.Builder where
docFrom = TLB.singleton
instance DocFrom String TLB.Builder where
docFrom = fromString
instance DocFrom Text TLB.Builder where
docFrom = TLB.fromText
instance DocFrom TL.Text TLB.Builder where
docFrom = TLB.fromLazyText
instance DocFrom TLB.Builder TLB.Builder where
docFrom = id
instance DocFrom d TLB.Builder => DocFrom (Line d) TLB.Builder where
docFrom = docFrom . unLine
instance DocFrom d TLB.Builder => DocFrom (Word d) TLB.Builder where
docFrom = docFrom . unWord
instance DocFrom [SGR] TLB.Builder where
docFrom = docFrom . setSGRCode
runTextBuilder :: TLB.Builder -> TL.Text
runTextBuilder = TLB.toLazyText
class Lengthable d where
length :: d -> Column
nullLength :: d -> Bool
nullLength d = length d == 0
instance Lengthable Char where
length _ = 1
nullLength = const False
instance Lengthable String where
length = fromIntegral . List.length
nullLength = null
instance Lengthable Text.Text where
length = fromIntegral . Text.length
nullLength = Text.null
instance Lengthable TL.Text where
length = fromIntegral . TL.length
nullLength = TL.null
instance Lengthable d => Lengthable (Line d) where
length = fromIntegral . length . unLine
nullLength = nullLength . unLine
instance Lengthable d => Lengthable (Word d) where
length = fromIntegral . length . unWord
nullLength = nullLength . unWord
class Monoid d => Spaceable d where
newline :: d
space :: d
default newline :: Spaceable (UnTrans d) => Trans d => d
default space :: Spaceable (UnTrans d) => Trans d => d
newline = noTrans newline
space = noTrans space
spaces :: Column -> d
default spaces :: Monoid d => Column -> d
spaces i = replicate (fromIntegral i) space
unlines :: Foldable f => f (Line d) -> d
unlines = foldr (\(Line x) acc -> x<>newline<>acc) mempty
unwords :: Foldable f => Functor f => f (Word d) -> d
unwords = intercalate space . (unWord <$>)
catLines :: Foldable f => Functor f => f (Line d) -> d
catLines = intercalate newline . (unLine <$>)
(<+>) :: d -> d -> d
(</>) :: d -> d -> d
x <+> y = x <> space <> y
x </> y = x <> newline <> y
catH :: Foldable f => f d -> d
catV :: Foldable f => f d -> d
catH = foldr (<>) mempty
catV = intercalate newline
infixr 6 <+>
infixr 6 </>
instance Spaceable String where
newline = "\n"
space = " "
spaces n = List.replicate (fromIntegral n) ' '
instance Spaceable Text where
newline = "\n"
space = " "
spaces n = Text.replicate (fromIntegral n) " "
instance Spaceable TLB.Builder where
newline = TLB.singleton '\n'
space = TLB.singleton ' '
spaces = TLB.fromText . spaces
intercalate :: (Foldable f, Monoid d) => d -> f d -> d
intercalate sep ds = if null ds then mempty else foldr1 (\x y -> x<>sep<>y) ds
replicate :: Monoid d => Int -> d -> d
replicate cnt t | cnt <= 0 = mempty
| otherwise = t `mappend` replicate (pred cnt) t
between :: Semigroup d => d -> d -> d -> d
between o c d = o<>d<>c
parens :: Semigroup d => DocFrom (Word Char) d => d -> d
parens = between (docFrom (Word '(')) (docFrom (Word ')'))
braces :: Semigroup d => DocFrom (Word Char) d => d -> d
braces = between (docFrom (Word '{')) (docFrom (Word '}'))
brackets :: Semigroup d => DocFrom (Word Char) d => d -> d
brackets = between (docFrom (Word '[')) (docFrom (Word ']'))
angles :: Semigroup d => DocFrom (Word Char) d => d -> d
angles = between (docFrom (Word '<')) (docFrom (Word '>'))
class (Lengthable d, Monoid d) => Splitable d where
tail :: d -> Maybe d
break :: (Char -> Bool) -> d -> (d, d)
span :: (Char -> Bool) -> d -> (d, d)
span f = break (not . f)
lines :: d -> [Line d]
words :: d -> [Word d]
linesNoEmpty :: d -> [Line d]
wordsNoEmpty :: d -> [Word d]
lines = (Line <$>) . splitOnChar (== '\n')
words = (Word <$>) . splitOnChar (== ' ')
linesNoEmpty = (Line <$>) . splitOnCharNoEmpty (== '\n')
wordsNoEmpty = (Word <$>) . splitOnCharNoEmpty (== ' ')
splitOnChar :: (Char -> Bool) -> d -> [d]
splitOnChar f d0 =
if nullLength d0 then [] else go d0
where
go d =
let (l,r) = f`break`d in
l : case tail r of
Nothing -> []
Just rt | nullLength rt -> [mempty]
| otherwise -> go rt
splitOnCharNoEmpty :: (Char -> Bool) -> d -> [d]
splitOnCharNoEmpty f d =
let (l,r) = f`break`d in
(if nullLength l then [] else [l]) <>
case tail r of
Nothing -> []
Just rt -> splitOnCharNoEmpty f rt
instance Splitable String where
tail [] = Nothing
tail s = Just $ List.tail s
break = List.break
instance Splitable Text.Text where
tail "" = Nothing
tail s = Just $ Text.tail s
break = Text.break
instance Splitable TL.Text where
tail "" = Nothing
tail s = Just $ TL.tail s
break = TL.break
class Decorable d where
bold :: d -> d
underline :: d -> d
italic :: d -> d
default bold :: Decorable (UnTrans d) => Trans d => d -> d
default underline :: Decorable (UnTrans d) => Trans d => d -> d
default italic :: Decorable (UnTrans d) => Trans d => d -> d
bold = noTrans1 bold
underline = noTrans1 underline
italic = noTrans1 italic
class Colorable16 d where
reverse :: d -> d
black :: d -> d
red :: d -> d
green :: d -> d
yellow :: d -> d
blue :: d -> d
magenta :: d -> d
cyan :: d -> d
white :: d -> d
blacker :: d -> d
redder :: d -> d
greener :: d -> d
yellower :: d -> d
bluer :: d -> d
magentaer :: d -> d
cyaner :: d -> d
whiter :: d -> d
onBlack :: d -> d
onRed :: d -> d
onGreen :: d -> d
onYellow :: d -> d
onBlue :: d -> d
onMagenta :: d -> d
onCyan :: d -> d
onWhite :: d -> d
onBlacker :: d -> d
onRedder :: d -> d
onGreener :: d -> d
onYellower :: d -> d
onBluer :: d -> d
onMagentaer :: d -> d
onCyaner :: d -> d
onWhiter :: d -> d
default reverse :: Colorable16 (UnTrans d) => Trans d => d -> d
default black :: Colorable16 (UnTrans d) => Trans d => d -> d
default red :: Colorable16 (UnTrans d) => Trans d => d -> d
default green :: Colorable16 (UnTrans d) => Trans d => d -> d
default yellow :: Colorable16 (UnTrans d) => Trans d => d -> d
default blue :: Colorable16 (UnTrans d) => Trans d => d -> d
default magenta :: Colorable16 (UnTrans d) => Trans d => d -> d
default cyan :: Colorable16 (UnTrans d) => Trans d => d -> d
default white :: Colorable16 (UnTrans d) => Trans d => d -> d
default blacker :: Colorable16 (UnTrans d) => Trans d => d -> d
default redder :: Colorable16 (UnTrans d) => Trans d => d -> d
default greener :: Colorable16 (UnTrans d) => Trans d => d -> d
default yellower :: Colorable16 (UnTrans d) => Trans d => d -> d
default bluer :: Colorable16 (UnTrans d) => Trans d => d -> d
default magentaer :: Colorable16 (UnTrans d) => Trans d => d -> d
default cyaner :: Colorable16 (UnTrans d) => Trans d => d -> d
default whiter :: Colorable16 (UnTrans d) => Trans d => d -> d
default onBlack :: Colorable16 (UnTrans d) => Trans d => d -> d
default onRed :: Colorable16 (UnTrans d) => Trans d => d -> d
default onGreen :: Colorable16 (UnTrans d) => Trans d => d -> d
default onYellow :: Colorable16 (UnTrans d) => Trans d => d -> d
default onBlue :: Colorable16 (UnTrans d) => Trans d => d -> d
default onMagenta :: Colorable16 (UnTrans d) => Trans d => d -> d
default onCyan :: Colorable16 (UnTrans d) => Trans d => d -> d
default onWhite :: Colorable16 (UnTrans d) => Trans d => d -> d
default onBlacker :: Colorable16 (UnTrans d) => Trans d => d -> d
default onRedder :: Colorable16 (UnTrans d) => Trans d => d -> d
default onGreener :: Colorable16 (UnTrans d) => Trans d => d -> d
default onYellower :: Colorable16 (UnTrans d) => Trans d => d -> d
default onBluer :: Colorable16 (UnTrans d) => Trans d => d -> d
default onMagentaer :: Colorable16 (UnTrans d) => Trans d => d -> d
default onCyaner :: Colorable16 (UnTrans d) => Trans d => d -> d
default onWhiter :: Colorable16 (UnTrans d) => Trans d => d -> d
reverse = noTrans1 reverse
black = noTrans1 black
red = noTrans1 red
green = noTrans1 green
yellow = noTrans1 yellow
blue = noTrans1 blue
magenta = noTrans1 magenta
cyan = noTrans1 cyan
white = noTrans1 white
blacker = noTrans1 blacker
redder = noTrans1 redder
greener = noTrans1 greener
yellower = noTrans1 yellower
bluer = noTrans1 bluer
magentaer = noTrans1 magentaer
cyaner = noTrans1 cyaner
whiter = noTrans1 whiter
onBlack = noTrans1 onBlack
onRed = noTrans1 onRed
onGreen = noTrans1 onGreen
onYellow = noTrans1 onYellow
onBlue = noTrans1 onBlue
onMagenta = noTrans1 onMagenta
onCyan = noTrans1 onCyan
onWhite = noTrans1 onWhite
onBlacker = noTrans1 onBlacker
onRedder = noTrans1 onRedder
onGreener = noTrans1 onGreener
onYellower = noTrans1 onYellower
onBluer = noTrans1 onBluer
onMagentaer = noTrans1 onMagentaer
onCyaner = noTrans1 onCyaner
onWhiter = noTrans1 onWhiter
instance Colorable16 String where
reverse = xmlSGR "reverse"
black = xmlSGR "black"
red = xmlSGR "red"
green = xmlSGR "green"
yellow = xmlSGR "yellow"
blue = xmlSGR "blue"
magenta = xmlSGR "magenta"
cyan = xmlSGR "cyan"
white = xmlSGR "white"
blacker = xmlSGR "blacker"
redder = xmlSGR "redder"
greener = xmlSGR "greener"
yellower = xmlSGR "yellower"
bluer = xmlSGR "bluer"
magentaer = xmlSGR "magentaer"
cyaner = xmlSGR "cyaner"
whiter = xmlSGR "whiter"
onBlack = xmlSGR "onBlack"
onRed = xmlSGR "onRed"
onGreen = xmlSGR "onGreen"
onYellow = xmlSGR "onYellow"
onBlue = xmlSGR "onBlue"
onMagenta = xmlSGR "onMagenta"
onCyan = xmlSGR "onCyan"
onWhite = xmlSGR "onWhite"
onBlacker = xmlSGR "onBlacker"
onRedder = xmlSGR "onRedder"
onGreener = xmlSGR "onGreener"
onYellower = xmlSGR "onYellower"
onBluer = xmlSGR "onBluer"
onMagentaer = xmlSGR "onMagentaer"
onCyaner = xmlSGR "onCyaner"
onWhiter = xmlSGR "onWhiter"
xmlSGR :: Semigroup d => DocFrom String d => String -> d -> d
xmlSGR newSGR s = docFrom ("<"<>newSGR<>">")<>s<>docFrom ("</"<>newSGR<>">")
class Spaceable d => Indentable d where
align :: d -> d
incrIndent :: Indent -> d -> d
setIndent :: Indent -> d -> d
hang :: Indent -> d -> d
hang ind = align . incrIndent ind
fill :: Width -> d -> d
breakfill :: Width -> d -> d
default align :: Indentable (UnTrans d) => Trans d => d -> d
default incrIndent :: Indentable (UnTrans d) => Trans d => Indent -> d -> d
default setIndent :: Indentable (UnTrans d) => Trans d => Indent -> d -> d
default fill :: Indentable (UnTrans d) => Trans d => Width -> d -> d
default breakfill :: Indentable (UnTrans d) => Trans d => Width -> d -> d
align = noTrans1 align
incrIndent = noTrans1 . incrIndent
setIndent = noTrans1 . setIndent
fill = noTrans1 . fill
breakfill = noTrans1 . breakfill
class Wrappable d where
setWidth :: Maybe Width -> d -> d
breakpoint :: d
breakspace :: d
breakalt :: d -> d -> d
default breakpoint :: Wrappable (UnTrans d) => Trans d => d
default breakspace :: Wrappable (UnTrans d) => Trans d => d
default breakalt :: Wrappable (UnTrans d) => Trans d => d -> d -> d
breakpoint = noTrans breakpoint
breakspace = noTrans breakspace
breakalt = noTrans2 breakalt
class Justifiable d where
justify :: d -> d
class Trans repr where
type UnTrans repr :: *
noTrans :: UnTrans repr -> repr
unTrans :: repr -> UnTrans repr
noTrans1 :: (UnTrans repr -> UnTrans repr) -> (repr -> repr)
noTrans1 f = noTrans . f . unTrans
noTrans2
:: (UnTrans repr -> UnTrans repr -> UnTrans repr)
-> (repr -> repr -> repr)
noTrans2 f a b = noTrans (f (unTrans a) (unTrans b))
noTrans3
:: (UnTrans repr -> UnTrans repr -> UnTrans repr -> UnTrans repr)
-> (repr -> repr -> repr -> repr)
noTrans3 f a b c = noTrans (f (unTrans a) (unTrans b) (unTrans c))