{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}

module Language.Pronunciation where

import Control.Applicative (Alternative (..))
import Control.Monad.Combinators qualified as P
import Control.Monad.Trans.Class qualified as MT
import Control.Monad.Trans.State qualified as MT
import Data.List qualified as List
import Data.List.Zipper qualified as LZ
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Text.Short qualified as TextShort
import Data.Traversable (traverse)
import Language
import Paths_worksheets qualified as Self
import System.FilePath.Posix ((</>))
import System.FilePath.Posix qualified as File
import Text.Blaze.Html5.Attributes qualified as HA
import Text.Megaparsec qualified as P
import Worksheets.Utils.Char qualified as Char
import Worksheets.Utils.HTML (className, classes, styles, (!))
import Worksheets.Utils.HTML qualified as HTML
import Worksheets.Utils.IPA qualified as IPA
import Worksheets.Utils.Paper qualified as Paper
import Worksheets.Utils.Prelude

data Pronunciation = Pronunciation
  { pronunciationIPABroad :: [IPA.Syllable []]
  , pronunciationText :: Text
  }
  deriving (Eq, Ord, Show)
instance Semigroup Pronunciation where
  x <> y =
    Pronunciation
      { pronunciationIPABroad = pronunciationIPABroad x <> pronunciationIPABroad y
      , pronunciationText =
          [pronunciationText x, pronunciationText y]
            & List.filter (/= "")
            & Text.intercalate "."
      }
instance IsList Pronunciation where
  type Item Pronunciation = IPA.Syllable []
  toList = pronunciationIPABroad

  -- fromList :: HasCallStack => [Item Pronunciation] -> Pronunciation
  fromList l =
    Pronunciation
      { pronunciationIPABroad = ipa
      , pronunciationText = ipa & foldMap (IPA.toIPA >>> maybe "" IPA.unIPA)
      }
    where
      ipa =
        l
          & mapButLast (IPA.WithSuprasegmentalFeature IPA.Break)
          & fromList
instance IsString Pronunciation where
  fromString s =
    Pronunciation
      { pronunciationIPABroad = ipa
      , pronunciationText = ipa & foldMap (IPA.toIPA_ >>> IPA.unIPA)
      }
    where
      ipa =
        s
          & Text.pack
          & IPA.parseSyllables @[]
          & either errorShow id

{-
data PronunciationKey = PronunciationKey
  { pronunciationKeyText :: Text
  , pronunciationKeyPron :: Pronunciation
  , pronunciationKey
  }
-}

newtype Pronunciations = Pronunciations
  { unPronunciations :: [(RuleLexemes, Pronunciation)]
  }
  deriving (Eq, Ord)
  deriving newtype (Show)
  deriving newtype (Semigroup)
  deriving newtype (Monoid)
joinPronunciations :: Pronunciations -> Pronunciations
joinPronunciations (Pronunciations ps) =
  Pronunciations
    [ input :=
        Pronunciation
          { pronunciationIPABroad = ipa
          , pronunciationText = ipa & foldMap (IPA.toIPA >>> maybe "" IPA.unIPA)
          }
    ]
  where
    input :: RuleLexemes
    ipa :: [IPA.Syllable []]
    (input, ipa) =
      ps
        & List.foldr
          ( \(inp, Pronunciation{pronunciationIPABroad}) (suffix, l, acc) ->
              case pronunciationIPABroad of
                [] -> (inp <> suffix, IPA.Syllable [], acc)
                [syl@(IPA.Syllable [])] -> (inp <> suffix, syl, acc)
                [syl] -> (inp <> suffix, IPA.Syllable [], (syl <> l) : acc)
                [sylL, sylR] -> (inp <> suffix, sylL, glueSyllableToTheRight sylR acc)
                _ -> errorShow pronunciationIPABroad
          )
          ( ""
          , IPA.Syllable []
          , []
          )
        & ( \(i, l, acc) ->
              ( i
              , glueSyllableToTheRight l acc
                  & mapButLast (IPA.setSuprasegmentalFeatures [IPA.Break])
              )
          )
    glueSyllableToTheRight ::
      IPA.Syllable [] ->
      [IPA.Syllable []] ->
      [IPA.Syllable []]
    glueSyllableToTheRight x y =
      case y of
        [] -> [x]
        [yL] -> [x <> yL]
        yL : yR -> x <> yL : yR
