{-# LANGUAGE Arrows #-}
module Skylighting.Parser ( parseSyntaxDefinition
                          , parseSyntaxDefinitionFromString
                          , addSyntaxDefinition
                          , missingIncludes
                          ) where

import Data.ByteString.UTF8 (fromString, toString)
import qualified Data.ByteString as BS
import Data.Char (isAlphaNum, toUpper)
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 Safe
import Skylighting.Regex
import Skylighting.Types
import System.FilePath
import Text.XML.HXT.Core

-- | Adds a syntax definition to a syntax map,
-- replacing any existing definition with the same name.
addSyntaxDefinition :: Syntax -> SyntaxMap -> SyntaxMap
addSyntaxDefinition :: Syntax -> SyntaxMap -> SyntaxMap
addSyntaxDefinition Syntax
s = Text -> Syntax -> SyntaxMap -> SyntaxMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Syntax -> Text
sName Syntax
s) Syntax
s

-- | Scan a list of 'Syntax's and make sure that
-- `IncludeRules` never asks for a syntax not in this
-- list.  Produces a list of pairs where the first
-- element is the including syntax name and the second
-- element is the (missing) included syntax name.
-- This is intended for sanity checks to avoid run-time
-- errors.
missingIncludes :: [Syntax] -> [(Text, Text)]
missingIncludes :: [Syntax] -> [(Text, Text)]
missingIncludes [Syntax]
syns = [(Text, Text)] -> [(Text, Text)]
forall a. Ord a => [a] -> [a]
ordNub
  [(Syntax -> Text
sName Syntax
s, Text
lang)
     | Syntax
s <- [Syntax]
syns
     , Context
c <- Map Text Context -> [Context]
forall k a. Map k a -> [a]
Map.elems (Syntax -> Map Text Context
sContexts Syntax
s)
     , IncludeRules (Text
lang, Text
_) <- (Rule -> Matcher) -> [Rule] -> [Matcher]
forall a b. (a -> b) -> [a] -> [b]
map Rule -> Matcher
rMatcher (Context -> [Rule]
cRules Context
c)
     , Bool -> Bool
not (Text
lang Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
syntaxNames)]
   where syntaxNames :: Set Text
syntaxNames = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ (Syntax -> Text) -> [Syntax] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Syntax -> Text
sName [Syntax]
syns

ordNub :: (Ord a) => [a] -> [a]
ordNub :: [a] -> [a]
ordNub [a]
l = Set a -> [a] -> [a]
forall a. Ord a => Set a -> [a] -> [a]
go Set a
forall a. Set a
Set.empty [a]
l
  where
    go :: Set a -> [a] -> [a]
go Set a
_ [] = []
    go Set a
s (a
x:[a]
xs) = if a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
s then Set a -> [a] -> [a]
go Set a
s [a]
xs
                                      else a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
go (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
s) [a]
xs

standardDelims :: Set.Set Char
standardDelims :: Set Char
standardDelims = [Char] -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList [Char]
" \n\t.():!+,-<=>%&*/;?[]^{|}~\\"

defaultKeywordAttr :: KeywordAttr
defaultKeywordAttr :: KeywordAttr
defaultKeywordAttr = KeywordAttr :: Bool -> Set Char -> KeywordAttr
KeywordAttr { keywordCaseSensitive :: Bool
keywordCaseSensitive = Bool
True
                                 , keywordDelims :: Set Char
keywordDelims = Set Char
standardDelims }

stripWhitespace :: String -> String
stripWhitespace :: [Char] -> [Char]
stripWhitespace = [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
stripWhitespaceLeft ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
stripWhitespaceLeft
  where stripWhitespaceLeft :: [Char] -> [Char]
stripWhitespaceLeft = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isWhitespace
        isWhitespace :: Char -> Bool
isWhitespace Char
x = Char
x Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
' ', Char
'\t', Char
'\n']

vBool :: Bool -> String -> Bool
vBool :: Bool -> [Char] -> Bool
vBool Bool
defaultVal [Char]
value = case [Char]
value of
                           [Char]
z | [Char]
z [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"true",[Char]
"yes",[Char]
"1"] -> Bool
True
                           [Char]
z | [Char]
z [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"false",[Char]
"no",[Char]
"0"] -> Bool
False
                           [Char]
_ -> Bool
defaultVal

-- | Parses a file containing a Kate XML syntax definition
-- into a 'Syntax' description.  Note that if the DOCTYPE contains
-- a reference to the now-obsolete language.dtd, we remove it.
parseSyntaxDefinition :: FilePath -> IO (Either String Syntax)
parseSyntaxDefinition :: [Char] -> IO (Either [Char] Syntax)
parseSyntaxDefinition [Char]
fp = do
  [Char]
xml <- ByteString -> [Char]
toString (ByteString -> [Char]) -> IO ByteString -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ByteString
BS.readFile [Char]
fp
  [Char] -> [Char] -> IO (Either [Char] Syntax)
parseSyntaxDefinitionFromString [Char]
fp [Char]
xml

-- | Parses a string containing a Kate XML syntax definition
-- into a 'Syntax' description.  Note that if the DOCTYPE contains
-- a reference to the now-obsolete language.dtd, we remove it.
parseSyntaxDefinitionFromString :: FilePath -- ^ used for short name
                                -> String
                                -> IO (Either String Syntax)
