{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
module HaskellCI.Travis.Yaml where
import HaskellCI.Prelude
import qualified Data.Aeson as Aeson
import qualified Data.List.NonEmpty as NE
import HaskellCI.Config.Ubuntu
import HaskellCI.List
import HaskellCI.Sh
import HaskellCI.YamlSyntax
data Travis = Travis
{ travisUbuntu :: !Ubuntu
, travisLanguage :: !String
, travisGit :: !TravisGit
, travisCache :: !TravisCache
, travisBranches :: !TravisBranches
, travisNotifications :: !TravisNotifications
, travisServices :: ![String]
, travisAddons :: !TravisAddons
, travisMatrix :: !TravisMatrix
, travisBeforeCache :: ![Sh]
, travisBeforeInstall :: ![Sh]
, travisInstall :: ![Sh]
, travisScript :: ![Sh]
}
deriving Show
newtype TravisGit = TravisGit
{ tgSubmodules :: Bool
}
deriving Show
newtype TravisCache = TravisCache
{ tcDirectories :: [FilePath]
}
deriving Show
newtype TravisBranches = TravisBranches
{ tbOnly :: [String]
}
deriving Show
data TravisNotifications = TravisNotifications
{ tnIRC :: Maybe TravisIRC
, tnEmail :: Bool
}
deriving Show
data TravisIRC = TravisIRC
{ tiChannels :: [String]
, tiSkipJoin :: Bool
, tiTemplate :: [String]
}
deriving Show
data TravisMatrix = TravisMatrix
{ tmInclude :: [TravisJob]
, tmAllowFailures :: [TravisAllowFailure]
}
deriving Show
data TravisJob = TravisJob
{ tjCompiler :: String
, tjEnv :: Maybe String
, tjAddons :: TravisAddons
, tjOS :: String
}
deriving Show
data TravisAddons = TravisAddons
{ taApt :: TravisApt
, taPostgres :: Maybe String
, taGoogleChrome :: Bool
}
deriving Show
data TravisApt = TravisApt
{ taPackages :: [String]
, taSources :: [TravisAptSource]
}
deriving Show
data TravisAptSource
= TravisAptSource String
| TravisAptSourceLine String (Maybe String)
deriving Show
newtype TravisAllowFailure = TravisAllowFailure
{ tafCompiler :: String
}
deriving Show
(~>) :: String -> Yaml [String] -> ([String], String, Yaml [String])
k ~> v = ([],k,v)
(^^^) :: ([String], String, Yaml [String]) -> String -> ([String], String, Yaml [String])
(a,b,c) ^^^ d = (d : a, b, c)
shListToYaml :: [Sh] -> Yaml [String]
shListToYaml shs = YList [] $ concat
[ YString cs x : map fromString xs
| (cs, x :| xs) <- gr shs
]
where
gr :: [Sh] -> [([String], NonEmpty String)]
gr [] = []
gr (Sh x : rest) = case gr rest of
([], xs) : xss -> ([], NE.cons x xs) : xss
xss -> ([], pure x) : xss
gr (Comment c : rest) = case gr rest of
(cs, xs) : xss -> (c : cs, xs) : xss
[] -> []
ykeyValuesFilt :: ann -> [(ann, String, Yaml ann)] -> Yaml ann
ykeyValuesFilt ann xs = YKeyValues ann
[ x
| x@(_,_,y) <- xs
, not (isEmpty y)
]
ylistFilt :: ann -> [Yaml ann] -> Yaml ann
ylistFilt ann xs = YList ann
[ x
| x <- xs
, not (isEmpty x)
]
isEmpty :: Yaml ann -> Bool
isEmpty (YList _ []) = True
isEmpty (YKeyValues _ []) = True
isEmpty _ = False
instance ToYaml Travis where
toYaml Travis {..} = ykeyValuesFilt []
[ "version" ~> fromString "~> 1.0"
, "language" ~> fromString travisLanguage
, "os" ~> fromString "linux"
, "dist" ~> fromString (showUbuntu travisUbuntu)
, "git" ~> toYaml travisGit
, "branches" ~> toYaml travisBranches
, "notifications" ~> toYaml travisNotifications
, "services" ~> YList [] (map fromString travisServices)
, "addons" ~> toYaml travisAddons
, "cache" ~> toYaml travisCache
, "before_cache" ~> shListToYaml travisBeforeCache
, "jobs" ~> toYaml travisMatrix
, "before_install" ~> shListToYaml travisBeforeInstall
, "install" ~> shListToYaml travisInstall
, "script" ~> shListToYaml travisScript
]
instance ToYaml TravisGit where
toYaml TravisGit {..} = ykeyValuesFilt []
[ "submodules" ~> toYaml tgSubmodules
^^^ "whether to recursively clone submodules"
]
instance ToYaml TravisBranches where
toYaml TravisBranches {..} = ykeyValuesFilt []
[ "only" ~> ylistFilt [] (map fromString tbOnly)
]
instance ToYaml TravisNotifications where
toYaml TravisNotifications {..} = ykeyValuesFilt [] $ buildList $ do
for_ tnIRC $ \y -> item $ "irc" ~> toYaml y
unless tnEmail $ item $ "email" ~> toYaml False
instance ToYaml TravisIRC where
toYaml TravisIRC {..} = ykeyValuesFilt []
[ "channels" ~> YList [] (map fromString tiChannels)
, "skip_join" ~> toYaml tiSkipJoin
, "template" ~> YList [] (map fromString tiTemplate)
]
instance ToYaml TravisCache where
toYaml TravisCache {..} = ykeyValuesFilt []
[ "directories" ~> ylistFilt []
[ fromString d
| d <- tcDirectories
]
]
instance ToYaml TravisMatrix where
toYaml TravisMatrix {..} = ykeyValuesFilt []
[ "include" ~> ylistFilt [] (map toYaml tmInclude)
, "allow_failures" ~> ylistFilt [] (map toYaml tmAllowFailures)
]
instance ToYaml TravisJob where
toYaml TravisJob {..} = ykeyValuesFilt [] $ buildList $ do
item $ "compiler" ~> fromString tjCompiler
item $ "addons" ~> toYaml (Aeson.toJSON tjAddons)
for_ tjEnv $ \e ->
item $ "env" ~> fromString e
item $ "os" ~> fromString tjOS
instance ToYaml TravisAllowFailure where
toYaml TravisAllowFailure {..} = ykeyValuesFilt []
[ "compiler" ~> fromString tafCompiler
]
instance ToYaml TravisAddons where
toYaml TravisAddons {..} = ykeyValuesFilt [] $ buildList $ do
for_ taPostgres $ \p ->
item $ "postgresql" ~> fromString p
when taGoogleChrome $
item $ "google" ~> fromString "stable"
instance Aeson.ToJSON TravisAddons where
toJSON TravisAddons {..} = Aeson.object
[ "apt" Aeson..= taApt
]
instance Aeson.ToJSON TravisApt where
toJSON TravisApt {..} = Aeson.object
[ "packages" Aeson..= taPackages
, "sources" Aeson..= taSources
]
instance Aeson.ToJSON TravisAptSource where
toJSON (TravisAptSource s) = Aeson.toJSON s
toJSON (TravisAptSourceLine sl Nothing) = Aeson.object
[ "sourceline" Aeson..= sl
]
toJSON (TravisAptSourceLine sl (Just key_url)) = Aeson.object
[ "sourceline" Aeson..= sl
, "key_url" Aeson..= key_url
]