instance IsList Pronunciations where
  type Item Pronunciations = (RuleLexemes, Pronunciation)
  toList = unPronunciations
  fromList l = Pronunciations{unPronunciations = l & fromList}

{-
instance IsString Pronunciations where
  fromString = \case
    "" -> Pronunciations "" [IPA.Syllable [IPA.Zero]]
    s -> Pronunciations (s & Text.pack) $
          fromString s
            & IPA.parseSyllables @[]
            & either errorShow id
-}
data ExampleLiteral = ExampleLiteral
  { exampleLiteralText :: ShortText
  , exampleLiteralTags :: Set LiteralTag
  , exampleLiteralMeaning :: ShortText
  }
  deriving (Eq, Ord, Show)
instance IsString ExampleLiteral where
  fromString s =
    ExampleLiteral
      { exampleLiteralText = s & fromString
      , exampleLiteralTags = Set.empty
      , exampleLiteralMeaning = ""
      }
data LiteralTag
  = LiteralTagOccurence
  | LiteralTagMeta
  | LiteralTagSilent
  deriving (Eq, Ord, Show)
exampleLiteralsText :: [ExampleLiteral] -> ShortText
exampleLiteralsText ls = ls <&> exampleLiteralText & mconcat

hyphen =
  ExampleLiteral
    { exampleLiteralText = "-"
    , exampleLiteralTags = [LiteralTagMeta] & Set.fromList
    , exampleLiteralMeaning = ""
    }
occurence lit = lit{exampleLiteralTags = lit & exampleLiteralTags & Set.insert LiteralTagOccurence}
silent lit = lit{exampleLiteralTags = lit & exampleLiteralTags & Set.insert LiteralTagSilent}

type SyllableText = ShortText
type SyllableBroad = IPA.Syllable []
type SyllablesTable = Map SyllableText (Map SyllableText [([ExampleLiteral], SyllableBroad)])

data Adjacent
  = AdjacentBorder
  | AdjacentVowel
  | AdjacentConsonant
  deriving (Eq, Ord, Show)
data Variant
  = VariantDefinition Text
  | VariantStress
  deriving (Eq, Ord, Show)
data Rule = Rule
  { -- , ruleStress :: Bool
    -- , ruleDefinition :: Maybe Text

    -- [ "e"    := ["ɛ"] , "x"    := ["g","z"] , "er"   := ["ɛʁ"] , "cice" := ["sis"] ]
    -- [ "exercice" := ["ɛg.zɛʁ.sis"]
    -- ]
    rulePron :: Pronunciations
  , ruleExamples :: Map InputLexemes Pronunciation
  }
  deriving (Eq, Ord, Show)

rule =
  Rule
    { rulePron = Pronunciations{unPronunciations = []}
    , ruleExamples = mempty
    }
space = rule
word
  , begining
  , ending ::
    RuleLexemes -> RuleLexemes
word = begining >>> ending
begining = after [LexemeBorder]
ending = before [LexemeBorder]
before ls r = RuleLexemes (unRuleLexemes r <> ls)
after ls r = RuleLexemes (ls <> unRuleLexemes r)
meaning r d = RuleLexemes (unRuleLexemes r <> [LexemeMeaning d])

type Table = Map RuleLexemes Rule
examples :: Table -> Map InputLexemes Pronunciation
examples tbl =
  [ v & ruleExamples
  | v <- tbl & Map.elems
  ]
    & Map.unionsWith (\new old -> if new == old then new else errorShow (new, old))

data Pron = Pron
  { pronInput :: [Lexeme]
  , pronRule :: Rule
  }
  deriving (Eq, Show)

data Syl = Syl
  { sylText :: Text
  , sylDependsOnBefore :: Bool
  , sylDependsOnAfter :: Bool
  , sylDependsOnMeaning :: Bool
  , sylSound :: Text -- [IPA.Syllable []]
  , sylIndex :: Int
  , sylSilent :: Bool
  , sylSplit :: Bool
  }

