{-# 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