Plain.hs

{-# LANGUAGE OverloadedStrings #-}
module Language.Symantic.CLI.Plain where

import Data.Bool
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Functor.Compose (Compose(..))
import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Text.Show (Show(..))
import qualified Data.Text.Lazy as TL
import qualified Language.Symantic.Document.Term as Doc
import qualified Language.Symantic.Document.Term.IO as DocIO

import Language.Symantic.CLI.Sym
import Language.Symantic.CLI.Fixity

-- * Class 'Doc'
class
 ( IsString d
 , Semigroup d
 , Monoid d
 , Doc.Textable d
 , Doc.Indentable d
 , Doc.Breakable d
 , Doc.Colorable d
 , Doc.Decorable d
 ) =>
 Doc d
instance Doc Doc.Term
instance Doc DocIO.TermIO

words :: Doc.Textable d => Doc.Breakable d => String -> d
words m = Doc.breakableSpaces $ Doc.string <$> Doc.words m

-- * Type 'Reader'
-- | Constructed top-down
data Reader d
 =   Reader
 {   reader_op             :: (Infix, Side) -- ^ Parent operator.
 ,   reader_define         :: Bool          -- ^ Whether to print a definition, or not.
 ,   reader_or             :: d
 }

defReader :: Doc.Textable d => Reader d
defReader = Reader
 { reader_op             = (infixN0, SideL)
 , reader_define         = True
 , reader_or             = Doc.stringH " | "
 }

pairIfNeeded :: Doc d => Reader d -> Infix -> d -> d
pairIfNeeded Reader{..} op d =
	if needsParenInfix reader_op op
	then Doc.align $ Doc.between (Doc.charH '(') (Doc.charH ')') d
	else d

-- * Type 'Plain'
newtype Plain d e t a
 =      Plain { unPlain :: Reader d -> Maybe d }

runPlain :: Monoid d => Plain d e t a -> Reader d -> d
runPlain (Plain p) = fromMaybe mempty . p

coercePlain :: Plain d e t a -> Plain d e u b
coercePlain Plain{..} = Plain{..}

textPlain :: Monoid d => Doc.Textable d => Plain d e t a -> d
textPlain p = runPlain p defReader

instance Semigroup d => Semigroup (Plain d e t a) where
	Plain x <> Plain y = Plain $ x <> y
instance (Semigroup d, Monoid d) => Monoid (Plain d e t a) where
	mempty  = Plain mempty
	mappend = (<>)
instance (Semigroup d, IsString d) => IsString (Plain d e t a) where
	fromString "" = Plain $ \_ro -> Nothing
	fromString s  = Plain $ \_ro -> Just $ fromString s
instance Show (Plain Doc.Term e t a) where
	show = TL.unpack . Doc.textTerm . textPlain
instance Doc d => Sym_Fun (Plain d) where
	_f <$$> Plain x = Plain $ \ro ->
		pairIfNeeded ro op <$>
		x ro{reader_op=(op, SideR)}
		where
		op = infixB SideL 10
instance Doc d => Sym_App (Plain d) where
	value _ = Plain $ \_ro -> Nothing
	end     = Plain $ \_ro -> Nothing
	Plain f <**> Plain x = Plain $ \ro ->
		case (f ro{reader_op=(op, SideL)}, x ro{reader_op=(op, SideR)}) of
		 (Nothing, Nothing) -> Nothing
		 (Just f', Nothing) -> Just f'
		 (Nothing, Just x') -> Just x'
		 (Just f', Just x') -> Just $ pairIfNeeded ro op $ f' <> Doc.space <> x'
		where
		op = infixB SideL 10
instance Doc d => Sym_Alt (Plain d) where
	lp <||> rp = Plain $ \ro ->
		Just $
		if needsParenInfix (reader_op ro) op
		then
			Doc.ifBreak
			 (Doc.align $
				Doc.between (Doc.charH '(') (Doc.charH ')') $
				Doc.space <>
				runPlain lp ro{reader_op=(op, SideL), reader_or=Doc.newline<>Doc.charH '|'<>Doc.space} <>
				Doc.newline <>
				Doc.stringH "| " <>
				runPlain rp ro{reader_op=(op, SideR), reader_or=Doc.newline<>Doc.charH '|'<>Doc.space} <>
				Doc.newline)
			 (Doc.between (Doc.charH '(') (Doc.charH ')') $
				Doc.withBreakable Nothing $
				runPlain lp ro{reader_op=(op, SideL), reader_or=Doc.stringH " | "} <>
				Doc.stringH " | " <>
				runPlain rp ro{reader_op=(op, SideR), reader_or=Doc.stringH " | "})
		else
			runPlain lp ro{reader_op=(op, SideL)} <>
			reader_or ro <>
			runPlain rp ro{reader_op=(op, SideR)}
		where op = infixB SideL 2
	try p = p
	choice [] = "<none>"
	choice [p] = p
	choice l@(_:_) = Plain $ \ro -> Just $
		pairIfNeeded ro op $
		Doc.foldWith ("\n| " <>) $
		(($ ro{reader_op=(op, SideL)}) . runPlain) <$> l
		where op = infixB SideL 2
	option _a p = Plain $ \ro -> Just $
		if needsParenInfix (reader_op ro) op
		then
			Doc.ifBreak
			 (Doc.align $
				Doc.between (Doc.charH '[') (Doc.charH ']') $
				Doc.space <>
				runPlain p ro{reader_op=(op, SideL)} <>
				Doc.newline)
			 (Doc.between (Doc.charH '[') (Doc.charH ']') $
				Doc.withBreakable Nothing $
				runPlain p ro{reader_op=(op, SideL), reader_or=Doc.stringH " | "})
		else
			runPlain p ro{reader_op=(op, SideL)}
		where op = infixN0
instance Doc d => Sym_AltApp (Plain d) where
	many p = Plain $ \ro -> Just $
		runPlain p ro{reader_op=(op, SideL)}<>"*"
		where op = infixN 10
	some p = Plain $ \ro -> Just $
		runPlain p ro{reader_op=(op, SideL)}<>"+"
		where op = infixN 10
type instance Perm (Plain d e t) = Compose [] (Plain d e t)
instance Doc d => Sym_Interleaved (Plain d) where
	interleaved (Compose []) = "<none>"
	interleaved (Compose [Plain p]) = Plain p
	interleaved (Compose l@(_:_)) = Plain $ \ro -> Just $
		-- pairIfNeeded ro op $
		Doc.align $
		Doc.foldWith Doc.breakableSpace $
		catMaybes $
		(\(Plain p) ->
			p ro
			 { reader_op=(op, SideL)
			 , reader_or=Doc.stringH " | " }
		) <$> l
		where op = infixN 10
	_f <<$>>      Plain p          = Compose [Plain p]
	_f <<$?>> (_, Plain p)         = Compose [coercePlain $ optional $ Plain p]
	_f <<$*>>     Plain p          = Compose [coercePlain $ many     $ Plain p]
	Compose ws <<|>>      Plain p  = Compose $ coercePlain <$> ws <> [Plain p]
	Compose ws <<|?>> (_, Plain p) = Compose $ coercePlain <$> ws <> [coercePlain $ optional $ Plain p]
	Compose ws <<|*>>     Plain p  = Compose $ coercePlain <$> ws <> [coercePlain $ many     $ Plain p]
instance Doc d => Sym_Rule (Plain d) where
	rule n p = Plain $ \ro -> Just $
		if reader_define ro
		then runPlain p ro{reader_define=False}
		else ref
		where
		ref =
			Doc.bold $
			Doc.between (Doc.charH '<') (Doc.charH '>') $
			Doc.magentaer $
			Doc.stringH n
instance Doc d => Sym_Option (Plain d) where
	var n _f = Plain $ \_ro -> Just $ Doc.between (Doc.charH '<') (Doc.charH '>') (Doc.string n)
	tag = fromString
	opt n r = Plain $ \ro ->
		unPlain (prefix n <**> coercePlain r) ro
		where
		prefix = \case
		 OptionName      s l -> prefix (OptionNameShort s)<>"|"<>prefix (OptionNameLong l)
		 OptionNameShort s   -> fromString ['-', s]
		 OptionNameLong  l   -> fromString ("--"<>l)
instance Doc d => Sym_Command (Plain d) where
	main n r = Plain $ \ro -> Just $
		if reader_define ro
		then
			runPlain
			 (fromString n <**> coercePlain r)
			 ro{reader_define = False}
		else ref
		where
		ref =
			Doc.bold $
			Doc.between (Doc.charH '<') (Doc.charH '>') $
			Doc.magentaer $
			Doc.stringH n
	command = main
instance Doc d => Sym_Help d (Plain d) where
	help _msg p = p
instance Doc d => Sym_Exit (Plain d) where
	exit _ = Plain $ \_ro -> Nothing