addIndexes :: [[Either Char Pron]] -> [[Syl]]
addIndexes = go 0
  where
    go _idx [] = []
    go idx (prons : next) = List.reverse prons' : go idx' next
      where
        (idx', prons') =
          prons
            & List.foldl'
              ( \(i, is) -> \case
                  Left c ->
                    ( i
                    , Syl
                        { sylText = Text.singleton c
                        , sylDependsOnAfter = False
                        , sylDependsOnBefore = False
                        , sylDependsOnMeaning = False
                        , sylSound = []
                        , sylIndex = i
                        , sylSilent = True
                        , sylSplit = False
                        }
                        : is
                    )
                  Right Pron{pronRule = Rule{rulePron = Pronunciations{unPronunciations = ps}}} ->
                    ps
                      & List.foldl'
                        ( \(j, js) (t, Pronunciation{..}) ->
                            let sylText = t & unRuleLexemes & lexemesChars & Text.pack
                            in case pronunciationIPABroad of
                                []
                                  | not (Text.null pronunciationText) ->
                                      ( j + 1
                                      , Syl
                                          { sylText
                                          , sylSound = pronunciationText
                                          , sylDependsOnBefore = t & unRuleLexemes & sylDependsOnBefore
                                          , sylDependsOnAfter = t & unRuleLexemes & sylDependsOnAfter
                                          , sylDependsOnMeaning = t & unRuleLexemes & sylDependsOnMeaning
                                          , sylIndex = j + 1
                                          , sylSilent = False
                                          , sylSplit = False
                                          }
                                          : js
                                      )
                                [IPA.Syllable []]
                                  | Text.null pronunciationText ->
                                      ( j
                                      , case js of
                                          [] ->
                                            Syl
                                              { sylText
                                              , sylDependsOnBefore = t & unRuleLexemes & sylDependsOnBefore
                                              , sylDependsOnAfter = t & unRuleLexemes & sylDependsOnAfter
                                              , sylDependsOnMeaning = t & unRuleLexemes & sylDependsOnMeaning
                                              , sylSound = ""
                                              , sylIndex = j
                                              , sylSilent = True
                                              , sylSplit = False
                                              }
                                              : js
                                          j0@Syl{sylText = j0t} : jss -> j0{sylText = j0t <> sylText} : jss
                                      )
                                syls
                                  | (syls & all IPA.isSilent) && Text.null pronunciationText ->
                                      ( j
                                      , Syl
                                          { sylText
                                          , sylDependsOnBefore = t & unRuleLexemes & sylDependsOnBefore
                                          , sylDependsOnAfter = t & unRuleLexemes & sylDependsOnAfter
                                          , sylDependsOnMeaning = t & unRuleLexemes & sylDependsOnMeaning
                                          , sylSound = ""
                                          , sylIndex = j
                                          , sylSilent = True
                                          , sylSplit = False
                                          }
                                          : js
                                      )
                                _syls@[_] ->
                                  ( j + 1
                                  , Syl
                                      { sylText
                                      , sylDependsOnBefore = t & unRuleLexemes & sylDependsOnBefore
                                      , sylDependsOnAfter = t & unRuleLexemes & sylDependsOnAfter
                                      , sylDependsOnMeaning = t & unRuleLexemes & sylDependsOnMeaning
                                      , sylSound = pronunciationText
                                      , sylIndex = j + 1
                                      , sylSilent = False
                                      , sylSplit = False
                                      }
                                      : js
                                  )
                                _syls@[_, _] ->
                                  ( j
                                  , Syl
                                      { sylText
                                      , sylDependsOnBefore = t & unRuleLexemes & sylDependsOnBefore
                                      , sylDependsOnAfter = t & unRuleLexemes & sylDependsOnAfter
                                      , sylDependsOnMeaning = t & unRuleLexemes & sylDependsOnMeaning
                                      , sylSound = pronunciationText
                                      , sylIndex = j
                                      , sylSilent = False
                                      , sylSplit = True
                                      }
                                      : js
                                  )
                                syls -> errorShow syls
                        )
                        (i, is)
                    where
                      sylDependsOnAfter =
                        List.reverse >>> \case
                          LexemeBorder : _ -> True
                          LexemeSilent : _ -> True
                          LexemeConsonant : _ -> True
                          LexemeDoubleConsonant : _ -> True
                          LexemeVowel : _ -> True
                          LexemeSemiVowel : _ -> True
                          _ -> False
                      sylDependsOnBefore =
                        \case
                          LexemeBorder : _ -> True
                          LexemeSilent : _ -> True
                          LexemeConsonant : _ -> True
                          LexemeDoubleConsonant : _ -> True
                          LexemeVowel : _ -> True
                          LexemeSemiVowel : _ -> True
                          _ -> False
                      sylDependsOnMeaning =
                        List.reverse >>> \case
                          LexemeMeaning{} : _ -> True
                          _ -> False
              )
              (idx, [])

