module Development.Bake.Type(
Host, Port,
Stringy(..), readShowStringy,
Oven(..), TestInfo(..), defaultOven, ovenTest, ovenNotifyStdout,
threads, threadsAll, require, run, suitable,
State(..), Patch(..), Test(..), Client(..), concrete, validate,
Author
) where
import Development.Bake.Format
import Control.Monad.Extra
import Data.Monoid
import Data.Aeson
import Data.Hashable
import Control.Arrow
type Author = String
type Host = String
type Port = Int
data Oven state patch test = Oven
{ovenUpdateState :: Maybe (state, [patch]) -> IO state
,ovenPrepare :: state -> [patch] -> IO [test]
,ovenTestInfo :: test -> TestInfo test
,ovenNotify :: [Author] -> String -> IO ()
,ovenPatchExtra :: state -> Maybe patch -> IO (String, String)
,ovenServer :: (Host, Port)
,ovenStringyState :: Stringy state
,ovenStringyPatch :: Stringy patch
,ovenStringyTest :: Stringy test
}
ovenTest :: Stringy test -> IO [test] -> (test -> TestInfo test)
-> Oven state patch () -> Oven state patch test
ovenTest stringy prepare info o = o{ovenStringyTest=stringy, ovenPrepare= \_ _ -> prepare, ovenTestInfo=info}
ovenNotifyStdout :: Oven state patch test -> Oven state patch test
ovenNotifyStdout o = o{ovenNotify = \a s -> f a s >> ovenNotify o a s}
where f a s = putStr $ unlines
[replicate 70 '-'
,"To: " ++ commas a
,s
,replicate 70 '-'
]
data Stringy s = Stringy
{stringyTo :: s -> String
,stringyFrom :: String -> s
,stringyPretty :: s -> String
}
readShowStringy :: (Show s, Read s) => Stringy s
readShowStringy = Stringy show read show
defaultOven :: Oven () () ()
defaultOven = Oven
{ovenUpdateState = \_ -> return ()
,ovenNotify = \_ _ -> return ()
,ovenPrepare = \_ _ -> return []
,ovenTestInfo = \_ -> mempty
,ovenPatchExtra = \_ _ -> return ("","")
,ovenServer = ("127.0.0.1",80)
,ovenStringyState = readShowStringy
,ovenStringyPatch = readShowStringy
,ovenStringyTest = readShowStringy
}
data TestInfo test = TestInfo
{testThreads :: Maybe Int
,testAction :: IO ()
,testSuitable :: IO Bool
,testRequire :: [test]
}
instance Functor TestInfo where
fmap f t = t{testRequire = map f $ testRequire t}
instance Monoid (TestInfo test) where
mempty = TestInfo (Just 1) (return ()) (return True) []
mappend (TestInfo x1 x2 x3 x4) (TestInfo y1 y2 y3 y4) =
TestInfo (liftM2 (+) x1 y1) (x2 >> y2) (x3 &&^ y3) (x4 ++ y4)
threads :: Int -> TestInfo test -> TestInfo test
threads j t = t{testThreads=Just j}
threadsAll :: TestInfo test -> TestInfo test
threadsAll t = t{testThreads=Nothing}
require :: [test] -> TestInfo test -> TestInfo test
require xs t = t{testRequire=testRequire t++xs}
run :: IO () -> TestInfo test
run act = mempty{testAction=act}
suitable :: IO Bool -> TestInfo test -> TestInfo test
suitable query t = t{testSuitable = query &&^ testSuitable t}
newtype State = State {fromState :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable)
newtype Patch = Patch {fromPatch :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable)
newtype Test = Test {fromTest :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable)
newtype Client = Client {fromClient :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable)
concrete :: Oven state patch test -> Oven State Patch Test
concrete o@Oven{..} = o
{ovenUpdateState = fmap restate . ovenUpdateState . fmap (unstate *** map unpatch)
,ovenPrepare = \s ps -> fmap (map retest) $ ovenPrepare (unstate s) (map unpatch ps)
,ovenTestInfo = fmap retest . ovenTestInfo . untest
,ovenPatchExtra = \s p -> ovenPatchExtra (unstate s) (fmap unpatch p)
,ovenStringyState = state
,ovenStringyPatch = patch
,ovenStringyTest = test
}
where
(patch,unpatch,_ ) = f Patch fromPatch ovenStringyPatch
(state,unstate,restate) = f State fromState ovenStringyState
(test ,untest ,retest ) = f Test fromTest ovenStringyTest
f :: (String -> s) -> (s -> String) -> Stringy o -> (Stringy s, s -> o, o -> s)
f inj proj Stringy{..} =
(Stringy proj inj (stringyPretty . stringyFrom . proj)
,stringyFrom . proj
,inj . stringyTo)
validate :: Oven state patch test -> Oven state patch test
validate o@Oven{..} = o
{ovenStringyState = f ovenStringyState
,ovenStringyPatch = f ovenStringyPatch
,ovenStringyTest = f ovenStringyTest
}
where
f :: Stringy a -> Stringy a
f s@Stringy{..} = s
{stringyTo = check . stringyTo
,stringyFrom = stringyFrom . check
}
where check s | s == stringyTo (stringyFrom s) = s
| otherwise = error $ "Problem with stringyTo/stringyFrom on " ++ show s