syb-0.2: tests/Perm.hs

{-# OPTIONS -fglasgow-exts #-}

module Perm (tests) where

{-

This module illustrates permutation phrases.
Disclaimer: this is a perhaps naive, certainly undebugged example.

-}

import Test.HUnit

import Control.Monad
import Data.Generics

---------------------------------------------------------------------------
-- We want to read terms of type T3 regardless of the order T1 and T2.
---------------------------------------------------------------------------

data T1 = T1       deriving (Show, Eq, Typeable, Data)
data T2 = T2       deriving (Show, Eq, Typeable, Data)
data T3 = T3 T1 T2 deriving (Show, Eq, Typeable, Data)


---------------------------------------------------------------------------
-- A silly monad that we use to read lists of constructor strings.
---------------------------------------------------------------------------

-- Type constructor
newtype ReadT a = ReadT { unReadT :: [String] -> Maybe ([String],a) }



-- Run a computation
runReadT x y = case unReadT x y of
                 Just ([],y) -> Just y
                 _           -> Nothing

-- Read one string
readT :: ReadT String
readT =  ReadT (\x -> if null x
                        then Nothing
                        else Just (tail x, head x)
               )

-- ReadT is a monad!
instance Monad ReadT where
  return x = ReadT (\y -> Just (y,x))
  c >>= f  = ReadT (\x -> case unReadT c x of
                            Nothing -> Nothing
                            Just (x', a) -> unReadT (f a) x'
                   )

-- ReadT also accommodates mzero and mplus!
instance MonadPlus ReadT where
  mzero = ReadT (const Nothing)
  f `mplus` g = ReadT (\x -> case unReadT f x of
                               Nothing -> unReadT g x
                               y -> y
                      )


---------------------------------------------------------------------------
-- A helper type to appeal to predicative type system.
---------------------------------------------------------------------------

newtype GenM = GenM { unGenM :: forall a. Data a => a -> ReadT a }


---------------------------------------------------------------------------
-- The function that reads and copes with all permutations.
---------------------------------------------------------------------------

buildT :: forall a. Data a => ReadT a
buildT = result

 where
  result = do str <- readT
              con <- string2constr str
              ske <- return $ fromConstr con
              fs  <- return $ gmapQ buildT' ske
              perm [] fs ske

  -- Determine type of data to be constructed
  myType = myTypeOf result
    where
      myTypeOf :: forall a. ReadT a -> a
      myTypeOf =  undefined

  -- Turn string into constructor
  string2constr str = maybe mzero
                            return
                            (readConstr (dataTypeOf myType) str)

  -- Specialise buildT per kid type
  buildT' :: forall a. Data a => a -> GenM
  buildT' (_::a) = GenM (const mzero `extM` const (buildT::ReadT a))

  -- The permutation exploration function
  perm :: forall a. Data a => [GenM] -> [GenM] -> a -> ReadT a
  perm [] [] a = return a
  perm fs [] a = perm [] fs a
  perm fs (f:fs') a = (
                        do a' <- gmapMo (unGenM f) a
                           perm fs fs' a'
                      )
                        `mplus`
                      (
                        do guard (not (null fs'))
                           perm (f:fs) fs' a
                      )


---------------------------------------------------------------------------
-- The main function for testing
---------------------------------------------------------------------------

tests =
     ( runReadT buildT ["T1"] :: Maybe T1           -- should parse fine
   , ( runReadT buildT ["T2"] :: Maybe T2           -- should parse fine
   , ( runReadT buildT ["T3","T1","T2"] :: Maybe T3 -- should parse fine
   , ( runReadT buildT ["T3","T2","T1"] :: Maybe T3 -- should parse fine
   , ( runReadT buildT ["T3","T2","T2"] :: Maybe T3 -- should fail
   ))))) ~=? output

output = (Just T1,(Just T2,(Just (T3 T1 T2),(Just (T3 T1 T2),Nothing))))