parseSyntaxDefinitionFromString :: [Char] -> [Char] -> IO (Either [Char] Syntax)
parseSyntaxDefinitionFromString [Char]
fp [Char]
xml = do
  [Syntax]
res <- IOSArrow XmlTree Syntax -> IO [Syntax]
forall c. IOSArrow XmlTree c -> IO [c]
runX ( SysConfigList -> [Char] -> IOStateArrow () XmlTree XmlTree
forall s b. SysConfigList -> [Char] -> IOStateArrow s b XmlTree
readString [Bool -> SysConfig
withValidate Bool
no]
                  ([Char] -> [Char]
removeLanguageDTD ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
removeBOM ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
xml)
                IOStateArrow () XmlTree XmlTree
-> IOSArrow XmlTree Syntax -> IOSArrow XmlTree Syntax
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                [Char] -> IOSArrow XmlTree Syntax
application [Char]
fp )
  case [Syntax]
res of
       [Syntax
s] -> Either [Char] Syntax -> IO (Either [Char] Syntax)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] Syntax -> IO (Either [Char] Syntax))
-> Either [Char] Syntax -> IO (Either [Char] Syntax)
forall a b. (a -> b) -> a -> b
$ Syntax -> Either [Char] Syntax
forall a b. b -> Either a b
Right Syntax
s
       [Syntax]
_   -> Either [Char] Syntax -> IO (Either [Char] Syntax)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] Syntax -> IO (Either [Char] Syntax))
-> Either [Char] Syntax -> IO (Either [Char] Syntax)
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] Syntax
forall a b. a -> Either a b
Left ([Char] -> Either [Char] Syntax) -> [Char] -> Either [Char] Syntax
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not parse syntax definition " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
fp

removeBOM :: String -> String
removeBOM :: [Char] -> [Char]
removeBOM (Char
'\xFEFF':[Char]
xs) = [Char]
xs
removeBOM [Char]
xs            = [Char]
xs

removeLanguageDTD :: String -> String
removeLanguageDTD :: [Char] -> [Char]
removeLanguageDTD (Char
'S':Char
'Y':Char
'S':Char
'T':Char
'E':Char
'M':Char
' ':[Char]
xs) =
  [Char] -> [Char]
removeLanguageDTD ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'[' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'>') [Char]
xs
removeLanguageDTD xs :: [Char]
xs@(Char
'<':Char
'l':Char
'a':Char
'n':Char
'g':[Char]
_) = [Char]
xs
removeLanguageDTD (Char
x:[Char]
xs) = Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
removeLanguageDTD [Char]
xs
removeLanguageDTD [] = []

application :: FilePath -> IOSArrow XmlTree Syntax
application :: [Char] -> IOSArrow XmlTree Syntax
application [Char]
fp
    = IOStateArrow () XmlTree XmlTree -> IOStateArrow () XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
multi ([Char] -> IOStateArrow () XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> a XmlTree XmlTree
hasName [Char]
"language")
      IOStateArrow () XmlTree XmlTree
-> IOSArrow XmlTree Syntax -> IOSArrow XmlTree Syntax
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      [Char] -> IOSArrow XmlTree Syntax
extractSyntaxDefinition ([Char] -> [Char]
takeFileName [Char]
fp)

extractSyntaxDefinition :: String -> IOSArrow XmlTree Syntax
extractSyntaxDefinition :: [Char] -> IOSArrow XmlTree Syntax
extractSyntaxDefinition [Char]
filename =
  proc XmlTree
x -> do
     [Char]
