{-# 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)
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 Data.Traversable (Traversable)
import Numeric.Natural (Natural)
import Prelude (Integer, fromIntegral, pred)
import System.Console.ANSI (SGR, setSGRCode)
import Text.Show (Show(..))
import qualified Data.Foldable as Fold
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 From [SGR] d => From [SGR] (Word d) where
from = Word . from
class From a d where
from :: a -> d
default from :: From String d => Show a => a -> d
from = from . show
instance From (Line String) d => From Int d where
from = from . Line . show
instance From (Line String) d => From Integer d where
from = from . Line . show
instance From (Line String) d => From Natural d where
from = from . Line . show
instance From Char String where
from = pure
instance From String String where
from = id
instance From Text String where
from = Text.unpack
instance From TL.Text String where
from = TL.unpack
instance From d String => From (Line d) String where
from = from . unLine
instance From d String => From (Word d) String where
from = from . unWord
instance From [SGR] String where
from = setSGRCode
instance From Char Text where
from = Text.singleton
instance From String Text where
from = Text.pack
instance From Text Text where
from = id
instance From TL.Text Text where
from = TL.toStrict
instance From d Text => From (Line d) Text where
from = from . unLine
instance From d Text => From (Word d) Text where
from = from . unWord
instance From [SGR] Text where
from = from . setSGRCode
instance From Char TLB.Builder where
from = TLB.singleton
instance From String TLB.Builder where
from = fromString
instance From Text TLB.Builder where
from = TLB.fromText
instance From TL.Text TLB.Builder where
from = TLB.fromLazyText
instance From TLB.Builder TLB.Builder where
from = id
instance From d TLB.Builder => From (Line d) TLB.Builder where
from = from . unLine
instance From d TLB.Builder => From (Word d) TLB.Builder where
from = from . unWord
instance From [SGR] TLB.Builder where
from = from . setSGRCode
runTextBuilder :: TLB.Builder -> TL.Text
runTextBuilder = TLB.toLazyText
class Lengthable d where
width :: d -> Column
nullWidth :: d -> Bool
nullWidth d = width d == 0
instance Lengthable Char where
width _ = 1
nullWidth = const False
instance Lengthable String where
width = fromIntegral . List.length
nullWidth = Fold.null
instance Lengthable Text.Text where
width = fromIntegral . Text.length
nullWidth = Text.null
instance Lengthable TL.Text where
width = fromIntegral . TL.length
nullWidth = TL.null
instance Lengthable d => Lengthable (Line d) where
width = fromIntegral . width . unLine
nullWidth = nullWidth . unLine
instance Lengthable d => Lengthable (Word d) where
width = fromIntegral . width . unWord
nullWidth = nullWidth . 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 = Fold.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 = catV . (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 = Fold.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 Fold.null ds then mempty else Fold.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 => From (Word Char) d => d -> d
parens = between (from (Word '(')) (from (Word ')'))
braces :: Semigroup d => From (Word Char) d => d -> d
braces = between (from (Word '{')) (from (Word '}'))
brackets :: Semigroup d => From (Word Char) d => d -> d
brackets = between (from (Word '[')) (from (Word ']'))
angles :: Semigroup d => From (Word Char) d => d -> d
angles = between (from (Word '<')) (from (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 nullWidth d0 then [] else go d0
where
go d =
let (l,r) = f`break`d in
l : case tail r of
Nothing -> []
Just rt | nullWidth rt -> [mempty]
| otherwise -> go rt
splitOnCharNoEmpty :: (Char -> Bool) -> d -> [d]
splitOnCharNoEmpty f d =
let (l,r) = f`break`d in
(if nullWidth 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 => From String d => String -> d -> d
xmlSGR newSGR s = from ("<"<>newSGR<>">")<>s<>from ("</"<>newSGR<>">")
class Spaceable d => Indentable d where
align :: d -> d
setIndent :: d -> Indent -> d -> d
incrIndent :: d -> Indent -> d -> d
hang :: Indent -> d -> d
hang ind = align . incrIndent (spaces ind) ind
fill :: Width -> d -> d
fillOrBreak :: Width -> d -> d
default align :: Indentable (UnTrans d) => Trans d => d -> d
default incrIndent :: Indentable (UnTrans d) => Trans d => d -> Indent -> d -> d
default setIndent :: Indentable (UnTrans d) => Trans d => d -> Indent -> d -> d
default fill :: Indentable (UnTrans d) => Trans d => Width -> d -> d
default fillOrBreak :: Indentable (UnTrans d) => Trans d => Width -> d -> d
align = noTrans1 align
setIndent p i = noTrans . setIndent (unTrans p) i . unTrans
incrIndent p i = noTrans . incrIndent (unTrans p) i . unTrans
fill = noTrans1 . fill
fillOrBreak = noTrans1 . fillOrBreak
class Listable d where
ul :: Traversable f => f d -> d
ol :: Traversable f => f d -> d
default ul ::
Listable (UnTrans d) => Trans d =>
Traversable f => f d -> d
default ol ::
Listable (UnTrans d) => Trans d =>
Traversable f => f d -> d
ul ds = noTrans $ ul $ unTrans <$> ds
ol ds = noTrans $ ol $ unTrans <$> ds
class Wrappable d where
setWidth :: Maybe Width -> d -> d
breakpoint :: d
breakspace :: d
breakalt :: d -> d -> d
endline :: 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
default endline :: Wrappable (UnTrans d) => Trans d => d
breakpoint = noTrans breakpoint
breakspace = noTrans breakspace
breakalt = noTrans2 breakalt
endline = noTrans endline
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))