withCapital :: [(RuleLexemes, Rule)] -> [(RuleLexemes, Rule)]
withCapital =
  foldMap \(RuleLexemes pat, rul) ->
    [ (RuleLexemes pat, rul)
    ,
      ( RuleLexemes (withCapitalLexemes pat)
      , rul
          { rulePron = rul & rulePron & withCapitalPronunciations
          , ruleExamples =
              rul
                & ruleExamples
                & Map.mapKeys
                  ( unInputLexemes
                      >>> withCapitalLexemes
                      >>> InputLexemes
                  )
          }
      )
    ]
  where
    withCapitalPronunciations (Pronunciations []) = Pronunciations []
    withCapitalPronunciations (Pronunciations ((t, p) : ps)) =
      Pronunciations ((RuleLexemes $ withCapitalLexemes $ unRuleLexemes t, p) : ps)
    withCapitalLexemes (LexemeChar x : xs) = LexemeChar (Char.toUpper x) : xs
    withCapitalLexemes (x : xs) = x : withCapitalLexemes xs
    withCapitalLexemes [] = []

lexemesChars :: [Lexeme] -> [Char]
lexemesChars p =
  p & foldMap \case
    LexemeChar c -> [c]
    _ -> []

run ::
  Table ->
  Text ->
  Either
    ( Either
        (P.ParseErrorBundle Text ())
        (P.ParseErrorBundle [Lexeme] ())
    )
    [Either Char Pron]
run rules inp =
  inp
    & runLexer
    & either (Left . Left) \lexs ->
      lexs
        & runParser rules
        & either (Left . Right) Right

runParser :: Table -> [Lexeme] -> Either (P.ParseErrorBundle [Lexeme] ()) [Either Char Pron]
runParser tbl inp = inp & P.runParser (parser tbl) "input"

parseLiterals ::
  Table ->
  [ExampleLiteral] ->
  Either
    ( Either
        (P.ParseErrorBundle Text ())
        (P.ParseErrorBundle [Lexeme] ())
    )
    [Either Char Pron]
parseLiterals rules inp =
  inp
    & traverse
      ( \ExampleLiteral{..} ->
          exampleLiteralText
            & TextShort.toText
            & runLexer
            <&> ( <>
                    [ LexemeMeaning exampleLiteralMeaning
                    | exampleLiteralMeaning & TextShort.null & not
                    ]
                )
      )
    & either (Left . Left) \lexs ->
      lexs
        & mconcat
        & runParser rules
        & either (Left . Right) Right