lang <- [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"name" -< XmlTree
x
     [Char]
author <- [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"author" -< XmlTree
x
     [Char]
version <- [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"version" -< XmlTree
x
     [Char]
license <- [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"license" -< XmlTree
x
     [Char]
extensions <- [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"extensions" -< XmlTree
x
     [Context]
contexts <- (Bool,
 ([Char],
  (Map [Char] TokenType, ([([Char], [[Char]])], KeywordAttr))))
-> IOSArrow XmlTree [Context]
getContexts ((Bool,
  ([Char],
   (Map [Char] TokenType, ([([Char], [[Char]])], KeywordAttr))))
 -> IOSArrow XmlTree [Context])
-> IOSLA
     (XIOState ())
     XmlTree
     (Bool,
      ([Char],
       (Map [Char] TokenType, ([([Char], [[Char]])], KeywordAttr))))
-> IOSArrow XmlTree [Context]
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$<
                    (([Char] -> Bool) -> IOSLA (XIOState ()) [Char] Bool
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Bool -> [Char] -> Bool
vBool Bool
True) IOSLA (XIOState ()) [Char] Bool
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"casesensitive") IOSLA (XIOState ()) XmlTree Bool
-> IOSLA
     (XIOState ())
     XmlTree
     ([Char],
      (Map [Char] TokenType, ([([Char], [[Char]])], KeywordAttr)))
-> IOSLA
     (XIOState ())
     XmlTree
     (Bool,
      ([Char],
       (Map [Char] TokenType, ([([Char], [[Char]])], KeywordAttr))))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
                    ([Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"name") IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA
     (XIOState ())
     XmlTree
     (Map [Char] TokenType, ([([Char], [[Char]])], KeywordAttr))
-> IOSLA
     (XIOState ())
     XmlTree
     ([Char],
      (Map [Char] TokenType, ([([Char], [[Char]])], KeywordAttr)))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
                    (([([Char], [Char])] -> Map [Char] TokenType)
-> IOSLA (XIOState ()) [([Char], [Char])] (Map [Char] TokenType)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr [([Char], [Char])] -> Map [Char] TokenType
toItemDataTable IOSLA (XIOState ()) [([Char], [Char])] (Map [Char] TokenType)
-> IOSLA (XIOState ()) XmlTree [([Char], [Char])]
-> IOSLA (XIOState ()) XmlTree (Map [Char] TokenType)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< IOSLA (XIOState ()) XmlTree [([Char], [Char])]
getItemDatas) IOSLA (XIOState ()) XmlTree (Map [Char] TokenType)
-> IOSLA (XIOState ()) XmlTree ([([Char], [[Char]])], KeywordAttr)
-> IOSLA
     (XIOState ())
     XmlTree
     (Map [Char] TokenType, ([([Char], [[Char]])], KeywordAttr))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
                    IOSArrow XmlTree [([Char], [[Char]])]
getLists IOSArrow XmlTree [([Char], [[Char]])]
-> IOSLA (XIOState ()) XmlTree KeywordAttr
-> IOSLA (XIOState ()) XmlTree ([([Char], [[Char]])], KeywordAttr)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
                    (([KeywordAttr] -> KeywordAttr)
-> IOSLA (XIOState ()) [KeywordAttr] KeywordAttr
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (KeywordAttr -> [KeywordAttr] -> KeywordAttr
forall a. a -> [a] -> a
headDef KeywordAttr
defaultKeywordAttr) IOSLA (XIOState ()) [KeywordAttr] KeywordAttr
-> IOSLA (XIOState ()) XmlTree [KeywordAttr]
-> IOSLA (XIOState ()) XmlTree KeywordAttr
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< IOSLA (XIOState ()) XmlTree [KeywordAttr]
getKeywordAttrs) -< XmlTree
x
     Text
startingContext <- case [Context]
contexts of
                             (Context
c:[Context]
_) -> IOSLA (XIOState ()) Text Text
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Context -> Text
cName Context
c
                             []    -> [Char] -> IOStateArrow () () ()
forall s b. [Char] -> IOStateArrow s b b
issueErr [Char]
"No contexts" IOStateArrow () () ()
-> IOSLA (XIOState ()) () Text -> IOSLA (XIOState ()) () Text
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> IOSLA (XIOState ()) () Text
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none -< ()
     IOSLA (XIOState ()) Syntax Syntax
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Syntax :: Text
-> [Char]
-> Text
-> Map Text Context
-> Text
-> Text
-> Text
-> [[Char]]
-> Text
-> Syntax
Syntax{
                  sName :: Text
sName     = [Char] -> Text
Text.pack [Char]
lang
                , sFilename :: [Char]
sFilename = [Char]
filename
                , sShortname :: Text
sShortname = [Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
pathToLangName [Char]
filename
                , sAuthor :: Text
sAuthor   = [Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
author
                , sVersion :: Text
sVersion  = [Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
version
                , sLicense :: Text
sLicense  = [Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
license
                , sExtensions :: [[Char]]
sExtensions = [Char] -> [[Char]]
words ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map
                     (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
';'
                               then Char
' '
                               else Char
c) [Char]
extensions
                , sContexts :: Map Text Context
sContexts = [(Text, Context)] -> Map Text Context
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                       [(Context -> Text
cName Context
c, Context
c) | Context
c <- [Context]
contexts]
                , sStartingContext :: Text
sStartingContext = Text
startingContext
                }

toItemDataTable :: [(String,String)] -> Map.Map String TokenType
toItemDataTable :: [([Char], [Char])] -> Map [Char] TokenType
toItemDataTable = [([Char], TokenType)] -> Map [Char] TokenType
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([([Char], TokenType)] -> Map [Char] TokenType)
-> ([([Char], [Char])] -> [([Char], TokenType)])
-> [([Char], [Char])]
-> Map [Char] TokenType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], [Char]) -> ([Char], TokenType))
-> [([Char], [Char])] -> [([Char], TokenType)]
forall a b. (a -> b) -> [a] -> [b]
map (\([Char]
s,[Char]
t) -> ([Char]
s, [Char] -> TokenType
toTokenType [Char]
t))

getItemDatas :: IOSArrow XmlTree [(String,String)]
getItemDatas :: IOSLA (XIOState ()) XmlTree [([Char], [Char])]
getItemDatas =
  IOStateArrow () XmlTree XmlTree -> IOStateArrow () XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
multi ([Char] -> IOStateArrow () XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> a XmlTree XmlTree
hasName [Char]
"itemDatas")
     IOStateArrow () XmlTree XmlTree
-> IOSLA (XIOState ()) XmlTree [([Char], [Char])]
-> IOSLA (XIOState ()) XmlTree [([Char], [Char])]
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
     (IOSLA (XIOState ()) XmlTree ([Char], [Char])
-> IOSLA (XIOState ()) XmlTree [([Char], [Char])]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA (IOSLA (XIOState ()) XmlTree ([Char], [Char])
 -> IOSLA (XIOState ()) XmlTree [([Char], [Char])])
-> IOSLA (XIOState ()) XmlTree ([Char], [Char])
-> IOSLA (XIOState ()) XmlTree [([Char], [Char])]
forall a b. (a -> b) -> a -> b
$ IOStateArrow () XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
             IOStateArrow () XmlTree XmlTree
-> IOSLA (XIOState ()) XmlTree ([Char], [Char])
-> IOSLA (XIOState ()) XmlTree ([Char], [Char])
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
             [Char] -> IOStateArrow () XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> a XmlTree XmlTree
hasName [Char]
"itemData"
             IOStateArrow () XmlTree XmlTree
-> IOSLA (XIOState ()) XmlTree ([Char], [Char])
-> IOSLA (XIOState ()) XmlTree ([Char], [Char])
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
             [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"name" IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree ([Char], [Char])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"defStyleNum")

toTokenType :: String -> TokenType
toTokenType :: [Char] -> TokenType
toTokenType [Char]
s =
  case [Char]
s of
       [Char]
"dsNormal"         -> TokenType
NormalTok
       [Char]
"dsKeyword"        -> TokenType
KeywordTok
       [Char]
"dsDataType"       -> TokenType
DataTypeTok
       [Char]
"dsDecVal"         -> TokenType
DecValTok
       [Char]
"dsBaseN"          -> TokenType
BaseNTok
       [Char]
"dsFloat"          -> TokenType
FloatTok
       [Char]
"dsConstant"       -> TokenType
ConstantTok
       [Char]
"dsChar"           -> TokenType
CharTok
       [Char]
"dsSpecialChar"    -> TokenType
SpecialCharTok
       [Char]
"dsString"         -> TokenType
StringTok
       [Char]
"dsVerbatimString" -> TokenType
VerbatimStringTok
       [Char]
"dsSpecialString"  -> TokenType
SpecialStringTok
       [Char]
"dsImport"         -> TokenType
ImportTok
       [Char]
"dsComment"        -> TokenType
CommentTok
       [Char]
"dsDocumentation"  -> TokenType
DocumentationTok
       [Char]
"dsAnnotation"     -> TokenType
AnnotationTok
       [Char]
"dsCommentVar"     -> TokenType
CommentVarTok
       [Char]
"dsOthers"         -> TokenType
OtherTok
       [Char]
"dsFunction"       -> TokenType
FunctionTok
       [Char]
"dsVariable"       -> TokenType
VariableTok
       [Char]
"dsControlFlow"    -> TokenType
ControlFlowTok
       [Char]
"dsOperator"       -> TokenType
OperatorTok
       [Char]
"dsBuiltIn"        -> TokenType
BuiltInTok
       [Char]
"dsExtension"      -> TokenType
ExtensionTok
       [Char]
"dsPreprocessor"   -> TokenType
PreprocessorTok
       [Char]
"dsAttribute"      -> TokenType
AttributeTok
       [Char]
"dsRegionMarker"   -> TokenType
RegionMarkerTok
       [Char]
"dsInformation"    -> TokenType
InformationTok
       [Char]
"dsWarning"        -> TokenType
WarningTok
       [Char]
"dsAlert"          -> TokenType
AlertTok
       [Char]
"dsError"          -> TokenType
ErrorTok
       [Char]
_                  -> TokenType
NormalTok

getLists :: IOSArrow XmlTree [(String, [String])]
getLists :: IOSArrow XmlTree [([Char], [[Char]])]
getLists =
  IOSLA (XIOState ()) XmlTree ([Char], [[Char]])
-> IOSArrow XmlTree [([Char], [[Char]])]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA (IOSLA (XIOState ()) XmlTree ([Char], [[Char]])
 -> IOSArrow XmlTree [([Char], [[Char]])])
-> IOSLA (XIOState ()) XmlTree ([Char], [[Char]])
-> IOSArrow XmlTree [([Char], [[Char]])]
forall a b. (a -> b) -> a -> b
$ IOStateArrow () XmlTree XmlTree -> IOStateArrow () XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
multi ([Char] -> IOStateArrow () XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> a XmlTree XmlTree
hasName [Char]
"list")
     IOStateArrow () XmlTree XmlTree
-> IOSLA (XIOState ()) XmlTree ([Char], [[Char]])
-> IOSLA (XIOState ()) XmlTree ([Char], [[Char]])
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
     [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"name" IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree [[Char]]
-> IOSLA (XIOState ()) XmlTree ([Char], [[Char]])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& IOSLA (XIOState ()) XmlTree [[Char]]
getListContents

getListContents :: IOSArrow XmlTree [String]
getListContents :: IOSLA (XIOState ()) XmlTree [[Char]]
getListContents =
  IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree [[Char]]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA (IOSLA (XIOState ()) XmlTree [Char]
 -> IOSLA (XIOState ()) XmlTree [[Char]])
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree [[Char]]
forall a b. (a -> b) -> a -> b
$ IOStateArrow () XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
     IOStateArrow () XmlTree XmlTree
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree [Char]
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
     [Char] -> IOStateArrow () XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> a XmlTree XmlTree
hasName [Char]
"item"
     IOStateArrow () XmlTree XmlTree
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree [Char]
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
     IOStateArrow () XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
     IOStateArrow () XmlTree XmlTree
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree [Char]
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
     IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => a XmlTree [Char]
getText
     IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) [Char] [Char]
-> IOSLA (XIOState ()) XmlTree [Char]
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
     ([Char] -> [Char]) -> IOSLA (XIOState ()) [Char] [Char]
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr [Char] -> [Char]
stripWhitespace

getContexts ::
     (Bool,
       (String,
         (Map.Map String TokenType,
           ([(String, [String])], KeywordAttr))))
            -> IOSArrow XmlTree [Context]
getContexts :: (Bool,
 ([Char],
  (Map [Char] TokenType, ([([Char], [[Char]])], KeywordAttr))))
-> IOSArrow XmlTree [Context]
getContexts (Bool
casesensitive, ([Char]
syntaxname, (Map [Char] TokenType
itemdatas, ([([Char], [[Char]])]
lists, KeywordAttr
kwattr)))) =
  IOSLA (XIOState ()) XmlTree Context -> IOSArrow XmlTree [Context]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA (IOSLA (XIOState ()) XmlTree Context -> IOSArrow XmlTree [Context])
-> IOSLA (XIOState ()) XmlTree Context
-> IOSArrow XmlTree [Context]
forall a b. (a -> b) -> a -> b
$ IOStateArrow () XmlTree XmlTree -> IOStateArrow () XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
multi ([Char] -> IOStateArrow () XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> a XmlTree XmlTree
hasName [Char]
"context")
     IOStateArrow () XmlTree XmlTree
-> IOSLA (XIOState ()) XmlTree Context
-> IOSLA (XIOState ()) XmlTree Context
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
     proc XmlTree
x -> do
       [Char]
name <- [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"name" -< XmlTree
x
       [Char]
attribute <- [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"attribute" -< XmlTree
x
       [Char]
lineEmptyContext <- [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"lineEmptyContext" -< XmlTree
x
       [Char]
lineEndContext <- [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"lineEndContext" -< XmlTree
x
       [Char]
lineBeginContext <- [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"lineBeginContext" -< XmlTree
x
       Bool
fallthrough <- ([Char] -> Bool) -> IOSLA (XIOState ()) [Char] Bool
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Bool -> [Char] -> Bool
vBool Bool
False) IOSLA (XIOState ()) [Char] Bool
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"fallthrough" -< XmlTree
x
       [Char]
fallthroughContext <- [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"fallthroughContext" -< XmlTree
x
       Bool
dynamic <- ([Char] -> Bool) -> IOSLA (XIOState ()) [Char] Bool
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Bool -> [Char] -> Bool
vBool Bool
False) IOSLA (XIOState ()) [Char] Bool
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"dynamic" -< XmlTree
x
       [Rule]
parsers <- (Bool,
 ([Char],
  (Map [Char] TokenType, ([([Char], [[Char]])], KeywordAttr))))
-> [Char] -> IOSArrow XmlTree [Rule]
getParsers (Bool
casesensitive, ([Char]
syntaxname,
                                (Map [Char] TokenType
itemdatas, ([([Char], [[Char]])]
lists, KeywordAttr
kwattr)))) ([Char] -> IOSArrow XmlTree [Rule])
-> IOSLA (XIOState ()) XmlTree [Char] -> IOSArrow XmlTree [Rule]
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$<
                            [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"attribute" -< XmlTree
x
       IOSLA (XIOState ()) Context Context
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Context :: Text
-> Text
-> [Rule]
-> TokenType
-> [ContextSwitch]
-> [ContextSwitch]
-> [ContextSwitch]
-> Bool
-> [ContextSwitch]
-> Bool
-> Context
Context {
                     cName :: Text
cName = [Char] -> Text
Text.pack [Char]
name
                   , cSyntax :: Text
cSyntax = [Char] -> Text
Text.pack [Char]
syntaxname
                   , cRules :: [Rule]
cRules = [Rule]
parsers
                   , cAttribute :: TokenType
cAttribute = TokenType -> Maybe TokenType -> TokenType
forall a. a -> Maybe a -> a
fromMaybe TokenType
NormalTok (Maybe TokenType -> TokenType) -> Maybe TokenType -> TokenType
forall a b. (a -> b) -> a -> b
$
                           [Char] -> Map [Char] TokenType -> Maybe TokenType
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
attribute Map [Char] TokenType
itemdatas
                   , cLineEmptyContext :: [ContextSwitch]
cLineEmptyContext =
                        [Char] -> [Char] -> [ContextSwitch]
parseContextSwitch [Char]
syntaxname [Char]
lineEmptyContext
                   , cLineEndContext :: [ContextSwitch]
cLineEndContext =
                        [Char] -> [Char] -> [ContextSwitch]
parseContextSwitch [Char]
syntaxname [Char]
lineEndContext
                   , cLineBeginContext :: [ContextSwitch]
cLineBeginContext =
                        [Char] -> [Char] -> [ContextSwitch]
parseContextSwitch [Char]
syntaxname [Char]
lineBeginContext
                   , cFallthrough :: Bool
cFallthrough = Bool
fallthrough
                   , cFallthroughContext :: [ContextSwitch]
cFallthroughContext =
                        [Char] -> [Char] -> [ContextSwitch]
parseContextSwitch [Char]
syntaxname [Char]
fallthroughContext
                   , cDynamic :: Bool
cDynamic = Bool
dynamic
                   }

-- Note, some xml files have "\\" for a backslash,
-- others have "\".  Not sure what the rules are, but
-- this covers both bases:
readChar :: String -> Char
readChar :: [Char] -> Char
readChar [Char]
s = case [Char]
s of
                  [Char
c] -> Char
c
                  [Char]
_   -> Char -> [Char] -> Char
forall a. Read a => a -> [Char] -> a
readDef Char
'\xffff' ([Char] -> Char) -> [Char] -> Char
forall a b. (a -> b) -> a -> b
$ [Char]
"'" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"


getParsers :: (Bool,
                (String,
                  (Map.Map String TokenType,
                    ([(String, [String])], KeywordAttr))))
            -> String  -- context attribute
            -> IOSArrow XmlTree [Rule]
getParsers :: (Bool,
 ([Char],
  (Map [Char] TokenType, ([([Char], [[Char]])], KeywordAttr))))
-> [Char] -> IOSArrow XmlTree [Rule]
getParsers (Bool
casesensitive, ([Char]
syntaxname, (Map [Char] TokenType
itemdatas, ([([Char], [[Char]])]
lists, KeywordAttr
kwattr)))) [Char]
cattr =
  IOSLA (XIOState ()) XmlTree Rule -> IOSArrow XmlTree [Rule]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA (IOSLA (XIOState ()) XmlTree Rule -> IOSArrow XmlTree [Rule])
-> IOSLA (XIOState ()) XmlTree Rule -> IOSArrow XmlTree [Rule]
forall a b. (a -> b) -> a -> b
$ IOStateArrow () XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
     IOStateArrow () XmlTree XmlTree
-> IOSLA (XIOState ()) XmlTree Rule
-> IOSLA (XIOState ()) XmlTree Rule
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
     proc XmlTree
x -> do
       [Char]
name <- IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => a XmlTree [Char]
getName -< XmlTree
x
       [Char]
attribute <- [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"attribute" -< XmlTree
x
       [Char]
context <- [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"context" -< XmlTree
x
       Char
char0 <- ([Char] -> Char) -> IOSLA (XIOState ()) [Char] Char
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr [Char] -> Char
readChar IOSLA (XIOState ()) [Char] Char
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree Char
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"char" -< XmlTree
x
       Char
char1 <- ([Char] -> Char) -> IOSLA (XIOState ()) [Char] Char
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr [Char] -> Char
readChar IOSLA (XIOState ()) [Char] Char
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree Char
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"char1" -< XmlTree
x
       [Char]
str' <- [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"String" -< XmlTree
x
       Bool
insensitive <- ([Char] -> Bool) -> IOSLA (XIOState ()) [Char] Bool
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Bool -> [Char] -> Bool
vBool (Bool -> Bool
not Bool
casesensitive))
                            IOSLA (XIOState ()) [Char] Bool
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"insensitive" -< XmlTree
x
       Bool
includeAttrib <- ([Char] -> Bool) -> IOSLA (XIOState ()) [Char] Bool
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Bool -> [Char] -> Bool
vBool Bool
False) IOSLA (XIOState ()) [Char] Bool
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"includeAttrib" -< XmlTree
x
       Bool
lookahead <- ([Char] -> Bool) -> IOSLA (XIOState ()) [Char] Bool
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Bool -> [Char] -> Bool
vBool Bool
False) IOSLA (XIOState ()) [Char] Bool
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"lookAhead" -< XmlTree
x
       Bool
firstNonSpace <- ([Char] -> Bool) -> IOSLA (XIOState ()) [Char] Bool
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Bool -> [Char] -> Bool
vBool Bool
False) IOSLA (XIOState ()) [Char] Bool
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"firstNonSpace" -< XmlTree
x
       [Char]
column' <- [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"column" -< XmlTree
x
       Bool
dynamic <- ([Char] -> Bool) -> IOSLA (XIOState ()) [Char] Bool
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Bool -> [Char] -> Bool
vBool Bool
False) IOSLA (XIOState ()) [Char] Bool
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"dynamic" -< XmlTree
x
       [Rule]
children <- (Bool,
 ([Char],
  (Map [Char] TokenType, ([([Char], [[Char]])], KeywordAttr))))
-> [Char] -> IOSArrow XmlTree [Rule]
getParsers
                     (Bool
casesensitive, ([Char]
syntaxname, (Map [Char] TokenType
itemdatas, ([([Char], [[Char]])]
lists, KeywordAttr
kwattr))))
                     [Char]
cattr -< XmlTree
x
       let tildeRegex :: Bool
tildeRegex = [Char]
name [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"RegExpr" Bool -> Bool -> Bool
&& Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
1 [Char]
str' [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"^"
       let str :: [Char]
str = if Bool
tildeRegex then Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
1 [Char]
str' else [Char]
str'
       let column :: Maybe Int
column = if Bool
tildeRegex
                       then Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
0 :: Int)
                       else [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMay [Char]
column'
       let re :: Matcher
re = RE -> Matcher
RegExpr RE :: ByteString -> Bool -> RE
RE{ reString :: ByteString
reString = [Char] -> ByteString
fromString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
convertOctalEscapes [Char]
str
                          , reCaseSensitive :: Bool
reCaseSensitive = Bool -> Bool
not Bool
insensitive }
       let ([Char]
incsyntax, [Char]
inccontext) =
               case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'#') [Char]
context of
                     ([Char]
cont, Char
'#':Char
'#':[Char]
lang) -> ([Char]
lang, [Char]
cont)
                     ([Char], [Char])
_                    -> ([Char]
syntaxname, [Char]
context)
       let mbmatcher :: Maybe Matcher
mbmatcher = case [Char]
name of
                         [Char]
"DetectChar" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$ Char -> Matcher
DetectChar Char
char0
                         [Char]
"Detect2Chars" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$ Char -> Char -> Matcher
Detect2Chars Char
char0 Char
char1
                         [Char]
"AnyChar" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$ [Char] -> Matcher
AnyChar [Char]
str
                         [Char]
"RangeDetect" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$ Char -> Char -> Matcher
RangeDetect Char
char0 Char
char1
                         [Char]
"StringDetect" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$ Text -> Matcher
StringDetect (Text -> Matcher) -> Text -> Matcher
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
Text.pack [Char]
str
                         [Char]
"WordDetect" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$ Text -> Matcher
WordDetect (Text -> Matcher) -> Text -> Matcher
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
Text.pack [Char]
str
                         [Char]
"RegExpr" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$ Matcher
re
                         [Char]
"keyword" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$ KeywordAttr -> WordSet Text -> Matcher
Keyword KeywordAttr
kwattr (WordSet Text -> Matcher) -> WordSet Text -> Matcher
forall a b. (a -> b) -> a -> b
$
                            WordSet Text
-> ([[Char]] -> WordSet Text) -> Maybe [[Char]] -> WordSet Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> [Text] -> WordSet Text
forall a. (FoldCase a, Ord a) => Bool -> [a] -> WordSet a
makeWordSet Bool
True [])
                              (Bool -> [Text] -> WordSet Text
forall a. (FoldCase a, Ord a) => Bool -> [a] -> WordSet a
makeWordSet (KeywordAttr -> Bool
keywordCaseSensitive KeywordAttr
kwattr) ([Text] -> WordSet Text)
-> ([[Char]] -> [Text]) -> [[Char]] -> WordSet Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
Text.pack)
                              ([Char] -> [([Char], [[Char]])] -> Maybe [[Char]]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
str [([Char], [[Char]])]
lists)
                         [Char]
"Int" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$ Matcher
Int
                         [Char]
"Float" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$ Matcher
Float
                         [Char]
"HlCOct" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$ Matcher
HlCOct
                         [Char]
"HlCHex" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$ Matcher
HlCHex
                         [Char]
"HlCStringChar" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$ Matcher
HlCStringChar
                         [Char]
"HlCChar" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$ Matcher
HlCChar
                         [Char]
"LineContinue" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$ Matcher
LineContinue
                         [Char]
"IncludeRules" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$
                           (Text, Text) -> Matcher
IncludeRules ([Char] -> Text
Text.pack [Char]
incsyntax, [Char] -> Text
Text.pack [Char]
inccontext)
                         [Char]
"DetectSpaces" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$ Matcher
DetectSpaces
                         [Char]
"DetectIdentifier" -> Matcher -> Maybe Matcher
forall a. a -> Maybe a
Just (Matcher -> Maybe Matcher) -> Matcher -> Maybe Matcher
forall a b. (a -> b) -> a -> b
$ Matcher
DetectIdentifier
                         [Char]
_ -> Maybe Matcher
forall a. Maybe a
Nothing

       Matcher
matcher <- case Maybe Matcher
mbmatcher of
                       Maybe Matcher
Nothing -> IOSLA (XIOState ()) [Char] Matcher
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
                                   IOSLA (XIOState ()) [Char] Matcher
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree Matcher
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< IOSLA (XIOState ()) [Char] (IOSLA (XIOState ()) [Char] [Char])
-> IOSLA (XIOState ()) [Char] [Char]
forall (a :: * -> * -> *) b c. ArrowList a => a b (a b c) -> a b c
applyA (([Char] -> IOSLA (XIOState ()) [Char] [Char])
-> IOSLA (XIOState ()) [Char] (IOSLA (XIOState ()) [Char] [Char])
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr [Char] -> IOSLA (XIOState ()) [Char] [Char]
forall s b. [Char] -> IOStateArrow s b b
issueWarn)
                                   IOSLA (XIOState ()) [Char] [Char]
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree [Char]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< ([Char] -> [Char]) -> IOSLA (XIOState ()) [Char] [Char]
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ([Char]
"Unknown element " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
                                   IOSLA (XIOState ()) [Char] [Char]
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree [Char]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => a XmlTree [Char]
getName -< XmlTree
x
                       Just Matcher
m  -> IOSLA (XIOState ()) Matcher Matcher
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Matcher
m

       let contextSwitch :: [ContextSwitch]
contextSwitch = if [Char]
name [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"IncludeRules"
                              then []  -- is this right?
                              else [Char] -> [Char] -> [ContextSwitch]
parseContextSwitch [Char]
incsyntax [Char]
inccontext
       IOSLA (XIOState ()) Rule Rule
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Rule :: Matcher
-> TokenType
-> Bool
-> Bool
-> Bool
-> [Rule]
-> Bool
-> Bool
-> Maybe Int
-> [ContextSwitch]
-> Rule
Rule{ rMatcher :: Matcher
rMatcher = Matcher
matcher,
                        rAttribute :: TokenType
rAttribute = TokenType -> Maybe TokenType -> TokenType
forall a. a -> Maybe a -> a
fromMaybe TokenType
NormalTok (Maybe TokenType -> TokenType) -> Maybe TokenType -> TokenType
forall a b. (a -> b) -> a -> b
$
                           if [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
attribute
                              then [Char] -> Map [Char] TokenType -> Maybe TokenType
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
cattr Map [Char] TokenType
itemdatas
                              else [Char] -> Map [Char] TokenType -> Maybe TokenType
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
attribute Map [Char] TokenType
itemdatas,
                        rIncludeAttribute :: Bool
rIncludeAttribute = Bool
includeAttrib,
                        rDynamic :: Bool
rDynamic = Bool
dynamic,
                        rCaseSensitive :: Bool
rCaseSensitive = Bool -> Bool
not Bool
insensitive,
                        rChildren :: [Rule]
rChildren = [Rule]
children,
                        rContextSwitch :: [ContextSwitch]
rContextSwitch = [ContextSwitch]
contextSwitch,
                        rLookahead :: Bool
rLookahead = Bool
lookahead,
                        rFirstNonspace :: Bool
rFirstNonspace = Bool
firstNonSpace ,
                        rColumn :: Maybe Int
rColumn = Maybe Int
column }

parseContextSwitch :: String -> String -> [ContextSwitch]
parseContextSwitch :: [Char] -> [Char] -> [ContextSwitch]
parseContextSwitch [Char]
_ [] = []
parseContextSwitch [Char]
_ [Char]
"#stay" = []
parseContextSwitch [Char]
syntaxname (Char
'#':Char
'p':Char
'o':Char
'p':[Char]
xs) =
  ContextSwitch
Pop ContextSwitch -> [ContextSwitch] -> [ContextSwitch]
forall a. a -> [a] -> [a]
: [Char] -> [Char] -> [ContextSwitch]
parseContextSwitch [Char]
syntaxname [Char]
xs
parseContextSwitch [Char]
syntaxname (Char
'!':[Char]
xs) = [(Text, Text) -> ContextSwitch
Push ([Char] -> Text
Text.pack [Char]
syntaxname, [Char] -> Text
Text.pack [Char]
xs)]
parseContextSwitch [Char]
syntaxname [Char]
xs = [(Text, Text) -> ContextSwitch
Push ([Char] -> Text
Text.pack [Char]
syntaxname, [Char] -> Text
Text.pack [Char]
xs)]

getKeywordAttrs :: IOSArrow XmlTree [KeywordAttr]
getKeywordAttrs :: IOSLA (XIOState ()) XmlTree [KeywordAttr]
getKeywordAttrs =
  IOSLA (XIOState ()) XmlTree KeywordAttr
-> IOSLA (XIOState ()) XmlTree [KeywordAttr]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA (IOSLA (XIOState ()) XmlTree KeywordAttr
 -> IOSLA (XIOState ()) XmlTree [KeywordAttr])
-> IOSLA (XIOState ()) XmlTree KeywordAttr
-> IOSLA (XIOState ()) XmlTree [KeywordAttr]
forall a b. (a -> b) -> a -> b
$ IOSLA (XIOState ()) XmlTree KeywordAttr
-> IOSLA (XIOState ()) XmlTree KeywordAttr
forall (a :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
multi (IOSLA (XIOState ()) XmlTree KeywordAttr
 -> IOSLA (XIOState ()) XmlTree KeywordAttr)
-> IOSLA (XIOState ()) XmlTree KeywordAttr
-> IOSLA (XIOState ()) XmlTree KeywordAttr
forall a b. (a -> b) -> a -> b
$ [Char] -> IOStateArrow () XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> a XmlTree XmlTree
hasName [Char]
"keywords"
     IOStateArrow () XmlTree XmlTree
-> IOSLA (XIOState ()) XmlTree KeywordAttr
-> IOSLA (XIOState ()) XmlTree KeywordAttr
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
     proc XmlTree
x -> do
       Bool
caseSensitive <- ([Char] -> Bool) -> IOSLA (XIOState ()) [Char] Bool
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Bool -> [Char] -> Bool
vBool Bool
True) IOSLA (XIOState ()) [Char] Bool
-> IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA (XIOState ()) XmlTree Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"casesensitive" -< XmlTree
x
       [Char]
weakDelim <- [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"weakDeliminator" -< XmlTree
x
       [Char]
additionalDelim <- [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
"additionalDeliminator" -< XmlTree
x
       IOSLA (XIOState ()) KeywordAttr KeywordAttr
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< KeywordAttr :: Bool -> Set Char -> KeywordAttr
KeywordAttr
                         { keywordCaseSensitive :: Bool
keywordCaseSensitive = Bool
caseSensitive
                         , keywordDelims :: Set Char
keywordDelims = (Set Char -> Set Char -> Set Char
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Char
standardDelims
                             ([Char] -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList [Char]
additionalDelim)) Set Char -> Set Char -> Set Char
forall a. Ord a => Set a -> Set a -> Set a
Set.\\
                                [Char] -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList [Char]
weakDelim }

pathToLangName :: String -> String
pathToLangName :: [Char] -> [Char]
pathToLangName [Char]
s = [Char] -> [Char]
capitalize ([Char] -> [Char]
camelize ([Char] -> [Char]
takeBaseName [Char]
s))

camelize :: String -> String
camelize :: [Char] -> [Char]
camelize (Char
d:Char
c:[Char]
cs) | Bool -> Bool
not (Char -> Bool
isAlphaNum Char
d) = Char -> Char
toUpper Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
camelize [Char]
cs
camelize (Char
c:[Char]
cs)   = Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
camelize [Char]
cs
camelize []       = []

capitalize :: String -> String
capitalize :: [Char] -> [Char]
capitalize (Char
c:[Char]
cs) = Char -> Char
toUpper Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs
capitalize []     = []