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

module Language.Pronunciation where

import Control.Applicative (asum)
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Text.Lazy qualified as TextLazy
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 Worksheets.Utils.Char qualified as Char
import Worksheets.Utils.HTML (className, classes, cm, 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
import Prelude (error)

-- import Data.Radix1Tree.Word8.Key.Unsafe qualified as RT
-- import Data.Radix1Tree.Word8.Strict qualified as RT

-- import Data.List.Split qualified as Split

-- radixFromList :: [(Text, a)] -> RT.Radix1Tree a
-- radixFromList = foldr (\(k, a) p -> RT.insert (RT.unsafeFeedText k) a p) RT.empty

data Pronunciation = PronunciationIPABroad
  { pronunciationText :: Text
  , pronunciationIPA :: IPA.Syllable []
  }
  deriving (Eq, Ord, Show)
instance IsString Pronunciation where
  fromString = \case
    "" -> PronunciationIPABroad "" $ IPA.Syllable []
    s -> PronunciationIPABroad (s & Text.pack) $ fromString s

data Lexeme = Lexeme
  { lexemeKey :: Text
  , -- , lexemeNext :: Text
    lexemePron :: Pronunciation
  }
  deriving (Eq, Show, Generic)

data LexemePron = LexemePron
  { lexemePronunciation :: Pronunciation
  , lexemeExample :: [Literal]
  }
  deriving (Eq, Show)

data Literal = Literal
  { literalText :: ShortText
  , literalTags :: Set LiteralTag
  }
  deriving (Eq, Ord, Show)
instance IsString Literal where
  fromString s =
    Literal
      { literalText = s & fromString
      , literalTags = Set.empty
      }
data LiteralTag
  = LiteralTagOccurence
  | LiteralTagMeta
  | LiteralTagSilent
  deriving (Eq, Ord, Show)

hyphen =
  Literal
    { literalText = "-"
    , literalTags = [LiteralTagMeta] & Set.fromList
    }
occurence lit = lit{literalTags = lit & literalTags & Set.insert LiteralTagOccurence}
silent lit = lit{literalTags = lit & literalTags & Set.insert LiteralTagSilent}

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

type ContextToLexemePron = (LexemePron, Map (IPA.Syllable []) LexemePron)
data Machine = Machine
  { machinePron :: Maybe Pronunciation
  , machineExample :: Set [Literal]
  , machineAlts :: Map Trans Machine
  -- ^ Those 'Machine's must not be recursive.
  }
  deriving (Eq, Show)
machine =
  Machine
    { machinePron = Nothing
    , machineExample = Set.empty
    , machineAlts = Map.empty
    }

{-
instance Monoid Machine where
  mempty = Machine
    { machinePron = ""
    , machineExample = []
    , machineAlts = Map.empty
    }
instance Semigroup Machine where
  x <> y = Machine
    { machinePron = if machinePron x == machinePron y
                    then machinePron x
                    else errorShow (machinePron x, machinePron y)
    , machineExample = machineExample x <> machineExample y
    , machineAlts = Map.unionWith (<>) (machineAlts x) (machineAlts y)
    }
-}
machineExamples :: Machine -> Set [Literal]
machineExamples mach =
  machineAlts mach
    & foldMap machineExamples
    & Set.union (machineExample mach)

data Input
  = InputChar
  | InputBorder
  | Input

data Chunk = Chunk
  { chunkInterval :: [Trans]
  , chunkInputNext :: [Char]
  , chunkMachine :: Machine
  }
  deriving (Eq, Show, Generic)

chunkText :: Chunk -> Text
chunkText Chunk{chunkInterval} =
  chunkInterval
    & List.foldl'
      ( \acc -> \case
          TransConsume (ObservChar c) -> c : acc
          _ -> acc
      )
      []
    & Text.pack

chunkPronunciation :: Chunk -> Text
chunkPronunciation Chunk{chunkMachine} =
  chunkMachine
    & machinePron
    & maybe "" pronunciationText

chunksWords :: [Chunk] -> [[Chunk]]
chunksWords [] = []
chunksWords chks = word0 : chunksWords next
  where
    (word0, rest) = chks & List.span (isSep >>> not)
    (_sep, next) = rest & List.span isSep
    isSep chk = chk & chunkInterval & List.elem (TransConsume ObservSpace)

inputToObservs :: Text -> [Observ]
inputToObservs t = ObservBorder : Text.foldr (\c acc -> ObservChar c : acc) [ObservBorder] t

data State
  = StateBorder
  | StateNonBorder

transChunk :: Trans -> Chunk -> Maybe Chunk
transChunk obs chunk = do
  nextMachine <- chunk & chunkMachine & machineAlts & Map.lookup trans
  Chunk
    { chunkMachine = nextMachine
    , chunkInterval = trans : chunkInterval chunk
    , chunkInputNext = chunkInputNext chunk
    }

borderChunk chunk =
  chunk
    & transChunk (TransLookAhead ObservBorder)

readChunk :: Bool -> Chunk -> Maybe Chunk
readChunk isBorder chunk =
  case chunk & chunkInputNext of
    [] | not isBorder -> chunk & borderChunk >>= readChunk False
       | otherwise -> Just chunk
    i:is ->
      | not isBorder && or [Char.isSpace i, ]

{-
consumeChar :: State -> Chunk -> Maybe Chunk
consumeChar st chunk = Nothing
  | st == StateBorder = (chunk, [])
  , otherwise = chunk & advanceChunk ObservBorder
consumeChar (c:cs) chunk
  | st == StateBorder = 
  Char
  case ob of
    ObservBorder
      | Just nextMach <- jumps & Map.lookup (TransLookAhead ObservBorder) ->
          Just Chunk
            { chunkInputNext = obs
            , chunkMachine = nextMach
            , chunkInterval = TransLookAhead ObservBorder : chunkInterval chunk
            }
    ObservChar c
      | Just nextMach <- jumps & Map.lookup (ObservChar c) ->
          Just Chunk
            { chunkInputNext = obs
            , chunkMachine = nextMach
            , chunkInterval = TransConsume ob : chunkInterval chunk
            }
      | Char.isSpace c
      , Just nextMach <- jumps & Map.lookup ObservSpace ->
          Just Chunk
            { chunkInputNext = obs
            , chunkMachine = nextMach
            , chunkInterval = TransConsume ob : chunkInterval chunk
            }
      | Char.isPunctuation c
      , Just nextMach <- jumps & Map.lookup ObservPunctuation ->
          Just Chunk
            { chunkInputNext = obs
            , chunkMachine = nextMach
            , chunkInterval = TransConsume ob : chunkInterval chunk
            }
  where
  jumps = chunk & chunkMachine & machineAlts
  piorities :: [Observ]
  piorities=
    TransConsume ob :
    TransLookAhead ob :
    case ob of
      ObservChar c ->
        [ TransConsume o | o <- obsClasses ]
        [ TransLookAhead o | o <- obsClasses ]
        where
        obsClasses =
          mconcat
            [ [ObservSpace | Char.isSpace c]
            , [ObservPunctuation | Char.isPunctuation c]
            , [ObservMark | Char.isMark c]
            , [ObservSymbol | Char.isSymbol c]
            , [ObservSeparator | Char.isSeparator c]
            ]
-}

runMachine :: Machine -> Text -> Either ([Trans], Text) [Chunk]
runMachine machInit = inputToObservs >>> loop True [] initChunk
  where
    initChunk inp =
      Chunk
        { chunkInterval = []
        , chunkInputNext = inp
        , chunkMachine = machInit
        }
    loop :: Bool -> [Chunk] -> Chunk -> [Observ] -> Either ([Trans], Text) [Chunk]
    loop isInit prevChunks chunk currentInput =
      -- traceShow ("runMachine.loop" :: Text, isInit, chunk{chunkMachine = Machine "" [] []}, currentInput) $
      if null currentInput
        then Right [chunk & chunkUpdateBehind prevChunks & chunkUpdateAhead []]
        else
          case chunk & updateChunkWithInput currentInput of
            Just (newChunk, inputNext) -> loop False prevChunks newChunk inputNext
            Nothing
              | isInit -> Left (chunk & chunkInterval, currentInput & Text.take 10)
              | otherwise -> do
                  -- Reset the machine to process the next chunk
                  nextChunks <- loop True (chunk : prevChunks) (initChunk currentInput) currentInput
                  Right $ (chunk & chunkUpdateBehind prevChunks & chunkUpdateAhead nextChunks) : nextChunks

updateChunkWithInput :: Text -> Chunk -> Maybe (Chunk, Text)
updateChunkWithInput input chunk =
  -- traceShow ("updateChunkWithInput" :: Text, chunk{chunkMachine = Machine "" [] []}) $
  [ (matchingLength, (newChunk, inputRest))
  | (trans, transMach) <- chunk & chunkMachine & machineAlts & Map.toList
  , let matchingLength = transMatchingLength input trans
  , 0 < matchingLength || not (isTransConsume trans)
  , -- , transMach & machinePron & isJust
  let (inputRead, inputRest) = input & Text.splitAt matchingLength
  , let newChunk =
          Chunk
            { -- chunkText = chunkText chunk <> inputRead
              chunkMachine = transMach
            , chunkInterval = trans : chunkInterval chunk
            }
  ]
    & Map.fromListWith (\new old -> old)
    & Map.lookupMax
    <&> snd
  where
    transMatchingLength :: Text -> Trans -> Int
    transMatchingLength inp = \case
      TransConsume obs ->
        case obs of
          ObservChar prefix
            | Text.isPrefixOf prefix inp -> Text.length prefix
            | Text.isPrefixOf prefix (inp & Text.take (Text.length prefix) & Text.toLower) -> Text.length prefix
            | otherwise -> 0
          ObservSpace
            | Just (c0, _) <- Text.uncons inp
            , Char.isSpace c0 ->
                1
            | otherwise -> 0
          ObservPunctuation
            | Just (c0, _) <- Text.uncons inp
            , Char.isPunctuation c0 ->
                1
            | otherwise -> 0
          ObservMark
            | Just (c0, _) <- Text.uncons inp
            , Char.isMark c0 ->
                1
            | otherwise -> 0
          ObservNumber
            | Just (c0, _) <- Text.uncons inp
            , Char.isNumber c0 ->
                1
            | otherwise -> 0
          ObservSeparator
            | Just (c0, _) <- Text.uncons inp
            , Char.isSeparator c0 ->
                1
            | otherwise -> 0
          ObservSymbol
            | Just (c0, _) <- Text.uncons inp
            , Char.isSymbol c0 ->
                1
            | otherwise -> 0
          _ -> 0
      _ -> 0

-- transNextOrId :: Trans -> Machine -> Machine
-- transNextOrId trans mach = mach & machineAlts & Map.findWithDefault mach trans
filterTransConsume = List.filter (\case TransConsume{} -> True; _ -> False)
isTransConsume = \case
  TransConsume{} -> True
  _ -> False
applyTrans :: Trans -> Chunk -> Chunk
applyTrans trans chunk =
  case chunk & chunkMachine & machineAlts & Map.lookup trans of
    Nothing -> chunk
    Just nextMachine ->
      -- \| Nothing <- nextMachine & machinePron -> chunk
      -- \| otherwise ->
      chunk
        { chunkMachine = nextMachine
        , chunkInterval = trans : chunkInterval chunk
        -- , chunkText = chunkText chunk
        }
applyTransSeq :: [Trans] -> Chunk -> Chunk
applyTransSeq [] chunk = chunk
applyTransSeq (t : ts) chunk = chunk & applyTrans t & applyTransSeq ts

chunkUpdateAhead :: [Chunk] -> Chunk -> Chunk
chunkUpdateAhead aheadChunks chunk =
  -- traceShow ("chunkUpdateAhead"::Text, chunk & chunkText, aheadObservs) $
  chunk & applyTransSeq [TransLookAhead x | x <- mconcat aheadObservs]
  where
    aheadObservs :: [[Observ]]
    aheadObservs =
      [ -- specific observation
        case aheadChunks of
          Chunk{chunkInterval = List.reverse . filterTransConsume -> TransConsume obs : _} : _ -> [obs]
          _ -> []
      , -- border observation
        case aheadChunks of
          Chunk{chunkInterval = List.reverse . filterTransConsume -> TransConsume obs : _} : _ ->
            case obs of
              ObservSpace -> [ObservBorder]
              ObservNumber -> [ObservBorder]
              ObservMark -> [ObservBorder]
              ObservPunctuation -> [ObservBorder]
              _ -> []
          [] -> [ObservBorder]
          _ -> []
      , -- vowel/semivowel/consonant observation
        case aheadChunks of
          Chunk{chunkMachine = Machine{machinePron = Just PronunciationIPABroad{pronunciationIPA = IPA.syllableToSegments -> seg : _}}} : _ ->
            case seg of
              IPA.Vowel{} -> [ObservVowel]
              IPA.Consonant (IPA.Pulmonic _phonation _place IPA.Approximant) -> [ObservSemiVowel]
              IPA.Consonant (IPA.Ejective _place IPA.Approximant) -> [ObservSemiVowel]
              _ -> [ObservConsonant]
          _ -> []
      ]

chunkUpdateBehind :: [Chunk] -> Chunk -> Chunk
chunkUpdateBehind behindChunks chunk =
  -- traceShow ("chunkUpdateBehind"::Text, chunk & chunkText, behindObservs, behindChunks <&> chunkText) $
  chunk & applyTransSeq [TransLookBehind x | x <- mconcat behindObservs]
  where
    behindObservs :: [[Observ]]
    behindObservs =
      [ -- specific observation
        case behindChunks of
          Chunk{chunkInterval = filterTransConsume -> TransConsume obs : _} : _ -> [obs]
          _ -> []
      , -- border observation
        case behindChunks of
          Chunk{chunkInterval = filterTransConsume -> TransConsume obs : _} : _ ->
            case obs of
              ObservSpace -> [ObservBorder]
              ObservNumber -> [ObservBorder]
              ObservMark -> [ObservBorder]
              ObservPunctuation -> [ObservBorder]
              _ -> []
          [] -> [ObservBorder]
          _ -> []
      , -- vowel/semivowel/consonant observation
        case behindChunks of
          Chunk{chunkMachine = Machine{machinePron = Just PronunciationIPABroad{pronunciationIPA = IPA.syllableToSegments >>> List.reverse -> seg : _}}} : _ ->
            case seg of
              IPA.Vowel{} -> [ObservVowel]
              IPA.Consonant (IPA.Pulmonic _phonation _place IPA.Approximant) -> [ObservSemiVowel]
              IPA.Consonant (IPA.Ejective _place IPA.Approximant) -> [ObservSemiVowel]
              _ -> [ObservConsonant]
          _ -> []
      ]

-- planète
data Trans
  = TransConsume Observ
  | TransLookAhead Observ
  | TransLookBehind Observ
  | TransDefinition Text
  deriving (Eq, Ord, Show)
data Observ
  = ObservChar Char
  | ObservConsonant
  | ObservSemiVowel
  | ObservVowel
  | ObservLetter
  | ObservMark
  | ObservNumber
  | ObservPunctuation
  | ObservSeparator
  | ObservSpace
  | ObservSymbol
  | ObservBorder
  deriving (Eq, Ord, Show)
instance IsString [Trans] where
  fromString = fmap (TransConsume . ObservChar)

data LexerDict = LexerDict
  { lexerDictMap :: Map Text (Map PronContext LexemePron)
  , lexerDictMaxKeyLength :: Int
  }

{-
contextToLexemePron :: [(Text, ContextToLexemePron)] -> [(Text, LexemePron)]
contextToLexemePron =
  foldr
    (
      \(key, (defLex, nextTolex))
      acc@((nextKey,nextLex):as) ->
      Map.findWithDefault defLex nextLex nextToLex:acc
    ) []
-}

borderLeftChar = '⌟'
borderRightChar = '⌞'
borderLeftText = borderLeftChar & Text.singleton
borderRightText = borderRightChar & Text.singleton
borderInnerText = borderRightText <> borderLeftText

{-
mapLookupLonguest :: Text -> LexerDict -> Maybe Lexeme
mapLookupLonguest inp LexerDict{..} =
  [ lexerDictMap & Map.lookup (key & Text.toLower)
                 & maybeToList
                 & foldMap \nextToVariant ->
      let nextMax :: Int =
            nextToVariant & Map.keys
                          <&> Text.length
                          & Set.fromList
                          & Set.lookupMax
                          & fromMaybe (error "empty map")
            in
        [ nextToVariant & Map.lookup (next & Text.toLower)
                        <&> (\variant -> Lexeme{lexemeKey=key, lexemeNext=next, lexemePron=variant & lexemePronunciation})
                        & maybeToList
        | next <- inp & Text.drop (key & Text.length)
                      & Text.take nextMax
                      & Text.inits
                      & List.reverse
        ] & mconcat
  | key <- inp & Text.take lexerDictMaxKeyLength
               & Text.inits
               & List.reverse
  , not $ Text.null key
  ]
    & mconcat
    & headMaybe
-}

lexerInit :: Text -> Text
lexerInit input =
  borderLeftText <> innerInput <> borderRightText
  where
    innerInput = input & Text.replace " " borderInnerText

type LexerError = (Text, [Text])

data PronContext
  = PronContextStressed
  | PronContextUnstressed
  | PronContextBeforeBorder
  | PronContextBeforeAnyVowel
  | -- | Aka. semi-vowels
    PronContextBeforeAnySemiVowel
  | PronContextBeforeAnyConsonant
  | PronContextBeforeAny
  | PronContextBeforeSegment IPA.Segment
  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

lexer :: LexerDict -> Text -> Either LexerError [Lexeme]
lexer dict input = input & lexerInit & splitChunks <&> foldChunks
  where
    nextChunk :: Text -> Maybe (Text, Map PronContext LexemePron)
    nextChunk inp =
      [ dict & lexerDictMap & Map.lookup (key & Text.toLower) <&> (key,) & maybeToList
      | key <-
          inp
            & Text.take (dict & lexerDictMaxKeyLength)
            & Text.inits
            & List.reverse
      , not $ Text.null key
      ]
        & mconcat
        & headMaybe
    splitChunks :: Text -> Either LexerError [(Text, Map PronContext LexemePron)]
    splitChunks inp =
      inp
        & nextChunk
        & \case
          Nothing -> Left (inp, keys)
            where
              keys =
                inp
                  & Text.take (dict & lexerDictMaxKeyLength)
                  & Text.inits
                  & List.reverse
          Just kv@(key, _contextToVariant)
            | otherwise ->
                if Text.null inpNext
                  then Right [kv]
                  else case splitChunks inpNext of
                    Left (rest, keys) -> Left (rest, keys)
                    Right res' -> Right (kv : res')
            where
              inpNext = inp & Text.drop (Text.length key)
    dropZeros :: [Lexeme] -> [Lexeme]
    dropZeros = List.dropWhile \case
      Lexeme{lexemePron = PronunciationIPABroad{pronunciationIPA = IPA.Syllable [IPA.Zero{}]}} -> True
      _ -> False
    foldChunks :: [(Text, Map PronContext LexemePron)] -> [Lexeme]
    foldChunks =
      foldr
        ( \(chunk, contextToVariant) afters ->
            (: afters) $
              fromMaybe (Lexeme chunk $ PronunciationIPABroad "" (IPA.Syllable [IPA.Zero])) $
                asum $
                  list
                    [ case afters of
                        [] -> Nothing
                        Lexeme{lexemeKey} : _ ->
                          case lexemeKey & Text.unpack of
                            c : _cs
                              | c & Char.isAlphaNum & not ->
                                  contextToVariant
                                    & Map.lookup PronContextBeforeBorder
                                    <&> \LexemePron{lexemePronunciation} -> Lexeme chunk lexemePronunciation
                            _ -> Nothing
                    , case afters & dropZeros of
                        [] -> Nothing
                        Lexeme{lexemePron = PronunciationIPABroad{pronunciationIPA = pron}} : _ ->
                          case pron & IPA.syllableToSegments of
                            seg : _
                              | Just LexemePron{lexemePronunciation} <-
                                  contextToVariant & Map.lookup (PronContextBeforeSegment seg) ->
                                  Just $ Lexeme chunk lexemePronunciation
                            IPA.Vowel{} : _ ->
                              contextToVariant
                                & Map.lookup PronContextBeforeAnyVowel
                                <&> \LexemePron{lexemePronunciation} -> Lexeme chunk lexemePronunciation
                            IPA.Consonant consonant : _ ->
                              case consonant of
                                IPA.Pulmonic _phonation _place IPA.Approximant ->
                                  contextToVariant
                                    & Map.lookup PronContextBeforeAnySemiVowel
                                    <&> \LexemePron{lexemePronunciation} -> Lexeme chunk lexemePronunciation
                                IPA.Ejective _place IPA.Approximant ->
                                  contextToVariant
                                    & Map.lookup PronContextBeforeAnySemiVowel
                                    <&> \LexemePron{lexemePronunciation} -> Lexeme chunk lexemePronunciation
                                _ ->
                                  contextToVariant
                                    & Map.lookup PronContextBeforeAnyConsonant
                                    <&> \LexemePron{lexemePronunciation} -> Lexeme chunk lexemePronunciation
                            _ -> Nothing
                    , contextToVariant
                        & Map.lookup PronContextBeforeAny
                        <&> \LexemePron{lexemePronunciation} -> Lexeme chunk lexemePronunciation
                    ]
        )
        []

