Add Data.Locale.
[doclang.git] / Language / TCT / Read / Token.hs
index d06abb7b6ab871240474b1f9bf31c096e01f2d5e..7ee57f2a25de37de610f7ea71efd02b4b8f1ebf1 100644 (file)
@@ -10,7 +10,7 @@ import Data.Bool
 import Data.Char (Char)
 import Data.Eq (Eq(..))
 import Data.Foldable (Foldable(..))
-import Data.Function (($), (.), flip)
+import Data.Function (($), (.))
 import Data.Functor ((<$>), ($>), (<$))
 import Data.Maybe (Maybe(..))
 import Data.Monoid (Monoid(..))
@@ -19,6 +19,7 @@ import Data.Sequence (ViewL(..), (<|))
 import Data.Text (Text)
 import Data.Text.Buildable (Buildable(..))
 import Data.Tuple (fst,snd)
+import Prelude (Num(..))
 import Text.Show (Show(..))
 import qualified Data.Char as Char
 import qualified Data.Sequence as Seq
@@ -26,62 +27,70 @@ import qualified Data.Text as Text
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Builder as Builder
 import qualified Text.Megaparsec as P
+import qualified Text.Megaparsec.Char as P
 
 import Language.TCT.Token
-import Language.TCT.Elem      -- hiding (dbg)
-import Language.TCT.Read.Elem -- hiding (pdbg)
-
-{-
-import Debug.Trace (trace)
-dbg m x = trace (m <> ": " <> show x) x
-pdbg m p = P.dbg m p
--}
+import Language.TCT.Cell
+import Language.TCT.Elem
+import Language.TCT.Read.Elem
+import Language.TCT.Read.Cell
 
 textOf :: Buildable a => a -> Text
 textOf = TL.toStrict . Builder.toLazyText . build
 
 -- * Type 'Pairs'
-type Pairs = (Tokens,[(Pair,Tokens)])
+type Pairs = (Tokens,[(Cell Pair,Tokens)])
 
-openPair :: Pair -> Pairs -> Pairs
-openPair g (t,ms) = (t,(g,mempty):ms)
+appendToken :: Pairs -> Cell Token -> Pairs
+appendToken ps = appendTokens ps . Seq.singleton
 
-insertToken :: Token -> Pairs -> Pairs
-insertToken tok (t,[])         = (t<>tokens [tok],[])
-insertToken tok (t,(p0,t0):ps) = (t,(p0,t0<>tokens [tok]):ps)
+appendTokens :: Pairs -> Tokens -> Pairs
+appendTokens (t,[])         toks = (t<>toks,[])
+appendTokens (t,(p0,t0):ps) toks = (t,(p0,t0<>toks):ps)
 
-insertTokens :: Tokens -> Pairs -> Pairs
-insertTokens toks (t,[])         = (t<>toks,[])
-insertTokens toks (t,(p0,t0):ps) = (t,(p0,t0<>toks):ps)
+openPair :: Pairs -> Cell Pair -> Pairs
+openPair (t,ms) p = (t,(p,mempty):ms)
 
 -- | Close a 'Pair' when there is a matching 'LexemePairClose'.
-closePair :: Pair -> Pairs -> Pairs
-closePair p (t,[]) = dbg "closePair" $
-       (t<>tokens [TokenPlain $ snd $ pairBorders p mempty],[])
-closePair p (t,(p1,t1):ts) = dbg "closePair" $
-       case (p,p1) of
-        (PairElem x ax, PairElem y ay) | x == y ->
-               insertToken (TokenPair (PairElem x (ax<>ay)) t1) (t,ts)
-        (x,y) | x == y -> insertToken (TokenPair p1 t1) (t,ts)
+closePair :: Pairs -> Cell Pair -> Pairs
+closePair ps@(_,[]) (Cell bp ep p) = dbg "closePair" $
+       appendToken ps $
+       Cell bp ep $
+       TokenPlain $ snd $ pairBorders p tokensPlainEmpty
+closePair (t,(p1,t1):ts) p = dbg "closePair" $
+       case (p1,p) of
+        (Cell bx _ex (PairElem x ax), Cell _by ey (PairElem y ay)) | x == y ->
+               appendToken (t,ts) $
+               Cell bx ey $
+               TokenPair (PairElem x (ax<>ay)) t1
+        (Cell bx _ex x, Cell _by ey y) | x == y ->
+               appendToken (t,ts) $
+               Cell bx ey $
+               TokenPair x t1
         _ ->
