Strict.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fcontext-stack=25 #-}
-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/Examples/Lex/RCS/Strict.hs,v 1.8 2011/02/16 00:58:48 dosuser Exp dosuser $
module Data.Flex.Examples.Lex.Strict where

import Control.Applicative (Applicative(..), (<$>), Alternative(..),
        liftA2
    )
import Control.Monad (join, ap, liftM, MonadPlus(..))
import Control.Monad.State (
        StateT(..), MonadState(..), modify, gets, evalStateT
    )
import Control.Monad.Trans (MonadTrans(..))

import Data.Char (ord)
import Data.Foldable as F (Foldable(..))
import Data.Maybe (fromJust)
-- isJust, catMaybes,
import Data.List (delete)

import Data.Flex.Compose ((:.)(..), O,
        FWCompP, FWCompS, FWCompDefaults, FWCompMonadPlusL
    )
import Data.Flex.FlipT (FlipT(..), FWFlipDefaults, FWFlipMonad)
import Data.Flex.Wrap (FW, FlexiWrap(..))
import Data.Flex.WrapCTC (FlexiWrapCTC(..), FWCTC)
import Data.Flex.WrappedMonad (FWMonadApplicative, FWWrapMonad)
import Data.Flex.WrapT (FlexiWrapT(..), FWT, inFlexiWrapT2, FWTDefaultMonadAll)

import Data.Flex.Examples.Lex.Simple

import Data.Type.TList

import Test.QuickCheck

data FWStrict = FWStrict

type Strict = FW (FWStrict :*: TNil)

strict :: a -> Strict a
strict = FlexiWrap

type StrictT = FWCTC
    (FWFlipDefaults :*:
        FWCompMonadPlusL :*: FWCompDefaults :*: FWCompS :*: TNil
    )
    (FlipT O) Strict

strictT :: f (Strict a) -> StrictT f a
strictT = FlexiWrapCTC . FlipT . O

unStrictT :: StrictT f a -> f (Strict a)
unStrictT = unO . unFlipT . unFlexiWrapCTC

type MaybeT = FWCTC
    (FWFlipDefaults :*: FWCompDefaults :*: FWCompP :*: TNil)
    (FlipT O) Maybe

-- maybeT :: Monad f => f (Maybe a) -> MaybeT f a
maybeT :: f (Maybe a) -> MaybeT f a
maybeT = FlexiWrapCTC . FlipT . O

unMaybeT :: MaybeT f a -> f (Maybe a)
unMaybeT = unO . unFlipT . unFlexiWrapCTC

type StrictMaybeT f = StrictT (MaybeT f)

{-
    StrictMaybeT f x ==
    StrictT (MaybeT f) x ==
    FWCTC tag (FlipT O) Strict (MaybeT f) x ~
    O (MaybeT f) Strict x ~
    MaybeT f (Strict x) ==
    FWCTC tag (FlipT O) Maybe f (Strict x) ~
    O f Maybe (Strict x) ~
    f (Maybe (Strict x))
-}

type WStateT s m =
    FWT (FWWrapMonad :*: FWTDefaultMonadAll :*: TNil) (StateT s m)

type StrictMaybeStateGen s = WStateT s (StrictMaybeT Gen)

{-
instance Monad m => Applicative (WStateT s m) where
    pure = FlexiWrapT . return
    (<*>) = inFlexiWrapT2 ap
-}

-- instance (MonadPlus m, Applicative (WStateT s m)) =>
instance MonadPlus m =>
        Alternative (WStateT s m) where
    empty = FlexiWrapT . StateT $ \s -> flip (,) s `liftM` mzero
    -- a <|> b = (<|>) <$> a <*> b
    a <|> b = FlexiWrapT . StateT $ \s ->
        runStateT (unFlexiWrapT a) s `mplus` runStateT (unFlexiWrapT b) s

{-
-- instance (Monad m, Monad (WStateT s m)) => MonadState s (WStateT s m) where
instance Monad m => MonadState s (WStateT s m) where
        -- and/or Monad (WStateT s m), Monad m
    get = lift get
    put = lift . put
-}

-- class Monad m => MonadGen m where
class MonadGen m where
    liftGen :: Gen a -> m a

instance MonadGen Gen where
    liftGen = id

-- instance (MonadTrans t, MonadGen m, Monad (t m)) => MonadGen (t m) where
instance (MonadTrans t, Monad m, MonadGen m) => MonadGen (t m) where
    liftGen = lift . liftGen

{-
-- instance (MonadGen m, Monad (WStateT s m)) =>  MonadGen (WStateT s m) where
instance (Monad m, MonadGen m) =>  MonadGen (WStateT s m) where
    liftGen = lift . lift . liftGen
-}