lexerDict lexerDictMap =
  LexerDict
    { lexerDictMap
    , lexerDictMaxKeyLength =
        lexerDictMap
          & Map.keys
          <&> Text.length
          & Set.fromList
          & Set.lookupMax
          & fromMaybe (error "empty map")
    }

lexerPron :: LexerDict -> Text -> Either LexerError [(Text, Text)]
lexerPron dict inp =
  inp
    & lexer dict
    <&> foldMap
      ( \Lexeme{..} ->
          lexemePron & \case
            PronunciationIPABroad txt (IPA.Syllable [IPA.Zero]) -> [(lexemeKey, txt)]
            PronunciationIPABroad txt _ipa -> [(lexemeKey, txt)]
      )

data FrenchToken = FrenchToken
  { tokenText :: Text
  , tokenSound :: Text
  }

lexerChunks :: LexerDict -> Text -> Either LexerError [FrenchToken]
lexerChunks dict inp =
  inp
    & lexer dict
    <&> foldMap
      ( \Lexeme{..} ->
          lexemePron & \case
            PronunciationIPABroad{pronunciationIPA = IPA.Syllable [IPA.Zero]} -> [FrenchToken lexemeKey ""]
            PronunciationIPABroad{pronunciationText} -> [FrenchToken lexemeKey pronunciationText]
      )

