{-# LANGUAGE OverloadedStrings #-}
module Database.Schema.Migrations.Filesystem.Serialize
    ( serializeMigration
    )
where

import Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import Data.Text ( Text )
import qualified Data.Text as T
import Data.String.Conversions ( cs )
import Data.Time () -- for UTCTime Show instance
import Data.Maybe ( catMaybes )
import Data.Monoid ( (<>) )

import Database.Schema.Migrations.Migration
    ( Migration(..)
    )

type FieldSerializer = Migration -> Maybe ByteString

fieldSerializers :: [FieldSerializer]
fieldSerializers :: [FieldSerializer]
fieldSerializers = [ FieldSerializer
serializeDesc
                   , FieldSerializer
serializeTimestamp
                   , FieldSerializer
serializeDepends
                   , FieldSerializer
serializeApply
                   , FieldSerializer
serializeRevert
                   ]

serializeDesc :: FieldSerializer
serializeDesc :: FieldSerializer
serializeDesc Migration
m =
    case Migration -> Maybe Text
mDesc Migration
m of
      Maybe Text
Nothing -> Maybe ByteString
forall a. Maybe a
Nothing
      Just Text
desc -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (Text -> ByteString) -> Text -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Maybe ByteString) -> Text -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text
"Description: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
desc

serializeTimestamp :: FieldSerializer
serializeTimestamp :: FieldSerializer
serializeTimestamp Migration
m =
    case Migration -> Maybe UTCTime
mTimestamp Migration
m of
        Maybe UTCTime
Nothing -> Maybe ByteString
forall a. Maybe a
Nothing
        Just UTCTime
ts -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
"Created: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (String -> ByteString)
-> (UTCTime -> String) -> UTCTime -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> String
forall a. Show a => a -> String
show (UTCTime -> ByteString) -> UTCTime -> ByteString
forall a b. (a -> b) -> a -> b
$ UTCTime
ts)

serializeDepends :: FieldSerializer
serializeDepends :: FieldSerializer
serializeDepends Migration
m = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (Text -> ByteString) -> Text -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Maybe ByteString) -> Text -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text
"Depends: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> [Text] -> Text
T.intercalate Text
" " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Migration -> [Text]
mDeps Migration
m)

serializeRevert :: FieldSerializer
serializeRevert :: FieldSerializer
serializeRevert Migration
m =
    case Migration -> Maybe Text
mRevert Migration
m of
      Maybe Text
Nothing -> Maybe ByteString
forall a. Maybe a
Nothing
      Just Text
revert -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
"Revert: |\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
                     (Text -> ByteString
serializeMultiline Text
revert)

serializeApply :: FieldSerializer
serializeApply :: FieldSerializer
serializeApply Migration
m = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
"Apply: |\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (Text -> ByteString
serializeMultiline (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Migration -> Text
mApply Migration
m)

commonPrefix :: Text -> Text -> Text
commonPrefix :: Text -> Text -> Text
commonPrefix Text
a Text
b = String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text)
-> ([(Char, Char)] -> String) -> [(Char, Char)] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char, Char) -> Char) -> [(Char, Char)] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Char, Char) -> Char
forall a b. (a, b) -> a
fst ([(Char, Char)] -> Text) -> [(Char, Char)] -> Text
forall a b. (a -> b) -> a -> b
$ ((Char, Char) -> Bool) -> [(Char, Char)] -> [(Char, Char)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((Char -> Char -> Bool) -> (Char, Char) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==)) (Text -> Text -> [(Char, Char)]
T.zip Text
a Text
b)

commonPrefixLines :: [Text] -> Text
commonPrefixLines :: [Text] -> Text
commonPrefixLines [] = Text
""
commonPrefixLines [Text]
theLines = (Text -> Text -> Text) -> [Text] -> Text
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Text -> Text -> Text
commonPrefix [Text]
theLines

serializeMultiline :: Text -> ByteString
serializeMultiline :: Text -> ByteString
serializeMultiline Text
s =
    let sLines :: [Text]
sLines = Text -> [Text]
T.lines Text
s
        prefix :: Text
prefix = case Text -> Char
T.head (Text -> Char) -> Text -> Char
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
commonPrefixLines [Text]
sLines of
                   -- If the lines already have a common prefix that
                   -- begins with whitespace, no new prefix is
                   -- necessary.
                   Char
' ' -> Text
""
                   -- Otherwise, use a new prefix of two spaces.
                   Char
_ -> Text
"  "

    in Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> ([Text] -> Text) -> [Text] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> ByteString) -> [Text] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
sLines

serializeMigration :: Migration -> ByteString
serializeMigration :: Migration -> ByteString
serializeMigration Migration
m = ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
"\n" [ByteString]
fields
    where
      fields :: [ByteString]
fields = [Maybe ByteString] -> [ByteString]
forall a. [Maybe a] -> [a]
catMaybes [ FieldSerializer
f Migration
m | FieldSerializer
f <- [FieldSerializer]
fieldSerializers ]