-               closePair p $
-               insertTokens
-                (closeUnpaired mempty (p1,t1))
+               (`closePair` p) $
+               appendTokens
                 (t,ts)
+                (closeUnpaired mempty (p1,t1))
 
 -- | Close a 'Pair' when there is not a matching 'LexemePairClose'.
-closeUnpaired :: Tokens -> (Pair,Tokens) -> Tokens
-closeUnpaired acc (p,tn) = dbg "closeUnpaired" $
+closeUnpaired :: Tokens -> (Cell Pair,Tokens) -> Tokens
+closeUnpaired acc (Cell bp ep p,toks) = dbg "closeUnpaired" $
        case p of
         -- NOTE: try to close 'PairHash' as 'TokenTag' instead of 'TokenPlain'.
-        PairHash | TokenPlain t :< ts <- Seq.viewl $ unTokens $ tn <> acc ->
+        PairHash | (Cell bt et (TokenPlain t)) :< ts <- Seq.viewl $ toks <> acc ->
                case Text.findIndex (not . isTagChar) t of
-                Just 0 -> tokens [TokenPlain $ fst $ pairBorders p mempty] <> tn <> acc
-                Just i -> Tokens $ TokenTag tag <| TokenPlain t' <| ts
+                -- Just 0 -> toksHash mempty <> toks <> acc
+                Just i ->
+                       Cell bp bt{columnPos = columnPos bt + i} (TokenTag tag)
+                        <| Cell bt{columnPos = columnPos bt + i + 1} et (TokenPlain t')
+                        <| ts
                        where (tag,t') = Text.splitAt i t
-                Nothing -> Tokens $ TokenTag t <| ts
-        _ -> tokens [TokenPlain $ fst $ pairBorders p $ tokens [TokenPlain ""]] <> tn <> acc
+                Nothing | Text.null t -> toksHash mempty <> toks <> acc
+                Nothing -> Cell bp et (TokenTag t) <| ts
+        _ -> toksHash tokensPlainEmpty <> toks <> acc
        where
+       toksHash = tokens1 . Cell bp ep . TokenPlain . fst . pairBorders p
        isTagChar c =
                Char.isAlphaNum c ||
                c=='·' ||
@@ -95,217 +104,150 @@ closePairs :: Pairs -> Tokens
 closePairs (t0,ps) = dbg "closePairs" $
        t0 <> foldl' closeUnpaired mempty ps
 
--- * Type 'Lexeme'
-data Lexeme
- =   LexemePairOpen   Pair
- |   LexemePairClose  Pair
- |   LexemePunctOrSym Char
- |   LexemeWhite      Text
- |   LexemeWord       Text
- |   LexemeToken      Tokens
- |   LexemeEscape     Char
- |   LexemeLink       Text
- deriving (Show, Eq)
-
 appendLexeme :: Lexeme -> Pairs -> Pairs
-appendLexeme lex ps =
+appendLexeme lex acc =
        dbg "appendLexeme" $
        case dbg "appendLexeme" lex of
-        LexemePairOpen   p -> openPair p ps
-        LexemePairClose  p -> closePair p ps
-        LexemePunctOrSym c -> insertToken (TokenPlain (Text.singleton c)) ps
-        LexemeWhite wh     -> insertToken (TokenPlain wh) ps
-        LexemeWord  wo     -> insertToken (TokenPlain wo) ps
-        LexemeToken ts     -> insertTokens ts ps
-        LexemeEscape c     -> insertToken (TokenEscape c) ps
-        LexemeLink lnk     -> insertToken (TokenLink lnk) ps
+        LexemePairOpen ps -> foldl' open acc ps
+               where
+               open a p@(Cell _bp ep (PairElem{})) = openPair a p `appendToken` (Cell ep ep $ TokenPlain "")
+               open a p                            = openPair a p
+        LexemePairClose ps -> foldl' closePair acc ps
+        LexemePairAny   ps -> appendTokens acc $ tokens $ ((\p -> TokenPlain $ fst $ pairBorders p mempty) <$>) <$> ps
+        LexemePairBoth  ps -> appendTokens acc $ tokens $ ((`TokenPair`mempty) <$>) <$> ps
+        LexemeEscape     c -> appendToken  acc $ TokenEscape <$> c
+        LexemeLink       t -> appendToken  acc $ TokenLink <$> t
+        LexemeWhite (unCell -> "") -> acc
+        LexemeWhite     cs -> appendToken  acc $ TokenPlain <$> cs
+        LexemeAlphaNum  cs -> appendToken  acc $ TokenPlain . Text.pack <$> cs
+        LexemeAny       cs -> appendToken  acc $ TokenPlain . Text.pack <$> cs
+        LexemeToken     ts -> appendTokens acc ts
 
-appendLexemes :: Pairs -> [Lexeme] -> Pairs
-appendLexemes = foldl' (flip appendLexeme)
-
--- * Parsers
+-- * Type 'Lexeme'
+data Lexeme
+ =   LexemePairOpen  ![Cell Pair]
+ |   LexemePairClose ![Cell Pair]
+ |   LexemePairAny   ![Cell Pair]
+ |   LexemePairBoth  ![Cell Pair]
+ |   LexemeEscape    !(Cell Char)
+ |   LexemeLink      !(Cell Text)
+ |   LexemeWhite     !(Cell White)
+ |   LexemeAlphaNum  !(Cell [Char])
+ |   LexemeAny       !(Cell [Char])
+ |   LexemeToken     !Tokens
+ deriving (Eq, Show)
 
 p_Tokens :: Parser e s Tokens
-p_Tokens = closePairs <$> p_Pairs (mempty,[])
-
-p_Pairs :: Pairs -> Parser e s Pairs
-p_Pairs gs = pdbg "Pairs" $
-       (p_Lexemes (mempty == gs) >>= p_Pairs . appendLexemes gs) <|>
-       (P.eof $> gs)
-
-p_Lexemes :: Bool -> Parser e s [Lexeme]
-p_Lexemes isBOF = pdbg "Lexemes" $
-       P.choice
-        [ P.try $ p_PairCloseWhite
-        , P.try $ p_PairWhiteOpen isBOF
-        , P.try $ p_PairCloseBorder
-        , P.try $ p_PairBorderOpen
-        , P.try $ p_PairClose
-        , P.try $ p_PairOpen
-        , P.try $ pure . LexemePunctOrSym <$> p_PunctOrSym
-        , P.try $ pure <$> p_White
-        , pure . LexemeWord <$> p_Word
-        ]
-
-p_White :: Parser e s Lexeme
-p_White = pdbg "White" $ LexemeWhite <$> p_Spaces
-
-p_PunctOrSym :: Parser e s Char
-p_PunctOrSym =
-       P.satisfy $ \c ->
-               Char.isPunctuation c ||
-               Char.isSymbol c
-
-p_PairCloseWhite :: Parser e s [Lexeme]
-p_PairCloseWhite = pdbg "PairCloseWhite" $
-       (\c b o -> mconcat c <> b <> mconcat o)
-        <$> P.some (P.try $
-               P.try p_ElemOpen  <|>
-               P.try p_ElemClose <|>
-               P.try p_PairClose <|>
-               pure . LexemePunctOrSym <$> p_PunctOrSym)
-        <*> (pure <$> p_White <|> P.eof $> [])
-        <*> P.many (P.try $
-               P.try p_ElemOpen  <|>
-               P.try p_ElemClose <|>
-               P.try p_PairOpen  <|>
-               pure . LexemePunctOrSym <$> p_PunctOrSym)
-
-p_PairWhiteOpen :: Bool -> Parser e s [Lexeme]
-p_PairWhiteOpen isBOF = pdbg "PairWhiteOpen" $
-       (\b o -> b <> mconcat o)
-        <$> (if isBOF then return [] else pure <$> p_White)
-        <*> P.some (P.try $
-               P.try p_ElemOpen  <|>
-               P.try p_ElemClose <|>
-               P.try p_PairOpen  <|>
-               pure . LexemePunctOrSym <$> p_PunctOrSym)
-
-p_PairCloseBorder :: Parser e s [Lexeme]
-p_PairCloseBorder = pdbg "PairCloseBorder" $
-       P.try p0 <|> p1
+p_Tokens = pdbg "Tokens" $
+       closePairs .
+       foldr appendLexeme mempty .
+       dbg "Lexemes" .
+       mangleLexemes .
+       (LexemeWhite (cell0 "") :) <$>
+       go [LexemeWhite (cell0 "")]
        where
-       p0 =
-               (\c b -> mconcat $ c <> b)
-                <$> P.some (P.try p_PairClose)
-                <*> P.some (P.try $
-                       P.choice
-                        [ P.try p_ElemOpen
-                        , P.try p_ElemClose
-                        , do
-                               c <- p_PunctOrSym
-                               case l_PairOpen c <|> l_PairClose c of
-                                Just l -> return [l]
-                                Nothing -> fail "PairCloseBorder"
-                        ])
-       p1 =
-               (\c b -> mconcat c <> [LexemePunctOrSym b])
-                <$> P.some (P.try p_PairClose)
-                <*> p_PunctOrSym
-
-p_PairBorderOpen :: Parser e s [Lexeme]
-p_PairBorderOpen = pdbg "PairBorderOpen" $
-       P.try p0 <|> p1
-       where
-       p0 =
-               (\b o -> mconcat $ b <> o)
-                <$> P.some (P.try $
-                       P.choice
-                        [ P.try p_ElemOpen
-                        , P.try p_ElemClose
-                        , do
-                               c <- p_PunctOrSym
-                               case l_PairOpen c <|> l_PairClose c of
-                                Just l -> return [l]
-                                Nothing -> fail "PairBorderOpen"
-                        ])
-                <*> P.some (P.try p_PairOpen)
-       p1 =
-               (\b o -> LexemePunctOrSym b : mconcat o)
-                <$> p_PunctOrSym
-                <*> P.some (P.try p_PairOpen)
-
-p_PairOpen :: Parser e s [Lexeme]
-p_PairOpen = pdbg "PairOpen" $ do
-       P.choice
-        [ P.try p_ElemOpen
-        , P.try (pure <$> p_Escape)
-        , P.try (pure <$> p_Link)
-        , do
-               c <- p_PunctOrSym
-               case l_PairOpenOrClose LexemePairOpen c of
-                Just l -> return [l]
-                _ -> fail "PairOpen"
-        ]
-
-p_PairClose :: Parser e s [Lexeme]
-p_PairClose = pdbg "PairClose" $ do
+       go :: [Lexeme] -> Parser e s [Lexeme]
+       go acc =
+               (P.eof $> acc) <|>
+               (p_Lexeme >>= \next -> go $ mangleLexemes $ next:acc)
+       
+       mangleLexemes = \case
+        LexemeAny (Cell _bx ex x):LexemeAny (Cell by _ey y):acc -> LexemeAny (Cell by ex (x<>y)):acc
+       
+        -- "   
+        w@LexemeWhite{}:LexemePairAny p:acc -> w:LexemePairClose p:acc
+        --    "
+        LexemePairAny p:w@LexemeWhite{}:acc -> LexemePairOpen p:w:acc
+       
+        --    ,,,"
+        LexemePairAny p:a@LexemeAny{}:w@LexemeWhite{}:acc -> LexemePairOpen p:a:w:acc
+        -- ",,,   
+        w@LexemeWhite{}:a@LexemeAny{}:LexemePairAny p:acc -> w:a:LexemePairClose p:acc
+       
+        -- ",,,AAA
+        an@LexemeAlphaNum{}:a@LexemeAny{}:LexemePairAny p:acc -> an:a:LexemePairClose p:acc
+        -- ,,,"AAA
+        an@LexemeAlphaNum{}:LexemePairAny p:a@LexemeAny{}:acc -> an:LexemePairOpen p:a:acc
+       
+        -- ")
+        c@LexemePairClose{}:LexemePairAny p:acc -> c:LexemePairClose p:acc
+        -- ("
+        LexemePairAny p:o@LexemePairOpen{}:acc -> LexemePairOpen p:o:acc
+       
+        acc -> acc
+
+pairAny :: Char -> Maybe Pair
+pairAny = \case
+ '-'  -> Just PairDash
+ '/'  -> Just PairSlash
+ '"'  -> Just PairDoublequote
+ '\'' -> Just PairSinglequote
+ '`'  -> Just PairBackquote
+ '_'  -> Just PairUnderscore
+ '*'  -> Just PairStar
+ '#'  -> Just PairHash
+ _    -> Nothing
+
+pairOpen :: Char -> Maybe Pair
+pairOpen = \case
+ '('  -> Just PairParen
+ '['  -> Just PairBracket
+ '{'  -> Just PairBrace
+ '«'  -> Just PairFrenchquote
+ _    -> Nothing
+
+pairClose :: Char -> Maybe Pair
+pairClose = \case
+ ')'  -> Just PairParen
+ ']'  -> Just PairBracket
+ '}'  -> Just PairBrace
+ '»'  -> Just PairFrenchquote
+ _    -> Nothing
+
+p_Cell :: Parser e s a -> Parser e s (Cell a)
+p_Cell pa = do
+       bp <- p_Position
+       a  <- pa
+       ep <- p_Position
+       return $ Cell bp ep a
+
+p_Lexeme :: Parser e s Lexeme
+p_Lexeme = pdbg "Lexeme" $
        P.choice
-        [ P.try p_ElemClose
-        , P.try p_ElemSingle
-        , P.try (pure <$> p_Escape)
-        , P.try (pure <$> p_Link)
-        , do
-               c <- p_PunctOrSym
-               case l_PairOpenOrClose LexemePairClose c of
-                Just l -> return [l]
-                _ -> fail "PairClose"
+        [ P.try $ LexemeWhite       <$> p_Cell p_Spaces
+        , P.try $ LexemePairAny     <$> P.some (p_Cell $ p_satisfyMaybe pairAny)
+        , P.try $ LexemePairBoth    <$> P.some (P.try $ p_Cell p_ElemSingle)
+        , P.try $ LexemePairOpen    <$> P.some (p_Cell $ p_satisfyMaybe pairOpen  <|> P.try p_ElemOpen)
+        , P.try $ LexemePairClose   <$> P.some (p_Cell $ p_satisfyMaybe pairClose <|> P.try p_ElemClose)
+        , P.try $ LexemeEscape      <$> p_Cell p_Escape
+        , P.try $ LexemeLink        <$> p_Cell p_Link
+        , P.try $ LexemeAlphaNum    <$> p_Cell (P.some p_AlphaNum)
+        ,         LexemeAny         <$> p_Cell (pure <$> P.anyChar)
         ]
 
-l_PairOpenOrClose :: (Pair -> Lexeme) -> Char -> Maybe Lexeme
-l_PairOpenOrClose lxm c =
-       l_PairOpenAndClose lxm c <|>
-       l_PairOpen c <|>
-       l_PairClose c
-
-l_PairOpenAndClose :: (Pair -> Lexeme) -> Char -> Maybe Lexeme
-l_PairOpenAndClose lxm c =
-       case c of
-        '/'  -> Just $ lxm PairSlash
-        '-'  -> Just $ lxm PairDash
-        '"'  -> Just $ lxm PairDoublequote
-        '\'' -> Just $ lxm PairSinglequote
-        '`'  -> Just $ lxm PairBackquote
-        '_'  -> Just $ lxm PairUnderscore
-        '*'  -> Just $ lxm PairStar
-        '#'  -> Just $ lxm PairHash
-        _    -> Nothing
-
-l_PairOpen :: Char -> Maybe Lexeme
-l_PairOpen c =
-       case c of
-        '('  -> Just $ LexemePairOpen PairParen
-        '['  -> Just $ LexemePairOpen PairBracket
-        '{'  -> Just $ LexemePairOpen PairBrace
-        '«'  -> Just $ LexemePairOpen PairFrenchquote
-        _    -> Nothing
+p_AlphaNum :: Parser e s Char
+p_AlphaNum = P.satisfy Char.isAlphaNum
 
-l_PairClose :: Char -> Maybe Lexeme
-l_PairClose c =
-       case c of
-        ')'  -> Just $ LexemePairClose PairParen
-        ']'  -> Just $ LexemePairClose PairBracket
-        '}'  -> Just $ LexemePairClose PairBrace
-        '»'  -> Just $ LexemePairClose PairFrenchquote
-        _    -> Nothing
+p_Escape :: Parser e s Char
+p_Escape = P.char '\\' *> P.satisfy Char.isPrint
 
-p_Link :: Parser e s Lexeme
+p_Link :: Parser e s Text
 p_Link =
-       (\scheme ss addr -> LexemeLink $ Text.pack $ scheme <> ss <> addr)
+       (\scheme addr -> Text.pack $ scheme <> "//" <> addr)
         <$> P.option "" (P.try p_scheme)
-        <*> P.string "//"
+        <*  P.string "//"
         <*> p_addr
        where
        p_scheme =
-               (<>)
-                <$> P.some (P.try $ P.satisfy $ \c ->
+               (<> ":")
+                <$> P.some (P.satisfy $ \c ->
                        Char.isAlphaNum c
                        || c=='_'
                        || c=='-'
                        || c=='+')
-                <*> P.string ":"
+                <* P.char ':'
        p_addr =
-               P.many $ P.try $
+               P.many $
                        P.satisfy $ \c ->
                                Char.isAlphaNum c
                                || c=='%'
@@ -315,43 +257,37 @@ p_Link =
                                || c=='-'
                                || c=='_'
                                || c=='.'
+                               || c=='#'
+                               || c=='?'
+                               || c=='='
 
-p_Escape :: Parser e s Lexeme
-p_Escape =
-       LexemeEscape
-        <$  P.char '\\'
-        <*> P.satisfy Char.isPrint
-
-p_ElemSingle :: Parser e s [Lexeme]
+p_ElemSingle :: Parser e s Pair
 p_ElemSingle = pdbg "ElemSingle" $
-       (\e as ->
-               [ LexemePairOpen  $ PairElem e as
-               , LexemeToken     $ mempty
-               , LexemePairClose $ PairElem e [] ])
+       PairElem
         <$  P.char '<'
         <*> p_Word
         <*> p_Attrs
         <*  P.string "/>"
 
-p_ElemOpen :: Parser e s [Lexeme]
+p_ElemOpen :: Parser e s Pair
 p_ElemOpen = pdbg "ElemOpen" $
-       (\e as oc ->
-               case oc of
-                True  -> [ LexemePairOpen  $ PairElem e as
-                         , LexemeToken     $ mempty
-                         , LexemePairClose $ PairElem e [] ]
-                False -> [ LexemePairOpen  $ PairElem e as
-                         , LexemeToken     $ tokens [TokenPlain ""]
-                         ])
+       PairElem
         <$  P.char '<'
         <*> p_Word
         <*> p_Attrs
-        <*> P.option False (True <$ P.char '/')
         <*  P.char '>'
 
-p_ElemClose :: Parser e s [Lexeme]
+p_ElemClose :: Parser e s Pair
 p_ElemClose = pdbg "ElemClose" $
-       (\e -> [LexemePairClose $ PairElem e []])
+       (`PairElem` [])
         <$  P.string "</"
         <*> p_Word
         <*  P.char '>'
+
+{-
+p_ElemOpenOrSingle :: Parser e s Pair
+p_ElemOpenOrSingle =
+       p_ElemOpen >>= \p ->
+               P.char    '>' $> LexemePairOpen p <|>
+               P.string "/>" $> LexemePairAny  p
+-}