parser :: Table -> P.Parsec () [Lexeme] [Either Char Pron]
parser tbl = do
  res <- P.many $ (Just . Right) <$> parseRules <|> parseChar
  P.eof
  return $ res & catMaybes
  where
    -- Match one of the rules, trying longuest first
    parseRules :: P.Parsec () [Lexeme] Pron
    parseRules =
      P.choice
        [ parseRule r
        | r <- tbl & Map.toDescList
        ]
    {-
    <|> P.choice
      [ parseRule
        ( RuleLexemes $
            rulePat & unRuleLexemes <&> \case
              LexemeChar c -> LexemeChar (c & Char.toUpper)
              x -> x
        , curRule
        )
      | (rulePat, curRule) <- tbl & Map.toDescList
      ]
    -}
    parseRule (rulePat, curRule@Rule{..}) =
      P.try do
        let
          pat = rulePat & unRuleLexemes
          patSep = (`List.elem` list [LexemeVowel, LexemeSemiVowel, LexemeConsonant, LexemeSilent])
          -- (patEnd, patBegin) = pat & List.reverse & List.span patSep
          patBegin = pat & List.dropWhileEnd patSep
          patEnd = pat & List.reverse & List.takeWhile patSep & List.reverse
        -- parse without the ending Lexeme{Vowel,SemiVowel,Consonant}
        P.chunk patBegin
        inpAfterBegin <- P.getInput
        unless (List.null patEnd) do
          inpWithAhead <- parseAhead
          -- traceShowM ("inpWithAhead"::Text, inpWithAhead)
          P.setInput inpWithAhead
          P.chunk patEnd & void
        -- insert the Lexeme{Vowel,SemiVowel,Consonant} from the output of the current rule
        let lastSound =
              rulePron
                & unPronunciations
                & List.reverse
                & headMaybe
                & maybe
                  []
                  ( snd
                      >>> pronunciationIPABroad
                      >>> List.reverse
                      >>> headMaybe
                      >>> maybe [] (IPA.syllableToSegments >>> List.reverse >>> lexemeHeadSound)
                  )
        P.setInput $ lastSound <> inpAfterBegin
        return Pron{pronInput = pat, pronRule = curRule}
    parseChar :: P.Parsec () [Lexeme] (Maybe (Either Char Pron))
    parseChar =
      P.anySingle <&> \case
        LexemeChar c -> Just $ Left c
        _ -> Nothing
    parseAhead :: P.Parsec () [Lexeme] [Lexeme]
    parseAhead = do
      nextStep <- P.observing $ Right <$> parseRules <|> Left <$> P.anySingle
      -- traceShowM ("nextStep"::Text, nextStep & either (\err -> Left ()) Right)
      case nextStep of
        Right (Right Pron{pronInput, pronRule}) -> do
          let x =
                pronRule
                  & rulePron
                  & unPronunciations
                  & headMaybe
                  & maybe
                    []
                    ( snd
                        >>> pronunciationIPABroad
                        >>> headMaybe
                        >>> maybe [] (IPA.syllableToSegments >>> lexemeHeadSound)
                    )
          inp <- P.getInput
          return $ x <> pronInput <> inp
        Right (Left lex) -> do
          parseAhead <&> (lex :)
        Left{} -> P.getInput
    lexemeHeadSound :: [_] -> [Lexeme]
    lexemeHeadSound =
      headMaybe >>> fmap IPA.dropSegmentalFeatures >>> \case
        Just IPA.Zero{} -> [LexemeSilent]
        Just IPA.Vowel{} -> [LexemeVowel]
        Just (IPA.Consonant consonant) -> do
          case consonant of
            IPA.Pulmonic _phonation _place IPA.Approximant -> [LexemeSemiVowel]
            IPA.Ejective _place IPA.Approximant -> [LexemeSemiVowel]
            _ -> [LexemeConsonant]
        _ -> [] -- error

runLexer :: Text -> Either (P.ParseErrorBundle Text ()) [Lexeme]
runLexer inp = inp & P.runParser lexer "input"

exampleLiteralsLexemes :: [ExampleLiteral] -> [Lexeme]
exampleLiteralsLexemes ls =
  ls & foldMap \ExampleLiteral{..} ->
    unRuleLexemes (fromString (TextShort.unpack exampleLiteralText))
      <> [ LexemeMeaning exampleLiteralMeaning
         ]

