Importing prototype for sequential implementation + and choose detailed-0.9 testing

lib/Text/Takkyuu.hs

 module Text.Takkyuu (
-      module Text.Takkyuu.Proto
-    , module Text.Takkyuu.French
-    , module Text.Takkyuu.Visualization
+      module Text.Takkyuu.Internal
+    , module Text.Takkyuu.IO
+    , module Text.Takkyuu.NLP
+    , module Text.Takkyuu.Protocol
+    , module Text.Takkyuu.Toolbox
   ) where
 
-import Text.Takkyuu.Proto
-import Text.Takkyuu.Visualization
-import Text.Takkyuu.French
+import Text.Takkyuu.Internal
+import Text.Takkyuu.IO
+import Text.Takkyuu.NLP
+import Text.Takkyuu.Protocol
+import Text.Takkyuu.Toolbox

lib/Text/Takkyuu/Data.hs

-{-# LANGUAGE NamedFieldPuns #-}
-module Text.Takkyuu.Data (
-  ) where
-
-data Move a =
-    Here a
-  | Back
-
-data Reply a =
-    Ok
-  | No
-
-data Round a =
-    Over Bool
-  | On {
-        move :: Move a
-      , next :: Reply a -> Round a
-    }
-
-fromList :: [a] -> Round a
-fromList [] = Over True
-fromList (a:as) = On {
-      move = Here a
-    , next
-  }
-  where
-    next Ok = fromList as
-    next _ = Over False

lib/Text/Takkyuu/French.hs

@@ -8,10 +8,11 @@ module Text.Takkyuu.French (
     , syntax
   ) where
 
+import Control.Monad.IO.Class (MonadIO(..))
 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)
+import Text.Takkyuu (Game, Label(..), Labeled(..), dico, labelizer, rules)
 
 data POS =
     Determiner
@@ -38,10 +39,10 @@ data MorphoLabel = MorphoLabel {
 
 type LabeledWord = Labeled String MorphoLabel
 
-french :: Game Char -> Game String
-french = dico id isSpace $ Set.fromList ["le", "la", "chat", "lait", "marché"]
+french:: MonadIO m => Game Char String m
+french = dico toLower isSpace $ Set.fromList ["le", "la", "chat", "lait", "marché"]
 
-tag :: Game String -> Game LabeledWord
+tag :: Game String [LabeledWord] m
 tag = labelizer (fmap toLower) $ Map.fromList [
       ("le",
         [MorphoLabel {pos = Determiner, gender = Masculine, number = Singular}])
@@ -59,7 +60,7 @@ tag = labelizer (fmap toLower) $ Map.fromList [
         ])
   ]
 
-syntax :: Game LabeledWord -> Game [LabeledWord]
+syntax :: Game LabeledWord [LabeledWord] m
 syntax = rules label . Set.fromList $ agreeSn <$> combinations
   where
     combinations = [(g, n) | g <- [Masculine, Feminine], n <- [Singular, Plural]]

lib/Text/Takkyuu/IO.hs

 module Text.Takkyuu.IO (
-      fromHandle
+      display
+    , debug
+    , fromHandle
     , toHandle
   ) where
 
-import Text.Takkyuu.Data (Round(..))
+import Control.Monad.IO.Class (MonadIO(..))
+import System.IO (Handle)
+import Text.Takkyuu.Internal (Game(..), Destination, Source)
+import Text.Takkyuu.Protocol (Move(..), Reply(..))
+--import Text.Takkyuu.Toolbox (effect)
 
-toHandle :: Handle -> Round a -> IO ()
 
-fromHandle :: Handle -> IO (Round a)
+effect :: Monad m => m () -> Game a b m
+effect m = M (m *> pure mempty)
+
+display :: MonadIO m => String -> Game a b m
+display = effect . liftIO . putStrLn
+
+debug :: (MonadIO m, Show a) => String -> Game a a m
+debug flag = Opponent traceMove
+  where
+    traceMove m = (Ok, (display $ flag ++ ":> " ++ show m) <> followMove m)
+    followMove (Finish exitStatus) = Finished exitStatus
+    followMove (Here a) = Player (Here a, traceReply)
+    followMove Back = Player (Back, traceReply)
+    traceReply r = (display $ flag ++ ":< " ++ show r) <> debug flag
+
+
+toHandle :: MonadIO m => Handle -> Destination a m
+toHandle = undefined
+
+fromHandle :: MonadIO m => Handle -> Source a m
+fromHandle = undefined

