content: {-# LANGUAGE StrictData                 #-}
  {-# LANGUAGE BangPatterns               #-}
  {-# LANGUAGE DeriveDataTypeable         #-}
  {-# LANGUAGE DeriveGeneric              #-}
  {-# LANGUAGE FlexibleInstances          #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE OverloadedStrings          #-}
  {-# LANGUAGE ScopedTypeVariables        #-}
  {-# LANGUAGE TypeSynonymInstances       #-}
  
  -- | Basic types for Skylighting.
  module Skylighting.Types (
                -- * Syntax descriptions
                  ContextName
                , KeywordAttr(..)
                , WordSet(..)
                , makeWordSet
                , inWordSet
                , ListItem(..)
                , Matcher(..)
                , Rule(..)
                , Context(..)
                , ContextSwitch(..)
                , Syntax(..)
                , SyntaxMap
                -- * Tokens
                , Token
                , TokenType(..)
                , SourceLine
                , LineNo(..)
                -- * Styles
                , TokenStyle(..)
                , defStyle
                , Color(..)
                , ToColor(..)
                , FromColor(..)
                , Style(..)
                , ANSIColorLevel(..)
                -- * Format options
                , FormatOptions(..)
                , defaultFormatOpts
                ) where
  
  import Control.Monad (mplus)
  import Data.Aeson
  import Data.Aeson.Types (toJSONKeyText)
  import Data.Binary (Binary)
  import Data.Bits
  import Data.CaseInsensitive (FoldCase (..))
  import Data.Colour.SRGB (Colour, sRGB24, toSRGB24)
  import qualified Data.Colour.SRGB as Colour
  import Data.Data (Data)
  import qualified Data.Map as Map
  import Data.Maybe (fromMaybe)
  import qualified Data.Set as Set
  import Data.Text (Text)
  import qualified Data.Text as Text
  import Data.Typeable (Typeable)
  import Data.Word
  import GHC.Generics (Generic)
  import Safe (readMay)
  import Skylighting.Regex
  import Text.Printf
  
  -- | Full name of a context: the first member of the pair is the full
  -- syntax name, the second the context name within that syntax.
  type ContextName = (Text, Text)
  
  -- | Attributes controlling how keywords are interpreted.
  data KeywordAttr =
    KeywordAttr  { keywordCaseSensitive :: !Bool
                 , keywordDelims        :: !(Set.Set Char)
                 }
    deriving (Show, Read, Eq, Ord, Data, Typeable, Generic)
  
  instance Binary KeywordAttr
  
  -- | A set of "words," possibly case insensitive.
  data WordSet a = CaseSensitiveWords !(Set.Set a)
                 | CaseInsensitiveWords !(Set.Set a)
       deriving (Show, Read, Eq, Ord, Data, Typeable, Generic)
  
  instance Binary a => Binary (WordSet a)
  
  -- | A set of words to match (either case-sensitive or case-insensitive).
  makeWordSet :: (FoldCase a, Ord a) => Bool -> [a] -> WordSet a
  makeWordSet True ws  = CaseSensitiveWords (Set.fromList ws)
  makeWordSet False ws = CaseInsensitiveWords (Set.fromList $ map foldCase ws)
  
  -- | Test for membership in a 'WordSet'.
  inWordSet :: (FoldCase a, Ord a) => a -> WordSet a -> Bool
  inWordSet w (CaseInsensitiveWords ws) = foldCase w `Set.member` ws
  inWordSet w (CaseSensitiveWords ws)   = w `Set.member` ws
  
  -- | Matchers correspond to the element types in a context.
  data Matcher =
      DetectChar !Char
    | Detect2Chars !Char !Char
    | AnyChar !(Set.Set Char)
    | RangeDetect !Char !Char
    | StringDetect !Text
    | WordDetect !Text
    | RegExpr !RE
    | Keyword !KeywordAttr (Either Text (WordSet Text))
        -- Either Left list name (unresolved) or Right wordset (resolved)
    | Int
    | Float
    | HlCOct
    | HlCHex
    | HlCStringChar
    | HlCChar
    | LineContinue
    | IncludeRules !ContextName
    | DetectSpaces
    | DetectIdentifier
    deriving (Show, Read, Eq, Ord, Data, Typeable, Generic)
  
  instance Binary Matcher
  
  -- | A context switch, either pops or pushes a context.
  data ContextSwitch =
    Pop | Push !ContextName
    deriving (Show, Read, Eq, Ord, Data, Typeable, Generic)
  
  instance Binary ContextSwitch
  
  -- | A rule corresponds to one of the elements of a Kate syntax
  -- highlighting "context."
  data Rule = Rule{
      rMatcher          :: !Matcher
    , rAttribute        :: !TokenType
    , rIncludeAttribute :: !Bool
    , rWeakDeliminators :: Set.Set Char
    , rDynamic          :: !Bool
    , rCaseSensitive    :: !Bool
    , rChildren         :: ![Rule]
    , rLookahead        :: !Bool
    , rFirstNonspace    :: !Bool
    , rColumn           :: !(Maybe Int)
    , rContextSwitch    :: ![ContextSwitch]
    } deriving (Show, Read, Eq, Ord, Data, Typeable, Generic)
  
  instance Binary Rule
  
  -- | A list item is either just a textual value or an included list.
  -- IncludeList (x,y) includes list y from syntax with full name x.
  data ListItem = Item !Text | IncludeList !(Text, Text)
    deriving (Show, Eq, Ord, Read, Data, Typeable, Generic)
  
  instance Binary ListItem
  
  -- | A syntax corresponds to a complete Kate syntax description.
  -- The 'sShortname' field is derived from the filename.
  data Syntax = Syntax{
      sName            :: !Text
    , sFilename        :: !String
    , sShortname       :: !Text
    , sLists           :: !(Map.Map Text [ListItem])
    , sContexts        :: !(Map.Map Text Context)
    , sAuthor          :: !Text
    , sVersion         :: !Text
    , sLicense         :: !Text
    , sExtensions      :: ![String]
    , sStartingContext :: !Text
    } deriving (Show, Read, Eq, Ord, Data, Typeable, Generic)
  
  instance Binary Syntax
  
  -- | A map of syntaxes, keyed by full name.
  type SyntaxMap = Map.Map Text Syntax
  
  -- | A Context corresponds to a context element in a Kate
  -- syntax description.
  data Context = Context{
      cName               :: !Text
    , cSyntax             :: !Text
    , cRules              :: ![Rule]
    , cAttribute          :: !TokenType
    , cLineEmptyContext   :: ![ContextSwitch]
    , cLineEndContext     :: ![ContextSwitch]
    , cLineBeginContext   :: ![ContextSwitch]
    , cFallthrough        :: !Bool
    , cFallthroughContext :: ![ContextSwitch]
    , cDynamic            :: !Bool
  } deriving (Show, Read, Eq, Ord, Data, Typeable, Generic)
  
  instance Binary Context
  
  -- | A pair consisting of a list of attributes and some text.
  type Token = (TokenType, Text)
  
  -- | 'KeywordTok' corresponds to @dsKeyword@ in Kate syntax
  -- descriptions, and so on.
  data TokenType = KeywordTok
                 | DataTypeTok
                 | DecValTok
                 | BaseNTok
                 | FloatTok
                 | ConstantTok
                 | CharTok
                 | SpecialCharTok
                 | StringTok
                 | VerbatimStringTok
                 | SpecialStringTok
                 | ImportTok
                 | CommentTok
                 | DocumentationTok
                 | AnnotationTok
                 | CommentVarTok
                 | OtherTok
                 | FunctionTok
                 | VariableTok
                 | ControlFlowTok
                 | OperatorTok
                 | BuiltInTok
                 | ExtensionTok
                 | PreprocessorTok
                 | AttributeTok
                 | RegionMarkerTok
                 | InformationTok
                 | WarningTok
                 | AlertTok
                 | ErrorTok
                 | NormalTok
                 deriving (Read, Show, Eq, Ord, Enum, Bounded, Data, Typeable, Generic)
  
  instance Binary TokenType
  
  instance ToJSON TokenType where
    toEncoding = toEncoding . Text.stripSuffix "Tok" . Text.pack . show
  
  instance ToJSONKey TokenType where
    toJSONKey = toJSONKeyText
      (fromMaybe "Unknown" . Text.stripSuffix "Tok" . Text.pack . show)
  
  instance FromJSON TokenType where
    parseJSON (String t) =
       case readMay (Text.unpack t ++ "Tok") of
            Just tt -> return tt
            Nothing -> fail "Not a token type"
    parseJSON _ = mempty
  
  -- | JSON @"Keyword"@ corresponds to 'KeywordTok', and so on.
  instance FromJSONKey TokenType where
    fromJSONKey = FromJSONKeyTextParser (\t ->
      case readMay (Text.unpack t ++ "Tok") of
           Just tt -> return tt
           Nothing -> fail "Not a token type")
  
  -- | A line of source: a list of labeled tokens.
  type SourceLine = [Token]
  
  -- | Line numbers
  newtype LineNo = LineNo { lineNo :: Int } deriving (Show, Enum)
  
  -- | A 'TokenStyle' determines how a token is to be rendered.
  data TokenStyle = TokenStyle {
      tokenColor      :: !(Maybe Color)
    , tokenBackground :: !(Maybe Color)
    , tokenBold       :: !Bool
    , tokenItalic     :: !Bool
    , tokenUnderline  :: !Bool
    } deriving (Show, Read, Ord, Eq, Data, Typeable, Generic)
  
  instance Binary TokenStyle
  
  -- | The keywords used in KDE syntax
  -- themes are used, e.g. @text-color@ for default token color.
  instance FromJSON TokenStyle where
    parseJSON (Object v) = do
      tcolor <- v .:? "text-color"
      bg <- v .:? "background-color"
      tbold <- v .:? "bold" .!= False
      titalic <- v .:? "italic" .!= False
      tunderline <- v .:? "underline" .!= False
      return TokenStyle{
                 tokenColor = tcolor
               , tokenBackground = bg
               , tokenBold = tbold
               , tokenItalic = titalic
               , tokenUnderline = tunderline }
    parseJSON _ = mempty
  instance ToJSON TokenStyle where
    toJSON ts = object [ "text-color" .= tokenColor ts
                       , "background-color" .= tokenBackground ts
                       , "bold" .= tokenBold ts
                       , "italic" .= tokenItalic ts
                       , "underline" .= tokenUnderline ts ]
  
  -- | Default style.
  defStyle :: TokenStyle
  defStyle = TokenStyle {
      tokenColor      = Nothing
    , tokenBackground = Nothing
    , tokenBold       = False
    , tokenItalic     = False
    , tokenUnderline  = False
    }
  
  -- | A color (red, green, blue).
  data Color = RGB Word8 Word8 Word8
    deriving (Show, Read, Ord, Eq, Data, Typeable, Generic)
  
  instance Binary Color
  
  -- | Things that can be converted to a color.
  class ToColor a where
    toColor :: a -> Maybe Color
  
  instance ToColor String where
    toColor ['#',r1,r2,g1,g2,b1,b2] =
       case reads ['(','0','x',r1,r2,',','0','x',g1,g2,',','0','x',b1,b2,')'] of
             ((r,g,b),_) : _ -> Just $ RGB r g b
             _               -> Nothing
    toColor ['#',_,_,r1,r2,g1,g2,b1,b2] = -- ARGB format, we just ignore the A
       case reads ['(','0','x',r1,r2,',','0','x',g1,g2,',','0','x',b1,b2,')'] of
             ((r,g,b),_) : _ -> Just $ RGB r g b
             _               -> Nothing
    toColor _        = Nothing
  
  instance ToColor Int where
    toColor x = toColor (fromIntegral x1 :: Word8,
                         fromIntegral x2 :: Word8,
                         fromIntegral x3 :: Word8)
      where x1 = (shiftR x 16) .&. 0xFF
            x2 = (shiftR x 8 ) .&. 0xFF
            x3 = x             .&. 0xFF
  
  instance ToColor (Word8, Word8, Word8) where
    toColor (r,g,b) = Just $ RGB r g b
  
  instance ToColor (Double, Double, Double) where
    toColor (r,g,b) | r >= 0 && g >= 0 && b >= 0 && r <= 1 && g <= 1 && b <= 1 =
            Just $ RGB (floor $ r * 255) (floor $ g * 255) (floor $ b * 255)
    toColor _ = Nothing
  
  instance (RealFrac a, Floating a) => ToColor (Colour a) where
      toColor c = let (Colour.RGB r g b) = toSRGB24 c in toColor (r, g, b)
  
  -- | JSON @"#1aff2b"@ corresponds to the color @RGB 0x1a 0xff 0x2b@.
  instance FromJSON Color where
    parseJSON (String t) = maybe mempty return $ toColor (Text.unpack t)
    parseJSON _          = mempty
  
  instance ToJSON Color where
    toJSON color = String (Text.pack (fromColor color :: String))
  
  -- | Different representations of a 'Color'.
  class FromColor a where
    fromColor :: Color -> a
  
  instance FromColor String where
    fromColor (RGB r g b) = printf "#%02x%02x%02x" r g b
  
  instance FromColor (Double, Double, Double) where
    fromColor (RGB r g b) = (fromIntegral r / 255, fromIntegral g / 255, fromIntegral b / 255)
  
  instance FromColor (Word8, Word8, Word8) where
    fromColor (RGB r g b) = (r, g, b)
  
  instance (Ord a, Floating a) => FromColor (Colour a) where
      fromColor (RGB r g b) = sRGB24 r g b
  
  -- | A rendering style. This determines how each kind of token
  -- is to be rendered, and sets a default color and background
  -- color for normal tokens.  Line numbers can have a different
  -- color and background color.
  data Style = Style {
      tokenStyles               :: !(Map.Map TokenType TokenStyle)
    , defaultColor              :: !(Maybe Color)
    , backgroundColor           :: !(Maybe Color)
    , lineNumberColor           :: !(Maybe Color)
    , lineNumberBackgroundColor :: !(Maybe Color)
    } deriving (Read, Show, Eq, Ord, Data, Typeable, Generic)
  
  instance Binary Style
  
  -- | The FromJSON instance for 'Style' is designed so that
  -- a KDE syntax theme (JSON) can be decoded directly as a
  -- 'Style'.
  instance FromJSON Style where
    parseJSON (Object v) = do
      (tokstyles :: Map.Map Text TokenStyle) <- v .: "text-styles"
      (editorColors :: Map.Map Text Color) <- v .:? "editor-colors" .!= mempty
      mbBackgroundColor <- v .:? "background-color"
      mbLineNumberColor <- v .:? "line-number-color"
      mbDefaultColor <- v .:? "text-color"
      mbLineNumberBackgroundColor <- v .:? "line-number-background-color"
      return Style{ defaultColor = mbDefaultColor `mplus`
                       (case Map.lookup "Normal" tokstyles of
                             Nothing -> Nothing
                             Just ts -> tokenColor ts)
                  , backgroundColor = mbBackgroundColor `mplus`
                       Map.lookup "background-color" editorColors
                  , lineNumberColor = mbLineNumberColor `mplus`
                       Map.lookup "line-numbers" editorColors
                  , lineNumberBackgroundColor =
                       mbLineNumberBackgroundColor `mplus`
                         Map.lookup "background-color" editorColors
                  , tokenStyles =
                       Map.mapKeys (\s -> maybe OtherTok id $
                                       readMay (Text.unpack s ++ "Tok")) tokstyles }
    parseJSON _ = mempty
  
  instance ToJSON Style where
    toJSON s = object [ "text-styles" .= toJSON (tokenStyles s)
                      , "background-color" .= toJSON (backgroundColor s)
                      , "text-color" .= toJSON (defaultColor s)
                      , "line-number-color" .= toJSON (lineNumberColor s)
                      , "line-number-background-color" .=
                           toJSON (lineNumberBackgroundColor s)
                      ]
  
  -- | The available levels of color complexity in ANSI terminal output.
  data ANSIColorLevel = ANSI16Color   -- ^ 16-color mode
                      | ANSI256Color  -- ^ 256-color mode
                      | ANSITrueColor -- ^ True-color mode
         deriving (Show, Read, Eq, Ord, Enum, Bounded, Data, Typeable, Generic)
  
  instance Binary ANSIColorLevel
  
  -- | Options for formatting source code.
  data FormatOptions = FormatOptions{
           numberLines      :: !Bool           -- ^ Number lines
         , startNumber      :: !Int            -- ^ Number of first line
         , lineAnchors      :: !Bool           -- ^ Anchors on each line number
         , titleAttributes  :: !Bool           -- ^ Html titles with token types
         , codeClasses      :: ![Text]         -- ^ Additional classes for Html code tag
         , containerClasses :: ![Text]         -- ^ Additional classes for Html container tag
         , lineIdPrefix     :: !Text           -- ^ Prefix for id attributes on lines
         , ansiColorLevel   :: !ANSIColorLevel -- ^ Level of ANSI color support to use
         } deriving (Show, Read, Eq, Ord, Data, Typeable, Generic)
  
  instance Binary FormatOptions
  
  -- | Default formatting options.
  defaultFormatOpts :: FormatOptions
  defaultFormatOpts = FormatOptions{
                        numberLines = False
                      , startNumber = 1
                      , lineAnchors = False
                      , titleAttributes = False
                      , codeClasses = []
                      , containerClasses = []
                      , lineIdPrefix = ""
                      , ansiColorLevel = ANSI16Color
                      }
  