class MonadMaybe m where
    liftMaybe :: Maybe a -> m a

instance MonadMaybe Maybe where
    liftMaybe = id

instance Monad m => MonadMaybe (MaybeT m) where
    liftMaybe = maybeT . return

instance (Monad m, MonadMaybe m) => MonadMaybe (StrictT m) where
    liftMaybe = lift . liftMaybe

instance (Monad m, MonadMaybe m) => MonadMaybe (WStateT s m) where
    liftMaybe = lift . lift . liftMaybe

lexAlphabet = "abcde"
lexIndex :: Char -> Int
lexIndex c
    | 'a' <= c && c <= 'e' = ord c - ord 'a'
    | otherwise = error "lexAlphabet character out of range"

-- strictMaybeBasic :: (Eq c, MonadState [c] (StrictMaybeStateGen [c])) =>
strictMaybeBasic :: Eq c =>
    StrictMaybeStateGen [c] (Basic c)
strictMaybeBasic = do
    c <- join $ gets select
    modify $ delete c
    return $ BSimple c
 where
    -- select :: (Eq c, Monad (StrictMaybeStateGen [c])) =>
    -- select :: Eq c =>
    select ::
        [c] -> StrictMaybeStateGen [c] c
    select [] = liftMaybe Nothing
    select l = liftGen $ elements l

{-
-- This clashes with any generic Arbitrary (Maybe a) instance
instance Arbitrary (Maybe (Strict (Basic Char))) where
    arbitrary = unMaybeT . unStrictT $ evalStateT strictMaybeBasic lexAlphabet
    coarbitrary Nothing = variant 0
    coarbitrary (Just (FlexiWrap (BSimple c))) = variant $ 1 + lexIndex c
-}

instance Arbitrary ((Maybe :. Strict) (Basic Char)) where
    arbitrary = fmap O . unMaybeT . unStrictT $
        evalStateT (unFlexiWrapT strictMaybeBasic) lexAlphabet
    coarbitrary (O Nothing) = variant 0
    coarbitrary (O (Just (FlexiWrap (BSimple c)))) = variant $ 1 + lexIndex c

{-
sizedStrictMaybeBSingle :: (
        Eq c, Applicative (StrictMaybeStateGen [c]),
        Monad (StrictMaybeStateGen [c])
    ) =>
-}
sizedStrictMaybeBSingle :: Eq c => Int -> StrictMaybeStateGen [c] (Single c)
sizedStrictMaybeBSingle 0 = SSimple <$> strictMaybeBasic
sizedStrictMaybeBSingle n | n > 0 =
    (SOr <$> strictMaybeBasic <*> sizedStrictMaybeBSingle (n - 1))
    <|>
    sizedStrictMaybeBSingle 0

{-
-- This clashes with any generic Arbitrary (Maybe a) instance
instance Arbitrary (Maybe (Strict (Single Char))) where
    arbitrary = sized $ unMaybeT . unStrictT .
        flip evalStateT lexAlphabet . unFlexiWrapT . sizedStrictMaybeBSingle
    coarbitrary Nothing = variant 0
    coarbitrary (Just (FlexiWrap (SSimple b))) =
        variant 1 . coarbitrary (O . Just $ strict b)
    coarbitrary (Just (FlexiWrap (b `SOr` c))) = variant 2 .
        coarbitrary (O . Just $ strict b) . coarbitrary (O . Just $ strict c)
-}

instance Arbitrary ((Maybe :. Strict) (Single Char)) where
    arbitrary = fmap O . sized $ unMaybeT . unStrictT .
        flip evalStateT lexAlphabet . unFlexiWrapT . sizedStrictMaybeBSingle
    coarbitrary (O Nothing) = variant 0
    coarbitrary (O (Just (FlexiWrap (SSimple b)))) =
        variant 1 . coarbitrary (O . Just $ strict b)
    coarbitrary (O (Just (FlexiWrap (b `SOr` c)))) = variant 2 .
        coarbitrary (O . Just $ strict b) . coarbitrary (O . Just $ strict c)

liftStrictMaybe :: (
            MonadTrans t, MonadTrans u, Monad f, Monad (u (StrictT (MaybeT f)))
        ) =>
    f (Maybe (Strict a)) -> t (u (StrictT (MaybeT f))) a
liftStrictMaybe = lift . lift . strictT . maybeT