lexer :: P.Parsec () Text [Lexeme]
lexer = do
  lls <- P.many do
    P.choice $
      list
        [ P.takeWhile1P Nothing Char.isSpace >>= \cs ->
            return [LexemeChar c | c <- cs & Text.unpack]
        , do
            cs <- P.takeWhile1P Nothing Char.isLetter
            mean <- (<|> return []) $ P.try do
              P.single '{'
              m <- P.takeWhile1P Nothing (/= '}')
              P.single '}'
              return [LexemeMeaning (TextShort.fromText m)]
            return $
              LexemeBorder
                : [LexemeChar c | c <- cs & Text.unpack]
                  <> mean
                  <> [LexemeBorder]
        , P.takeWhile1P Nothing Char.isNumber >>= \cs ->
            return (LexemeBorder : ([LexemeChar c | c <- cs & Text.unpack] <> [LexemeBorder]))
        , P.satisfy Char.isSymbol >>= \c ->
            return [LexemeChar c]
        , P.satisfy Char.isSeparator >>= \c ->
            return [LexemeChar c]
        , P.satisfy Char.isMark >>= \c ->
            return [LexemeChar c]
        , P.satisfy Char.isPunctuation >>= \c ->
            return [LexemeChar c]
        ]
  P.eof
  return $ mconcat lls

words :: [Either Char Pron] -> [[Either Char Pron]]
words [] = []
words prons = word0 : words next
  where
    (word0, rest) = prons & List.span (isSep >>> not)
    (_sep, next) = rest & List.span isSep
    isSep = \case
      Left c | c & Char.isSpace -> True
      _ -> False


{-
case statePats st & Map.lookup k of
  Nothing -> st
  Just (PatTree pats) ->
    loop st {statePats = pats, stateBuffer = k : stateBuffer st}
  Just (PatEnd end) ->
    loop st { statePats = initPats
       , stateBuffer = []
       , stateInput = stateInput st
           & LZ.insert Inp
              { inpPats = stateBuffer st & List.reverse
              , inpPronunciations = end
              }
           & LZ.right
       }
-}

{-
parse :: PatTree -> Text -> [Inp]
parse initPats input =
  let inpZip = input & Text.unpack & fmap charToInp & LZ.fromList in
  runInp [] initPats inpZip & LZ.toList
  where
  charToInp :: Char -> Inp
  charToInp c = Inp
    { inpPats = [PosNext (PatternChar c)]
    , inpPronunciations = []
    }
  runInp :: [Pos] -> PatTree -> LZ.Zipper Inp -> LZ.Zipper Inp
  runInp oks pat inp =
    traceShow ("runInp"::Text, ("oks"::Text) := oks, ("cur"::Text) := LZ.safeCursor inp) $
    case pat of
      PatEnd end ->
        -- the pattern ends
        inp
        & LZ.insert Inp
          { inpPats = oks & List.reverse
          , inpPronunciations = end
          }
        & LZ.right
        & runInp [] initPats
      PatTree pats ->
        -- the pattern may go on
        case inp & LZ.safeCursor of
          Nothing ->
            inp
              & runPat [] oks [PosNext PatternLexicalBorder] pats
          Just cur ->
            inp & LZ.delete
                & runPat [] oks (inpPats cur & List.sort) pats

  runPat :: [Pos] -> [Pos] -> [Pos] -> Map Pos PatTree -> LZ.Zipper Inp -> LZ.Zipper Inp
  runPat kos oks todos pats inp =
    traceShow ( "runPat"::Text
              , ("kos"::Text) := kos
              , ("oks"::Text) := oks
              , ("todos"::Text) := todos
              , ("cur"::Text) :=LZ.safeCursor inp
              ) $
    case todos of
      [] | LZ.endp inp -> inp
        & runInp kos (PatEnd [])
        & runInp oks (PatEnd [])
      [] ->
        -- nothing left to advance the pattern
        --traceShow ("runPat/[]"::Text) $
          inp
            & (if null kos then id else runInp kos (PatEnd []))
            & runInp oks (PatTree pats)
      k:ks ->
        case pats & Map.lookup k of
          -- the pattern ends
          Just (PatEnd end) ->
            --traceShow ("runPat/End"::Text) $
            -- ks forgotten
            inp
              & (if null kos then id else runInp kos (PatEnd []))
              & runInp (k:oks) (PatEnd end)
          -- the pattern advances
          Just (PatTree nextPats) ->
            --traceShow ("runPat/Node"::Text) $
            inp & runPat kos (k:oks) ks nextPats
          -- the pattern does not advance
          Nothing ->
            inp & runPat (k:kos) oks ks pats
-}


