Add a clean prototype of the classical tree approach

lib/Text/Takkyuu.hs

 module Text.Takkyuu (
+      module Text.Takkyuu.Proto
+    , module Text.Takkyuu.French
+    , module Text.Takkyuu.Visualization
   ) where
 
+import Text.Takkyuu.Proto
+import Text.Takkyuu.Visualization
+import Text.Takkyuu.French

lib/Text/Takkyuu/French.hs

+{-# LANGUAGE NamedFieldPuns #-}
+module Text.Takkyuu.French (
+      POS(..)
+    , Gender(..)
+    , MorphoLabel(..)
+    , french
+    , tag
+    , syntax
+  ) where
+
+import Data.Char (isSpace, toLower)
+import qualified Data.Map as Map (fromList)
+import qualified Data.Set as Set (fromList)
+import Text.Takkyuu.Proto (Game, Labeled(..), Label(..), dico, labelizer, rules)
+
+data POS =
+    Determiner
+  | Noun
+  | Particip
+  deriving (Eq, Ord, Show)
+
+data Gender =
+    Masculine
+  | Feminine
+  deriving (Eq, Ord, Show)
+
+data Number =
+    Singular
+  | Plural
+  deriving (Eq, Ord, Show)
+
+data MorphoLabel = MorphoLabel {
+      pos :: POS
+    , gender :: Gender
+    , number :: Number
+  }
+  deriving (Eq, Ord, Show)
+
+type LabeledWord = Labeled String MorphoLabel
+
+french :: Game Char -> Game String
+french = dico id isSpace $ Set.fromList ["le", "la", "chat", "lait", "marché"]
+
+tag :: Game String -> Game LabeledWord
+tag = labelizer (fmap toLower) $ Map.fromList [
+      ("le",
+        [MorphoLabel {pos = Determiner, gender = Masculine, number = Singular}])
+    , ("la",
+        [MorphoLabel {pos = Determiner, gender = Feminine, number = Singular}])
+    , ("les", [
+            MorphoLabel {pos = Determiner, gender = Masculine, number = Plural}
+          , MorphoLabel {pos = Determiner, gender = Feminine, number = Plural}
+        ])
+    , ("chat", [MorphoLabel {pos = Noun, gender = Masculine, number = Singular}])
+    , ("lait", [MorphoLabel {pos = Noun, gender = Masculine, number = Singular}])
+    , ("marché", [
+            MorphoLabel {pos = Noun, gender = Masculine, number = Singular}
+          , MorphoLabel {pos = Particip, gender = Masculine, number = Singular}
+        ])
+  ]
+
+syntax :: Game LabeledWord -> Game [LabeledWord]
+syntax = rules label . Set.fromList $ agreeSn <$> combinations
+  where
+    combinations = [(g, n) | g <- [Masculine, Feminine], n <- [Singular, Plural]]
+    agreeSn (gender, number) = [
+          Label $ MorphoLabel {pos = Determiner, gender, number}
+        , Label $ MorphoLabel {pos = Noun, gender, number}
+      ]

lib/Text/Takkyuu/Proto.hs

+{-# LANGUAGE NamedFieldPuns #-}
+module Text.Takkyuu.Proto (
+      Game(..)
+    , Label(..)
+    , Labeled(..)
+    , game
+    , oneOf
+    , fuzz
+    , keep
+    , ignore
+    , dico
+    , labelizer
+    , fixTypo
+    , rules
+  ) where
+
+import Control.Applicative (Alternative(..))
+import Data.Map (Map, findWithDefault, insertWith)
+import qualified Data.Map as Map (empty, lookup)
+import Data.Set as Set (Set)
+import qualified Data.Set as Set (empty, fromList, member)
+
+data Game a =
+    Over Bool
+  | On {
+          token :: a
+        , next :: Game a
+        , fallback :: Game a
+      }
+  deriving Show
+
+instance Semigroup (Game a) where
+  Over True <> g = g
+  o@(Over False) <> _ = o
+  o <> g = o {
+        next = next o <> g
+      , fallback = fallback o <> g
+    }
+
+instance Monoid (Game a) where
+  mempty = Over True
+
+instance Functor Game where
+  fmap _  (Over b) = Over b
+  fmap f o = o {
+        token = f $ token o
+      , next = f <$> next o
+      , fallback = f <$> fallback o
+    }
+
+instance Applicative Game where
+  pure token = On {
+        token
+      , next = mempty
+      , fallback = empty
+    }
+
+  Over b <*> _ = Over b
+  _ <*> Over b = Over b
+  f <*> g = On {
+        token = (token f) (token g)
+      , next = (next f) <*> (next g)
+      , fallback = (fallback f) <*> (fallback g)
+    }
+
+instance Alternative Game where
+  empty = Over False
+  Over False <|> g = g
+  o@(Over True) <|> _ = o
+  o <|> g = o {
+      fallback = fallback o <|> g
+    }
+
+instance Monad Game where
+  Over b >>= _ = Over b
+  o >>= f = (f (token o) <> ((next o) >>= f)) <|> ((fallback o) >>= f)
+
+game :: [a] -> Game a
+game = foldr ((<>) . pure) mempty
+
+oneOf :: [a] -> Game a
+oneOf = foldr ((<|>) . pure) empty
+
+fuzz :: (Eq a, Ord a) => Set [a] -> Game a -> Game a
+fuzz classes = (>>= alternatives)
+  where
+    alternatives t = oneOf (findWithDefault [t] t equiv)
+    equiv = foldl (\tmp0 l ->
+        foldl (\tmp1 x -> 
+            insertWith (++) x l tmp1
+          ) tmp0 l
+      ) Map.empty classes
+
+data Label l =
+    Unknown
+  | Label l
+  deriving (Eq, Ord, Show)
+
+data Labeled a l = Labeled {
+      item :: a
+    , label :: Label l
+  }
+  deriving (Eq, Ord, Show)
+
+
+keep :: (a -> Bool) -> Game a -> Game a
+keep predicate = (>>= select)
+  where
+    select a
+      | predicate a = pure a
+      | otherwise = Over False
+
+ignore :: (a -> Bool) -> Game a -> Game a
+ignore p = keep (not . p)
+
+dico :: (Eq k, Ord k) => (a -> k) -> (k -> Bool) -> Set [k] -> Game a -> Game [a]
+dico projector isBlank vocabulary = continueFrom start
+  where
+    start = ([], vocabulary)
+    continueFrom (stack@(_:_), candidates) (Over True)
+      | not $ Set.member [] candidates = pure (reverse stack)
+    continueFrom _ (Over b) = Over b
+    continueFrom state@(stack, candidates) (On {token, next, fallback})
+      | isBlank (projector token) =
+            ((if null stack || Set.member [] candidates then empty else pure (reverse stack))
+            <> continueFrom start next)
+          <|> continueFrom state next
+          <|> continueFrom state fallback
+      | otherwise =
+        let projection = projector token in
+        let newCandidates = foldMap (startingWith projection) candidates in
+        case (null newCandidates, Set.member [] newCandidates) of
+          (True, _) -> continueFrom state fallback <|> continueFrom (token:stack, newCandidates) next
+          (_, False) -> continueFrom (token:stack, newCandidates) next
+                      <|> continueFrom state fallback
+          _ -> (pure (reverse $ token:stack) <> continueFrom start next)
+              <|> continueFrom (token:stack, newCandidates) next
+              <|> continueFrom state fallback
+    startingWith e (x:xs) = Set.fromList $ if e == x then [xs] else []
+    startingWith _ [] = Set.empty
+
+rules :: (Eq k, Ord k) => (a -> k) -> Set [k] -> Game a -> Game [a]
+rules projector vocabulary = continueFrom start
+  where
+    start = ([], vocabulary)
+    continueFrom _ (Over b) = Over b
+    continueFrom state@(stack, candidates) (On {token, next, fallback}) =
+      let projection = projector token in
+      let newCandidates = foldMap (startingWith projection) candidates in
+      case (null newCandidates, Set.member [] newCandidates) of
+        (True, _) -> continueFrom state fallback
+        (_, False) -> continueFrom (token:stack, newCandidates) next
+                    <|> continueFrom state fallback
+        _ -> (pure (reverse $ token:stack) <> continueFrom start next)
+            <|> continueFrom (token:stack, newCandidates) next
+            <|> continueFrom state fallback
+    startingWith e (x:xs) = Set.fromList $ if e == x then [xs] else []
+    startingWith _ [] = Set.empty
+
+labelizer :: Ord k => (a -> k) -> (Map k [b]) -> Game a -> Game (Labeled a b)
+labelizer projector labels = (>>= alternatives)
+  where
+    alternatives t =
+      let possibleLabels = Map.lookup (projector t) labels in
+      oneOf $  maybe [Labeled t Unknown] (Labeled t . Label <$>) possibleLabels
+
+fixTypo :: Game Char -> Game Char
+fixTypo = fuzz $ Set.fromList [
+      "bh"
+    , "il1"
+  ]

lib/Text/Takkyuu/Visualization.hs

+{-# LANGUAGE NamedFieldPuns #-}
+module Text.Takkyuu.Visualization (
+      dump
+    , explore
+    , render
+  ) where
+
+import Text.Takkyuu.Proto (Game(..))
+import Text.Printf (printf)
+
+data Tree a =
+    Leaf Bool
+  | Tree {
+      unTree :: [(a, Tree a)]
+    }
+  deriving Show
+
+explore :: Game a -> Tree a
+explore (Over b) = Leaf b
+explore (On {token, next, fallback}) =
+  case explore fallback of
+    Leaf _ -> Tree [(token, explore next)]
+    Tree l -> Tree $ (token, explore next):l
+
+dump :: Show a => Tree a -> String
+dump = unlines . dumpAux
+  where
+    dumpAux (Leaf b) = [if b then "o" else "x"]
+    dumpAux (Tree l) = l >>= f
+    f (a, tree) = printf "%s — %s" (show a) <$> dumpAux tree
+
+render :: Show a => Game a -> IO ()
+render = putStr . dump . explore

takkyuu.cabal

@@ -19,13 +19,15 @@ extra-source-files:  CHANGELOG.md
 
 library
   exposed-modules:     Text.Takkyuu
-                     , Text.Takkyuu.Data
-                     , Text.Takkyuu.IO
-  -- other-modules:
+  other-modules:       Text.Takkyuu.French
+                     , Text.Takkyuu.Proto
+                     , Text.Takkyuu.Visualization
   -- other-extensions:
   build-depends:       base >=4.14 && <4.15
+                     , containers >=0.6 && <0.7
   hs-source-dirs:      lib
   default-language:    Haskell2010
+  ghc-options:         -Wall
 
 executable takkyuu
   main-is:             Main.hs