{-
sizedStrictMaybeSimple :: (Eq c,
        -- Arbitrary (Maybe (Strict s))
        Arbitrary (Strict s),
        Applicative (StrictMaybeStateGen [c]),
        Monad (StrictMaybeStateGen [c])
    ) =>
-}
sizedStrictMaybeSimple :: (Eq c,
        -- Arbitrary (Maybe (Strict s))
        Arbitrary (Strict s)
    ) =>
    Int -> StrictMaybeStateGen [c] (Simple s c)
sizedStrictMaybeSimple n = TSimple <$> sizedStrictMaybeBSingle n2 <*>
    liftStrictMaybe (fmap Just $ resize n2 arbitrary)
  where n2 = n `div` 2

{-
-- This clashes with any generic Arbitrary (Maybe a) instance
instance
    -- Arbitrary (Maybe (Strict s))
    Arbitrary (Strict s)
  =>
    Arbitrary (Maybe (Strict (Simple s Char)))
  where
    arbitrary = sized $ unMaybeT . unStrictT .
        flip evalStateT lexAlphabet . sizedStrictMaybeSimple
    coarbitrary Nothing = variant 0
    coarbitrary (Just (FlexiWrap (TSimple b l))) = variant 1 .
        coarbitrary (O . Just $ strict b) . coarbitrary (strict l)
-}

instance
    Arbitrary (Strict s)
  =>
    Arbitrary ((Maybe :. Strict) (Simple s Char))
  where
    arbitrary = fmap O . sized $ unMaybeT . unStrictT .
        flip evalStateT lexAlphabet . unFlexiWrapT . sizedStrictMaybeSimple
    coarbitrary (O Nothing) = variant 0
    coarbitrary (O (Just (FlexiWrap (TSimple b l)))) = variant 1 .
        coarbitrary (O . Just $ strict b) . coarbitrary (strict l)

{-
sizedStrictMaybeLex :: (
        Eq c, Arbitrary a,
        -- Arbitrary (Maybe (Strict (Lex c a)))
        Arbitrary (Strict (Lex c a)),
        Applicative (StrictMaybeStateGen [c]),
        Monad (StrictMaybeStateGen [c])
    ) =>
-}
sizedStrictMaybeLex :: (
        Eq c, Arbitrary a,
        -- Arbitrary (Maybe (Strict (Lex c a)))
        Arbitrary (Strict (Lex c a))
    ) =>
    Int -> StrictMaybeStateGen [c] (Lex c a)
sizedStrictMaybeLex 0 = sequence [
        return LNil
        , LDone <$> liftGen arbitrary
    ] >>= liftGen . elements
sizedStrictMaybeLex n | n > 0 = catAlternatives [
        LRepeat . SRepeat <$> sizedStrictMaybeSimple (n - 1)
        , LOr . SOnce <$> sizedStrictMaybeSimple n2 <*>
            sizedStrictMaybeLex n2
    ] >>= select
  where
    n2 = n `div` 2
    select [] = sizedStrictMaybeLex 0
    select l = liftGen $ elements l

catAlternatives :: (Foldable f, Alternative g) => f (g b) -> g [b]
catAlternatives = F.foldr merge (pure []) where
    merge b bs = liftA2 (:) b bs <|> bs

instance Arbitrary a => Arbitrary (Strict (Lex Char a)) where
    arbitrary = alphabetSizedStrictLex lexAlphabet
    coarbitrary (FlexiWrap LNil) = variant 0
    coarbitrary (FlexiWrap (LDone a)) = variant 1 . coarbitrary a
    coarbitrary (FlexiWrap (LRepeat (SRepeat s))) = variant 2 .
        coarbitrary (O . Just $ strict s)
    coarbitrary (FlexiWrap (SOnce s `LOr` l)) = variant 3 .
        coarbitrary (O . Just $ strict s) . coarbitrary (strict l)

{-
alphabetSizedStrictLex :: (
        Eq c, Arbitrary a,
        -- Arbitrary (Maybe (Strict (Lex c a)))
        Arbitrary (Strict (Lex c a)),
        Applicative (StrictMaybeStateGen [c]),
        Monad (StrictMaybeStateGen [c])
    ) =>
-}
alphabetSizedStrictLex :: (
        Eq c, Arbitrary a,
        -- Arbitrary (Maybe (Strict (Lex c a)))
        Arbitrary (Strict (Lex c a))
    ) =>
    [c] -> Gen (Strict (Lex c a))
alphabetSizedStrictLex alphabet = sized $ fmap fromJust .
    unMaybeT . unStrictT . flip evalStateT alphabet .
    unFlexiWrapT . sizedStrictMaybeLex

-- vim: expandtab:tabstop=4:shiftwidth=4