data Lexeme
  = LexemeBorder
  | LexemeVowel
  | LexemeSemiVowel
  | LexemeConsonant
  | LexemeDoubleConsonant
  | LexemeSilent
  | LexemeMeaning ShortText
  | -- | `LexemeChar` is last to have priority when using `Map.toDescList`
    LexemeChar Char
  deriving (Eq, Ord, Show)

-- data Sound
--   = SoundVowel
--   | SoundConsonant
--   deriving (Eq, Ord, Show)

{-
newtype Lexemes = Lexemes { unLexemes :: [Lexeme] }
  deriving (Eq, Ord, Show)
instance P.Stream Lexemes where
  type Token Lexemes = Lexeme
  type Tokens Lexemes = Lexemes
  tokensToChunk _px = Lexemes
  chunkToTokens _px = unLexemes
  chunkLength _px = unLexemes >>> List.length
  chunkEmpty _px = unLexemes >>> List.null
  take1_ = unLexemes >>> P.take1_ >>> coerce
  takeN_ n = unLexemes >>> P.takeN_ n >>> coerce
  takeWhile_ p = unLexemes >>> P.takeWhile_ p >>> coerce

instance IsString Lexemes where
  fromString s =
    s
      & Text.pack
      & runLexer
      & either
          errorShow
          ((`appEndo` []) >>> Lexemes)
-}

newtype RuleLexemes = RuleLexemes {unRuleLexemes :: [Lexeme]}
  deriving (Eq, Ord, Show)
instance HasTypeDefault RuleLexemes where
  typeDefault = RuleLexemes typeDefault
instance Semigroup RuleLexemes where
  RuleLexemes x <> RuleLexemes y = RuleLexemes (x <> y)
instance Monoid RuleLexemes where
  mempty = RuleLexemes mempty
instance IsList RuleLexemes where
  type Item RuleLexemes = Lexeme
  fromList = RuleLexemes
  toList = unRuleLexemes
instance IsString RuleLexemes where
  fromString s =
    s
      & Text.pack
      & runLexer
      & either
        errorShow
        ( List.dropWhileEnd (== LexemeBorder)
            >>> List.dropWhile (== LexemeBorder)
            >>> RuleLexemes
        )

newtype InputLexemes = InputLexemes {unInputLexemes :: [Lexeme]}
  deriving (Eq, Ord, Show)
instance HasTypeDefault InputLexemes where
  typeDefault = InputLexemes typeDefault
instance Semigroup InputLexemes where
  InputLexemes x <> InputLexemes y = InputLexemes (x <> y)
instance Monoid InputLexemes where
  mempty = InputLexemes mempty
instance IsList InputLexemes where
  type Item InputLexemes = Lexeme
  fromList = InputLexemes
  toList = unInputLexemes
instance IsString InputLexemes where
  fromString s =
    s
      & Text.pack
      & runLexer
      & either errorShow InputLexemes

instance P.ShowErrorComponent () where
  showErrorComponent = show
  errorComponentLen _ = 2
instance P.VisualStream [Lexeme] where
  showTokens _s = show
  tokensLength _s xs = xs <&> (show >>> List.length) & sum
instance P.TraversableStream [Lexeme] where
  reachOffset off pos = (Nothing, pos{P.pstateOffset = P.pstateOffset pos + off})

data LexemeTag
  = LexemeTagLetter
  | LexemeTagSpace
  | LexemeTagPunctuation
  | LexemeTagSeparator
  | LexemeTagMark
  | LexemeTagSymbol
  | LexemeTagDefinition
  | LexemeTagBorder
  deriving (Eq, Ord, Show)
deriving instance Ord (IPA.Syllable [])
deriving instance Ord IPA.SuprasegmentalFeature
deriving instance Ord IPA.SegmentalFeature
deriving instance Ord IPA.Sibilance
deriving instance Ord IPA.Manner
deriving instance Ord IPA.Phonation
deriving instance Ord IPA.Roundedness
deriving instance Ord IPA.Height
deriving instance Ord IPA.Vowel
deriving instance Ord IPA.Consonant
deriving instance Ord IPA.Segment

