Getting rid of MonadIO troubleshooting stuff, ack. the fack that wire isn't...

Getting rid of MonadIO troubleshooting stuff, ack. the fack that wire isn't behaving as one, adding filters to compensate for lack of support of blank in dico

lib/Text/Takkyuu/French.hs

@@ -3,16 +3,16 @@ module Text.Takkyuu.French (
       POS(..)
     , Gender(..)
     , MorphoLabel(..)
+    , typo
     , french
     , tag
     , 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 (Game, Label(..), Labeled(..), dico, labelizer, rules)
+import Text.Takkyuu (Game, Label(..), Labeled(..), dico, fuzz, labelizer, rules)
 
 data POS =
     Determiner
@@ -39,10 +39,13 @@ data MorphoLabel = MorphoLabel {
 
 type LabeledWord = Labeled String MorphoLabel
 
-french:: MonadIO m => Game Char String m
+typo :: Functor m => Game Char Char m
+typo = fuzz $ Set.fromList ["bh"]
+
+french:: Functor m => Game Char String m
 french = dico toLower isSpace $ Set.fromList ["le", "la", "chat", "lait", "marché"]
 
-tag :: Game String [LabeledWord] m
+tag :: Functor m => Game String LabeledWord m
 tag = labelizer (fmap toLower) $ Map.fromList [
       ("le",
         [MorphoLabel {pos = Determiner, gender = Masculine, number = Singular}])
@@ -60,7 +63,7 @@ tag = labelizer (fmap toLower) $ Map.fromList [
         ])
   ]
 
-syntax :: Game LabeledWord [LabeledWord] m
+syntax :: Functor m => 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

@@ -9,11 +9,7 @@ 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)
-
-
-effect :: Monad m => m () -> Game a b m
-effect m = M (m *> pure mempty)
+import Text.Takkyuu.Toolbox (effect)
 
 display :: MonadIO m => String -> Game a b m
 display = effect . liftIO . putStrLn

lib/Text/Takkyuu/NLP.hs

@@ -7,18 +7,16 @@ module Text.Takkyuu.NLP (
     , rules
   ) where
 
-import Control.Monad.IO.Class (MonadIO(..))
 import Data.Map (Map, findWithDefault, insertWith)
-import qualified Data.Map as Map (empty)
+import qualified Data.Map as Map (empty, lookup)
 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)
+import Text.Takkyuu.Toolbox (accept, back, 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
+fuzz :: (Eq a, Ord a, Functor m) => Set [a] -> Game a a m
+fuzz classes = accept expand back
   where
     expand a = oneOf (a:findWithDefault [] a equiv)
     equiv = foldl (\tmp0 l ->
@@ -27,9 +25,7 @@ fuzz classes = accept expand
           ) 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 :: (Functor m, Eq k, Ord k) => (a -> k) -> (k -> Bool) -> Set [k] -> Game a [a] m
 dico projector _ vocabulary = start
   where
     start = Opponent $ continueFrom ([], [vocabulary])
@@ -58,15 +54,18 @@ data Label l =
   | 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
+labelizer :: (Functor m, Ord k) => (a -> k) -> Map k [b] -> Game a (Labeled a b) m
+labelizer projector labels = accept outputLabels back
+  where
+    outputLabels a =
+      let possibleLabels = Map.lookup (projector a) labels in
+      oneOf $ maybe [Labeled a Unknown] (Labeled a . Label <$>) possibleLabels
 
-rules :: (a -> k) -> Set [k] -> Game a [a] m
-rules = undefined
+rules :: (Functor m, Ord k) => (a -> k) -> Set [k] -> Game a [a] m
+rules projector = dico projector undefined

lib/Text/Takkyuu/Toolbox.hs

@@ -5,30 +5,30 @@ module Text.Takkyuu.Toolbox (
     , effect
     , fromEffect
     , accept
+    , handle
     , game
     , oneOf
-    , wire
+    , diode
+    , keep
+    , require
     , 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
+checkOk :: Reply b -> Game a b m
+checkOk Ok = Finished Success
+checkOk _ = Finished Failure
 
-here :: MonadIO m => b -> Game a b m
+here :: b -> Game a b m
 here a = Player (Here a, checkOk)
 
-back :: MonadIO m => Game a b m
+back :: Game a b m
 back = Player (Back, checkOk)
 
 fromEffect :: Monad m => m c -> (c -> Game a b m) -> Game a b m
@@ -37,32 +37,37 @@ 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
+handle :: Functor m => (a -> (Reply a, Game a b m)) -> Game a b m -> Game a b m
+handle whenHere whenBack = Opponent use
   where
-    use (Here a) = (Ok, f a <> accept f)
-    use Back = (Ok, back <> accept f)
+    use (Here a) = (<> handle whenHere whenBack) <$> whenHere a
+    use Back = (Ok, whenBack <> handle whenHere whenBack)
     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 = 
--}
+accept :: Functor m => (a -> Game a b m) -> Game a b m -> Game a b m
+accept f = handle ((,) Ok . f)
+
+diode :: Functor m => Game a a m
+diode = accept here back
 
-game :: (MonadIO m, Foldable f) => f b -> Game a b m
---game :: (Functor 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 :: (Functor m, Foldable f) => f b -> Game a b m
 oneOf = foldr (\a s -> here a // s) (Finished Failure)
 
+keep :: Functor m => (a -> Bool) -> Game a a m
+keep predicate = handle skipOthers back
+  where
+    skipOthers a = (Ok, if predicate a then here a else mempty)
+
+require :: Functor m => (a -> Bool) -> Game a a m
+require predicate = handle replaceOthers back
+  where
+    replaceOthers a
+      | predicate a = (Ok, here a)
+      | otherwise = (No, mempty)
+
 integrator :: MonadState [a] m => Destination a m
 integrator = Opponent record
   where