groupLexemes :: [Lexeme] -> [[Lexeme]]
groupLexemes ls =
  ls -- & Split.split ( Split.whenElt (\(t, _) -> t == "\n") & Split.dropDelims)
    & group
  where
    group :: [Lexeme] -> [[Lexeme]]
    group [] = []
    -- group (inpHead@("\n", lex) : inpTail) =
    group (inpHead : inpTail) =
      if inpHead & lexemeKey & Text.isPrefixOf borderLeftText
        then
          ( let (seps, rest) = inpTail & List.span \l -> not $ l & lexemeKey & Text.isPrefixOf borderLeftText
            in (inpHead : seps) : group rest
          )
        else error "groupLexemes"

pronunciation :: LexerDict -> [Either Lexeme Text] -> [[Lexeme]]
pronunciation dict ts =
  [ case lexOrText of
    Left lex -> [lex]
    Right txt ->
      txt
        & lexer dict
        & either (error . TextLazy.unpack . pShow) id
        -- & List.intercalate [("\n", LexemePron{lexemePronunciation=PronunciationSilent, lexemeExample=[]})]
      where

  | -- lines = txt & Text.split (== '\n')
  lexOrText <- ts
  ]
    & mconcat
    & groupLexemes

lexerWords dict =
  [ (word, word & lexerPron dict)
  | word <-
      [ "poule"
      ]
  ]

