{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | This module defines symantics
-- for terminal grammars.
module Language.Symantic.Grammar.Terminal where

import Control.Monad
import qualified Data.Bool as Bool
import qualified Data.Char as Char
import qualified Data.List as List
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import qualified Data.Text as Text
import Prelude hiding (any)

import Language.Symantic.Grammar.EBNF

-- * Type 'Terminal'
-- | Terminal grammar.
newtype Terminal g a
 =      Terminal { unTerminal :: g a }
 deriving (Functor, Gram_Terminal)
deriving instance Gram_Rule g => Gram_Rule (Terminal g)

-- ** Class 'Gram_Terminal'
-- | Symantics for terminal grammars.
class Gram_Terminal g where
	any    :: g Char
	but    :: Terminal g Char -> Terminal g Char -> Terminal g Char
	eoi    :: g ()
	char   :: Char -> g Char
	string :: String -> g String
	unicat :: Unicat -> g Char
	range  :: (Char, Char) -> g Char
	-- string = foldr (\c -> (<*>) ((:) <$> char c)) (pure "")
	-- string [] = pure []
	-- string (c:cs) = (:) <$> char c <*> string cs
deriving instance Gram_Terminal RuleDef
instance Gram_Terminal EBNF where
	any  = ebnf_const "_"
	Terminal (EBNF f) `but` Terminal (EBNF g) =
		Terminal $ EBNF $ \bo po -> infix_paren po op $
			f bo (op, L) <> " - " <> g bo (op, R)
		where op = infixL 6
	eoi  = ebnf_const "eoi"
	char = ebnf_const . escape
		where
		escape c | Char.isPrint c && c /= '"' = Text.concat $ ["\"", Text.singleton c, "\""]
		escape c = Text.concat ["U+", Text.pack $ show $ Char.ord c]
	string s =
		case List.break (\c -> Bool.not (Char.isPrint c) || c == '"') s of
		 (ps, "")   -> raw ps
		 ("", [c])  -> "" <$ char c
		 (ps, [c])  -> "" <$ raw ps <* char c
		 ("", c:rs) -> "" <$ char c <* string rs
		 (ps, c:rs) -> "" <$ raw ps <* char c <* string rs
		where
		raw cs = ebnf_const $ Text.concat $ ["\"", Text.pack cs, "\""]
	unicat = ebnf_const . Text.pack . show
	range (l, h) = ebnf_const $ Text.concat
	 [ runEBNF $ char l
	 , "…"
	 , runEBNF $ char h
	 ]
instance IsString (EBNF String) where
	fromString = string

-- *** Type 'Unicat'
-- | Unicode category.
data Unicat
 = Unicat_Letter
 | Unicat_Mark
 | Unicat_Number
 | Unicat_Punctuation
 | Unicat_Symbol
 | Unicat Char.GeneralCategory
 deriving (Eq, Show)

unicode_categories :: Unicat -> [Char.GeneralCategory]
unicode_categories c =
	case c of
	 Unicat_Letter ->
		 [ Char.UppercaseLetter
		 , Char.LowercaseLetter
		 , Char.TitlecaseLetter
		 , Char.ModifierLetter
		 , Char.OtherLetter
		 ]
	 Unicat_Mark ->
		 [ Char.NonSpacingMark
		 , Char.SpacingCombiningMark
		 , Char.EnclosingMark
		 ]
	 Unicat_Number ->
		 [ Char.DecimalNumber
		 , Char.LetterNumber
		 , Char.OtherNumber
		 ]
	 Unicat_Punctuation ->
		 [ Char.ConnectorPunctuation
		 , Char.DashPunctuation
		 , Char.OpenPunctuation
		 , Char.ClosePunctuation
		 , Char.OtherPunctuation
		 ]
	 Unicat_Symbol ->
		 [ Char.MathSymbol
		 , Char.CurrencySymbol
		 , Char.ModifierSymbol
		 , Char.OtherSymbol
		 ]
	 Unicat cat -> [cat]