{-
tableToMatch :: Table -> [Lexeme] -> [Pronunciations]
tableToMatch tbl = loop
  where
  loop prevBorder = \case
    InputText inp ->
      [ (matchingLength, )
      | (trans, transMach) <- chunk & chunkMachine & machineAlts & Map.toList
      , let matchingLength = transMatchingLength input trans
      , 0 < matchingLength || not (isTransConsume trans)
      , let (inputRead, inputRest) = input & Text.splitAt matchingLength
      ]
        & Map.fromListWith (\new old -> old)
        & Map.lookupMax
        <&> snd

-}
tableHtml :: Table -> IO HTML.Html
tableHtml tbl = do
  dataPath <- Self.getDataDir <&> File.normalise
  let title :: String = "LexerDict"
  let pageOrientation = Paper.PageOrientationPortrait
  let pageSize = Paper.PageSizeA4
  let partLangue = LangueFrançais
  return do
    HTML.docTypeHtml do
      HTML.head do
        HTML.title $ title & HTML.toHtml
        forM_
          ( [ "styles/Paper.css"
            , "styles/French/Lexer.css"
            , "styles/Rosetta/Reading.css"
            ]
              & list
          )
          \cssFile ->
            HTML.link
              ! HA.rel "stylesheet"
              ! HA.type_ "text/css"
              ! HA.href (dataPath </> cssFile & HTML.toValue)
        HTML.styleCSS $ HTML.cssPrintPage pageOrientation pageSize
      -- HTML.styleCSS $ pageDifficulties & difficultyCSS
      HTML.body
        ! classes ["A4", "french-lexer"]
        $ do
          "\n"
          let rulesChunks = tbl & Map.toList & chunksOf 50
          forM_ rulesChunks \rules ->
            HTML.section
              ! classes
                [ "sheet"
                ]
              ! styles
                []
              $ do
                forM_ (rules & List.zip [1 :: Int ..]) \(ruleIndex, (rulePat, Rule{..})) -> do
                  "\n"
                  HTML.div
                    ! classes
                      [ "dict-entry"
                      , if even ruleIndex then "even" else "odd"
                      ]
                    ! styles
                      []
                    $ do
                      "\n"
                      HTML.div
                        ! classes
                          [ "dict-key"
                          , "lang-" <> className partLangue
                          ]
                        ! styles
                          []
                        -- "grid-template-columns" :=
                        --  (0.5 & cm & HTML.toCSS)
                        --    & List.replicate lexerDictMaxKeyLength
                        --    & List.unwords

                        $ do
                          forM_ (["model"] :: [String]) \rowKind -> do
                            forM_ (rulePat & unRuleLexemes) \ruleChar -> do
                              -- let uniScript = cellToken & tokenMeta & snd & fromMaybe (UnicodeBlockLatin UnicodeBlockLatin_Basic)
                              case ruleChar of
                                LexemeChar c -> do
                                  HTML.span
                                    ! classes
                                      [ "dict-key-cell"
                                      , rowKind
                                      -- , "script-" <> className uniScript
                                      ]
                                    $ do
                                      c & HTML.toHtml
                                _ -> ""
                      HTML.div
                        ! classes
                          [ "dict-pronunciation"
                          ]
                        $ do
                          -- HTML.span ! classes ["arrow"] $ "→"
                          case rulePron of
                            Pronunciations
                              { unPronunciations =
                                all (snd >>> pronunciationIPABroad >>> all IPA.isSilent) -> True
                              } -> ""
                            Pronunciations{unPronunciations = is} ->
                              is
                                & foldMap (snd >>> pronunciationIPABroad >>> foldMap (IPA.toIPA_ >>> IPA.transcribe IPA.Phonemic))
                                & HTML.toHtml
                      HTML.div
                        ! classes
                          [ "dict-lexeme"
                          ]
                        $ do
                          -- HTML.span ! classes ["arrow"] $ "→"
                          forM_ (ruleExamples & Map.toList) \(_inp, Pronunciation{..}) -> do
                            HTML.span
                              ! classes
                                []
                              $ do
                                case pronunciationIPABroad of
                                  [] -> pronunciationText & HTML.toHtml
                                  _ -> pronunciationIPABroad & foldMap (IPA.toIPA_ >>> IPA.transcribe IPA.Phonemic) & HTML.toHtml
                            "; "