-- 1|de,ʁə,ʁe,ʁa
{-
syllablesTable :: SyllablesTable
syllablesTable =
  [ "b" :=
      [ "a" := ["ba" := "ba"]
      , "e" := ["ber" := "bɛʁ", "be" := "bə", "be" := "bɛ"]
      , "é" := ["bé" := "be"]
      ]
  ]
-}
-- 1|de,ʁə,ʁe,ʁa
-- 2|ʁa,li,a,ti,ʁɛ,zə,ɑ̃
-- 3|ɑ̃,ni,ʁi,ka,e,ze,ʁɔ̃,ta,te,si,za
-- 4|za,to,ma,na,di,mi,kɔ̃,kɔ,o,sjɔ̃,tə,la,pa,ne
-- 5|ne,i,fi,se,bi,də,ɔ,ɛ̃,sje,ʁje,me,nə,ʁjɔ̃,mɑ̃,le,tɔ,lɔ,pi,ba,vi,zɑ̃

syllablesTableToHTML :: SyllablesTable -> IO HTML.Html
syllablesTableToHTML sylInitToSylFinalToPhon = do
  -- FIXME: this absolute path is not portable out of my system
  dataPath <- Self.getDataDir <&> File.normalise
  return do
    -- let pageOrientation = Paper.PageOrientationLandscape
    -- let pageSize = Paper.PageSizeA4
    HTML.docTypeHtml do
      HTML.head do
        HTML.title $ "Syllabes"
        forM_
          ( [ "Paper.css"
          -- , "SyllableTable.css"
            ]
              & list
          )
          \cssFile ->
            HTML.link
              ! HA.rel "stylesheet"
              ! HA.type_ "text/css"
              ! HA.href (dataPath </> "styles" </> cssFile & HTML.toValue)
      -- HTML.styleCSS $ HTML.cssPrintPage pageOrientation pageSize
      let sylInits = sylInitToSylFinalToPhon & Map.keysSet
      let sylFinals = sylInitToSylFinalToPhon & Map.elems & foldMap Map.keysSet
      HTML.body ! classes ["A4"] $ do
        "\n"
        forM_ ([1 :: Int .. 3] & list) \page ->
          HTML.section
            ! classes ["sheet"]
            $ do
              HTML.article do
                "test" <> show page & HTML.toHtml