lib/Text/Takkyuu/Internal.hs

+{- LANGUAGE FlexibleContexts, DeriveGeneric #-}
+module Text.Takkyuu.Internal (
+      Game(..)
+    , Source
+    , Destination
+    , Match
+    , failed
+    , (<->)
+    , (//)
+    , play
+  ) where
+
+import Text.Takkyuu.Protocol (ExitStatus(..), Move(..), Reply(..))
+
+data Game a b m =
+    Player (Move b, Reply b -> Game a b m)
+  | Opponent (Move a -> (Reply a, Game a b m))
+  | M (m (Game a b m))
+  | Finished ExitStatus
+
+type Source a m = Game () a m
+type Destination a m = Game a () m
+type Match m = Game () () m
+
+instance Functor m => Semigroup (Game a b m) where
+  Finished Success <> g = g
+  f@(Finished Failure) <> _ = f
+  M m <> g = M ((<> g) <$> m)
+  Player (m, next) <> g = Player (m, (<> g) . next)
+  Opponent next <> g = Opponent (fmap (<> g) . next)
+
+instance Functor m => Monoid (Game a b m) where
+  mempty = Finished Success
+
+failed :: Game a b m
+failed = Finished Failure
+
+(//) :: Functor m => Game a b m -> Game a b m -> Game a b m
+Finished Failure // g = g
+f@(Finished Success) // _ = f
+M m // g = M ((// g) <$> m)
+Player (m, next) // g = Player (m, (// g) . next)
+Opponent next // g = Opponent (fmap (// g) . next)
+
+(<->) :: Functor m => Game a b m -> Game b c m -> Game a c m
+Player (moveB, next1) <-> Opponent next2 =
+  let (replyB, g) = next2 moveB in
+  next1 replyB <-> g
+M m1 <-> g = M ((<-> g) <$> m1)
+g <-> M m2 = M ((g <->) <$> m2)
+Opponent next1 <-> g =
+  Opponent (fmap (<-> g) . next1)
+g <-> Player (moveC, next2) =
+  Player (moveC, (g <->) . next2)
+Finished Success <-> Finished Success = Finished Success
+g@(Finished exitStatus1) <-> Opponent next2 =
+  case next2 (Finish exitStatus1) of
+    (_, Opponent _) -> Finished Failure
+    (Ok, g2) -> g <-> g2
+    _ -> Finished Failure
+Player (Finish exitStatus1, _) <-> Finished Success = Finished exitStatus1
+_ <-> Finished _ = Finished Failure
+
+play :: Monad m => Game () () m -> m ExitStatus
+play (Finished exitStatus) = pure exitStatus
+play (M m) = m >>= play
+play (Player (_, next)) = play $ next Ok
+play (Opponent next) = play . snd . next $ Here ()

lib/Text/Takkyuu/NLP.hs

+module Text.Takkyuu.NLP (
+      Label(..)
+    , Labeled(..)
+    , dico
+    , fuzz
+    , labelizer
+    , rules
+  ) where
+
+import Control.Monad.IO.Class (MonadIO(..))
+import Data.Map (Map, findWithDefault, insertWith)
+import qualified Data.Map as Map (empty)
+import Data.Set (Set)
+import qualified Data.Set as Set (empty, fromList, member)
+import Text.Takkyuu.Internal (Game(..), (//))
+import Text.Takkyuu.Protocol (ExitStatus(..), Move(..), Reply(..))
+import Text.Takkyuu.Toolbox (accept, here, oneOf)
+
+fuzz :: (Eq a, Ord a, MonadIO m) => Set [a] -> Game a a m
+--fuzz :: (Eq a, Ord a, Functor m) => Set [a] -> Game a a m
+fuzz classes = accept expand
+  where
+    expand a = oneOf (a:findWithDefault [] a equiv)
+    equiv = foldl (\tmp0 l ->
+        foldl (\tmp1 x -> 
+            insertWith (++) x (filter (/= x) l) tmp1
+          ) tmp0 l
+      ) Map.empty classes
+
+dico :: (MonadIO m, Eq k, Ord k) => (a -> k) -> (k -> Bool) -> Set [k] -> Game a [a] m
+--dico :: (Functor m, Eq k, Ord k) => (a -> k) -> (k -> Bool) -> Set [k] -> Game a [a] m
+--dico :: (Eq k, Ord k) => (a -> k) -> (k -> Bool) -> Set [k] -> Game a [a] (StateT [String] IO)
+dico projector _ vocabulary = start
+  where
+    start = Opponent $ continueFrom ([], [vocabulary])
+    continueFrom currentState@(stack, candidatesStack) (Here a) =
+      let projection = projector a in
+      let newCandidates = foldMap (startingWith projection) (candidatesStack !! 0) in
+      case (length newCandidates, Set.member [] newCandidates) of
+        (0, _) -> (No, Opponent $ continueFrom currentState)
+        (1, True) -> (Ok, (here (reverse $ a:stack) <> start))
+        (_, True) -> (Ok, (here (reverse $ a:stack) <> start) // Opponent (continueFrom (a:stack, newCandidates:candidatesStack)))
+        --(1, False) -> (Predict , …)
+        (_, False) -> (Ok, Opponent $ continueFrom (a:stack, newCandidates:candidatesStack))
+    continueFrom (_:stack, _:candidatesStack) Back =
+      (Ok, Opponent $ continueFrom (stack, candidatesStack))
+    continueFrom (_, _) Back = (No, Finished Failure)
+    continueFrom ([], _) (Finish Success) =
+      (Ok, Finished Success)
+    continueFrom (stack, _) (Finish Success) =
+      (Ok, here (reverse stack))
+    continueFrom (_, _) (Finish Failure) = (Ok, Finished Failure)
+    startingWith e (x:xs) = Set.fromList $ if e == x then [xs] else []
+    startingWith _ [] = Set.empty
+
+data Label l =
+    Unknown
+  | Label l
+  deriving (Eq, Ord, Show)
+ 
+
+data Labeled a l = Labeled {
+      item :: a
+    , label :: Label l
+  }
+  deriving (Eq, Ord, Show)
+
+labelizer :: (a -> k) -> Map a [b] -> Game a [Labeled a b] m
+labelizer = undefined
+
+rules :: (a -> k) -> Set [k] -> Game a [a] m
+rules = undefined

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/Protocol.hs

+{-# LANGUAGE FlexibleContexts, DeriveGeneric #-}
+
+module Text.Takkyuu.Protocol (
+      ExitStatus(..)
+    , Move(..)
+    , Reply(..)
+  ) where
+
+import Data.Aeson (FromJSON(..), ToJSON(..))
+import GHC.Generics (Generic)
+
+data ExitStatus =
+    Success
+  | Failure
+  deriving (Show, Generic)
+
+instance FromJSON ExitStatus
+instance ToJSON ExitStatus
+
+data Move a =
+    Here a
+  | Back
+  | Finish ExitStatus
+  deriving (Show, Generic)
+
+instance FromJSON a => FromJSON (Move a)
+instance ToJSON a => ToJSON (Move a)
+
+data Reply a =
+--data Reply =
+    Ok
+  | No
+--  | Error
+--  | Predict a
+  deriving (Show, Generic)
+
+instance FromJSON a => FromJSON (Reply a)
+instance ToJSON a => ToJSON (Reply a)

lib/Text/Takkyuu/Toolbox.hs

+{-# LANGUAGE FlexibleContexts, DeriveGeneric #-}
+module Text.Takkyuu.Toolbox (
+      here
+    , back
+    , effect
+    , fromEffect
+    , accept
+    , game
+    , oneOf
+    , wire
+    , sink
+    , runMonoid
+    , runMonoidT
+    , integrator
+  ) where
+
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.State (MonadState(..), modify, State, StateT(..), runState, runStateT)
+import Text.Takkyuu.Internal (Game(..), Destination, Match, (//), play)
+import Text.Takkyuu.IO (display)
+import Text.Takkyuu.Protocol (ExitStatus(..), Move(..), Reply(..))
+
+--checkOk :: Reply b -> Game a b m
+checkOk :: MonadIO m => Reply b -> Game a b m
+checkOk Ok = display "ok" <> Finished Success
+checkOk _ = display "no" <> Finished Failure
+
+here :: MonadIO m => b -> Game a b m
+here a = Player (Here a, checkOk)
+
+back :: MonadIO m => Game a b m
+back = Player (Back, checkOk)
+
+fromEffect :: Monad m => m c -> (c -> Game a b m) -> Game a b m
+fromEffect m f = M (m >>= pure . f)
+
+effect :: Monad m => m () -> Game a b m
+effect m = M (m *> pure mempty)
+
+accept :: MonadIO m => (a -> Game a b m) -> Game a b m
+--accept :: Functor m => (a -> Game a b m) -> Game a b m
+accept f = Opponent use
+  where
+    use (Here a) = (Ok, f a <> accept f)
+    use Back = (Ok, back <> accept f)
+    use (Finish exitStatus) = (Ok, Finished exitStatus)
+
+wire :: MonadIO m => Game a a m
+--wire :: Functor m => Game a a m
+wire = accept here
+{-
+wire = Opponent pass
+  where
+    pass (Finish exitStatus) = (Ok, Finished exitStatus)
+    pass m = 
+-}
+
+game :: (MonadIO m, Foldable f) => f b -> Game a b m
+--game :: (Functor m, Foldable f) => f b -> Game a b m
+game = foldr (\a s -> here a <> s) (Finished Success)
+
+oneOf :: (MonadIO m, Foldable f) => f b -> Game a b m
+--oneOf :: (Functor m, Foldable f) => f b -> Game a b m
+oneOf = foldr (\a s -> here a // s) (Finished Failure)
+
+integrator :: MonadState [a] m => Destination a m
+integrator = Opponent record
+  where
+    record (Here a) = (Ok, M (modify (a:) *> pure integrator))
+    record Back = (Ok, M (modify (drop 1) *> pure integrator))
+    record (Finish exitStatus) = (Ok, Finished exitStatus)
+
+sink :: Destination a m
+sink = Opponent ack
+  where
+    ack (Finish exitStatus) = (Ok, Finished exitStatus)
+    ack _ = (Ok, sink)
+
+runMonoid :: Monoid a => Match (State a) -> (ExitStatus, a)
+runMonoid m = runState (play m) mempty
+
+runMonoidT :: (Monad m, Monoid a) => Match (StateT a m) -> m (ExitStatus, a)
+runMonoidT m = runStateT (play m) mempty

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,12 +19,17 @@ extra-source-files:  CHANGELOG.md
 
 library
   exposed-modules:     Text.Takkyuu
-  other-modules:       Text.Takkyuu.French
-                     , Text.Takkyuu.Proto
-                     , Text.Takkyuu.Visualization
+                     , Text.Takkyuu.French
+  other-modules:       Text.Takkyuu.Internal
+                     , Text.Takkyuu.NLP
+                     , Text.Takkyuu.Protocol
+                     , Text.Takkyuu.Toolbox
+                     , Text.Takkyuu.IO
   -- other-extensions:
   build-depends:       base >=4.14 && <4.15
+                     , aeson >=1.5.6 && <1.5.7
                      , containers >=0.6 && <0.7
+                     , mtl >=2.2 && <2.3
   hs-source-dirs:      lib
   default-language:    Haskell2010
   ghc-options:         -Wall
@@ -39,7 +44,9 @@ executable takkyuu
 
 test-suite takkyuu-test
   default-language:    Haskell2010
-  type:                exitcode-stdio-1.0
+  type:                detailed-0.9
   hs-source-dirs:      test
-  main-is:             MyLibTest.hs
+  test-module:         Test
   build-depends:       base >=4.14 && <4.15
+                     , Cabal
+                     , takkyuu

test/MyLibTest.hs

-module Main (main) where
-
-main :: IO ()
-main = putStrLn "Test suite not yet implemented."

test/Test.hs

+module Test (
+    tests
+  ) where
+
+import Distribution.TestSuite
+import Text.Takkyuu (oneOf)
+
+tests :: IO [Test]
+tests = pure []