module Development.Bake.Core.Type(
Host, Port,
Stringy(..),
Oven(..), TestInfo(..), defaultOven, ovenTest,
ovenNotifyAdd, ovenNotifyStdout,
threads, threadsAll, depend, run, require, priority,
State, toState, fromState,
Patch, toPatch, fromPatch,
Test, toTest, fromTest,
Client, toClient, fromClient,
Point,
concrete, Prettys(..),
validTests,
Author
) where
import General.Extra
import Control.Monad.Extra
import Control.DeepSeq
import Data.Monoid
import Data.Aeson
import Data.Hashable
import Data.Typeable
import Database.SQLite.Simple.FromField
import Database.SQLite.Simple.ToField
import General.Database
import Data.List.Extra
import Prelude
type Author = String
type Host = String
type Port = Int
data Oven state patch test = Oven
{ovenInit :: IO state
,ovenUpdate :: state -> [patch] -> IO state
,ovenPrepare :: state -> [patch] -> IO [test]
,ovenTestInfo :: test -> TestInfo test
,ovenNotify :: Author -> String -> String -> IO ()
,ovenPatchExtra :: state -> Maybe patch -> IO (String, String)
,ovenServer :: (Host, Port)
,ovenSupersede :: patch -> patch -> Bool
}
ovenTest :: IO [test] -> (test -> TestInfo test)
-> Oven state patch () -> Oven state patch test
ovenTest prepare info o = o{ovenPrepare= \_ _ -> prepare, ovenTestInfo=info}
ovenNotifyAdd :: (Author -> String -> String -> IO ()) -> Oven state patch test -> Oven state patch test
ovenNotifyAdd f o = o{ovenNotify = \a s b -> f a s b >> ovenNotify o a s b}
ovenNotifyStdout :: Oven state patch test -> Oven state patch test
ovenNotifyStdout = ovenNotifyAdd $ \author subject body ->
putBlock "Email" ["To: " ++ author, "Subject: " ++ subject, body]
class Stringy s where
stringyTo :: s -> String
stringyFrom :: String -> s
stringyPretty :: s -> String
stringyPretty = stringyTo
instance Stringy () where
stringyTo () = "_"
stringyFrom "_" = ()
stringyFrom x = error $ "Invalid stringyFrom on (), expected \"_\", got " ++ show x
instance Stringy String where
stringyTo = id
stringyFrom = id
stringyPretty x
| (pre,sha) <- spanEnd (`elem` "0123456789abcdef") x
, length sha >= 32
= pre ++ take 7 sha
stringyPretty x = x
defaultOven :: Oven () () ()
defaultOven = Oven
{ovenInit = return ()
,ovenUpdate = \_ _ -> return ()
,ovenNotify = \_ _ _ -> return ()
,ovenPrepare = \_ _ -> return []
,ovenTestInfo = \_ -> mempty
,ovenPatchExtra = \_ _ -> return ("","")
,ovenServer = ("127.0.0.1",80)
,ovenSupersede = \_ _ -> False
}
data TestInfo test = TestInfo
{testThreads :: Maybe Int
,testAction :: IO ()
,testRequire :: [String]
,testDepend :: [test]
,testPriority :: Int
}
instance Functor TestInfo where
fmap f t = t{testDepend = map f $ testDepend t}
instance Monoid (TestInfo test) where
mempty = TestInfo (Just 1) (return ()) [] [] 0
mappend (TestInfo x1 x2 x3 x4 x5) (TestInfo y1 y2 y3 y4 y5) =
TestInfo (liftM2 (+) x1 y1) (x2 >> y2) (x3 ++ y3) (x4 ++ y4) (x5 + y5)
threads :: Int -> TestInfo test -> TestInfo test
threads j t = t{testThreads=Just j}
threadsAll :: TestInfo test -> TestInfo test
threadsAll t = t{testThreads=Nothing}
depend :: [test] -> TestInfo test -> TestInfo test
depend xs t = t{testDepend=testDepend t++xs}
run :: IO () -> TestInfo test
run act = mempty{testAction=act}
priority :: Int -> TestInfo test -> TestInfo test
priority p t = t{testPriority = p + testPriority t}
require :: [String] -> TestInfo test -> TestInfo test
require xs t = t{testRequire = xs ++ testRequire t}
newtype State = State {fromState :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable,NFData,Typeable,FromField,ToField,TypeField,Stringy)
newtype Patch = Patch {fromPatch :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable,NFData,Typeable,FromField,ToField,TypeField,Stringy)
newtype Test = Test {fromTest :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable,NFData,Typeable,FromField,ToField,TypeField,Stringy)
newtype Client = Client {fromClient :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable,NFData,Typeable,FromField,ToField,TypeField)
toState :: String -> State; toState = State
toPatch :: String -> Patch; toPatch = Patch
toTest :: String -> Test; toTest = Test
toClient :: String -> Client; toClient = Client
type Point = (State, [Patch])
data Prettys = Prettys
{prettyState :: State -> String
,prettyPatch :: Patch -> String
,prettyTest :: Test -> String
}
concrete :: (Stringy state, Stringy patch, Stringy test) => Oven state patch test -> (Prettys, Oven State Patch Test)
concrete o@Oven{..} = (Prettys prestate prepatch pretest, o
{ovenInit = fmap restate ovenInit
,ovenUpdate = \s ps -> fmap restate $ ovenUpdate (unstate s) (map unpatch ps)
,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)
,ovenSupersede = \p1 p2 -> ovenSupersede (unpatch p1) (unpatch p2)
})
where
(unstate,restate,prestate) = f State fromState
(unpatch,_ ,prepatch) = f Patch fromPatch
(untest ,retest ,pretest ) = f Test fromTest
f :: forall o s . Stringy o => (String -> s) -> (s -> String) -> (s -> o, o -> s, s -> String)
f inj proj =
(check . stringyFrom . proj
,inj . stringyTo . check
,stringyPretty . flip asTypeOf (undefined :: o) . check . stringyFrom . proj)
check :: forall o . Stringy o => o -> o
check s | null $ stringyTo s = error "Problem with stringyTo/stringyFrom, generated blank string"
| stringyTo s == stringyTo (stringyFrom (stringyTo s) :: o) = s
| otherwise = error $ "Problem with stringyTo/stringyFrom on " ++ stringyTo s
validTests :: Stringy test => (test -> TestInfo test) -> [test] -> Either String ()
validTests info (map stringyTo -> res)
| Just xs <- findCycle follow res = Left $ unlines $ "Tests form a cycle:" : xs
| missing@(_:_) <- transitiveClosure follow res \\ res = Left $ unlines $ "Test is a dependency that cannot be reached:" : missing
| otherwise = Right ()
where follow t = map stringyTo $ testDepend $ info $ stringyFrom t