{-
HTML.div
  ! classes ["main-page"]
  $ do
    HTML.div
      ! classes
        [ "syllable-table"
        , "sub-page"
        , "page-" <> className pageSize <> "-" <> className pageOrientation
        ]
      ! styles
        [ "grid-template-columns" := (1 & fr & HTML.toCSS) & List.replicate (1 + Set.size sylFinals) & List.unwords
        ]
      $ do
        forM_ sylFinals \sylFinal -> do
          HTML.div do
            sylFinal & HTML.toHtml
        forM_ sylFinals \sylFinal -> do
          forM_ (sylInitToSylFinalToPhon & Map.toList) \(sylInit, sylFinalToPhon) -> do
            HTML.div do
              sylInit & HTML.toHtml
              forM_ sylFinals \sylFinal -> do
                HTML.div do
                  forM_ (sylFinalToPhon & Map.lookup sylFinal & fromMaybe []) \phons -> do
                    phons & show & HTML.toHtml
-}

data PronDictKey = PronDictKey Text
  deriving (Eq)
instance Ord PronDictKey where
  PronDictKey x `compare` PronDictKey y =
    compare (Down $ Text.length x) (Down $ Text.length y)
      <> compare x y


ful, pre, suf, inf :: Text -> [Text]
ful t =
  [ borderLeftText <> t <> borderRightText
  , borderLeftText <> t <> "'"
  , "'" <> t <> borderRightText
  , borderLeftText <> t <> "-"
  , "-" <> t <> borderRightText
  ]
pre t = [borderLeftText <> t, "-" <> t, "'" <> t]
suf t = [t <> borderRightText, t <> "-", t <> "'", t <> ",", t <> "."]
inf t = [t]