{-# LANGUAGE OverloadedStrings #-}

-- | Disney体験記録のJSON生成パイプラインモジュール
-- このモジュールは、Hakyllコンテキストでディズニーログを集約し、
-- D3.js可視化用のJSONデータを生成する
module Data.Disney.Experience.Generator
    ( generateVisualizationData
    , aggregateDailyData
    , aggregateTagData
    , aggregateByYear
    , parseLogMetadata
    ) where

import           Control.Monad          (forM)
import           Data.Aeson             (encode)
import qualified Data.ByteString.Lazy   as BL
import           Data.Disney.Experience
import           Data.List              (foldl', sort)
import qualified Data.Map.Strict        as M
import           Data.Maybe             (fromMaybe)
import           Data.Text              (Text)
import qualified Data.Text              as T
import           Data.Time              (Day, defaultTimeLocale, parseTimeM,
                                         toGregorian)
import           Hakyll

-- | メタデータから体験記録をパースする
parseLogMetadata :: Metadata -> Maybe ExperienceRecord
parseLogMetadata :: Metadata -> Maybe ExperienceRecord
parseLogMetadata Metadata
meta = do
    String
titleStr <- String -> Metadata -> Maybe String
lookupString String
"title" Metadata
meta
    String
dateStr <- String -> Metadata -> Maybe String
lookupString String
"date" Metadata
meta
    Day
date <- Bool -> TimeLocale -> String -> String -> Maybe Day
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%Y-%m-%d" String
dateStr
    let tagsStr :: String
tagsStr = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Metadata -> Maybe String
lookupString String
"disney-tags" Metadata
meta
        tags :: [Text]
tags = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"," (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
tagsStr
        aiGeneratedByStr :: String
aiGeneratedByStr = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Metadata -> Maybe String
lookupString String
"ai-generated-by" Metadata
meta
        aiGeneratedBy :: Text
aiGeneratedBy = Text -> Text
T.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
aiGeneratedByStr
        aiGeneratedStr :: String
aiGeneratedStr = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"false" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Metadata -> Maybe String
lookupString String
"ai-generated" Metadata
meta
        aiGenerated :: Bool
aiGenerated = (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
aiGeneratedBy) Bool -> Bool -> Bool
|| Text -> Text
T.toLower (String -> Text
T.pack String
aiGeneratedStr) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"true"

        -- SNSリンクの取得
        youtube :: [Text]
youtube = String -> [Text]
parseLinks (String -> [Text]) -> String -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Metadata -> Maybe String
lookupString String
"youtube" Metadata
meta
        instagram :: [Text]
instagram = String -> [Text]
parseLinks (String -> [Text]) -> String -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Metadata -> Maybe String
lookupString String
"instagram" Metadata
meta
        xLinks :: [Text]
xLinks = String -> [Text]
parseLinks (String -> [Text]) -> String -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Metadata -> Maybe String
lookupString String
"x" Metadata
meta
        note :: [Text]
note = String -> [Text]
parseLinks (String -> [Text]) -> String -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Metadata -> Maybe String
lookupString String
"note" Metadata
meta

        snsLinks :: SNSLinks
snsLinks = SNSLinks
            { youtube :: [Text]
youtube = [Text]
youtube
            , instagram :: [Text]
instagram = [Text]
instagram
            , x :: [Text]
x = [Text]
xLinks
            , note :: [Text]
note = [Text]
note
            }

    ExperienceRecord -> Maybe ExperienceRecord
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ExperienceRecord
        { title :: Text
title = String -> Text
T.pack String
titleStr
        , date :: Day
date = Day
date
        , disneyTags :: [Text]
disneyTags = [Text]
tags
        , snsLinks :: SNSLinks
snsLinks = SNSLinks
snsLinks
        , aiGenerated :: Bool
aiGenerated = Bool
aiGenerated
        }

-- | カンマ区切りの文字列をリストにパース
parseLinks :: String -> [Text]
parseLinks :: String -> [Text]
parseLinks String
str = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"," (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
str

-- | 日別データを集約
aggregateDailyData :: [ExperienceRecord] -> [DailyCount]
aggregateDailyData :: [ExperienceRecord] -> [DailyCount]
aggregateDailyData [ExperienceRecord]
records =
    let dateCountMap :: Map Day Int
dateCountMap = (Map Day Int -> ExperienceRecord -> Map Day Int)
-> Map Day Int -> [ExperienceRecord] -> Map Day Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map Day Int
acc ExperienceRecord
rec -> (Int -> Int -> Int) -> Day -> Int -> Map Day Int -> Map Day Int
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (ExperienceRecord -> Day
date ExperienceRecord
rec) Int
1 Map Day Int
acc) Map Day Int
forall k a. Map k a
M.empty [ExperienceRecord]
records
        sortedDates :: [Day]
sortedDates = [Day] -> [Day]
forall a. Ord a => [a] -> [a]
sort ([Day] -> [Day]) -> [Day] -> [Day]
forall a b. (a -> b) -> a -> b
$ Map Day Int -> [Day]
forall k a. Map k a -> [k]
M.keys Map Day Int
dateCountMap
    in (Day -> DailyCount) -> [Day] -> [DailyCount]
forall a b. (a -> b) -> [a] -> [b]
map (\Day
d -> Day -> Int -> DailyCount
DailyCount Day
d (Map Day Int
dateCountMap Map Day Int -> Day -> Int
forall k a. Ord k => Map k a -> k -> a
M.! Day
d)) [Day]
sortedDates

-- | タグ別データを集約
aggregateTagData :: [ExperienceRecord] -> [TagCount]
aggregateTagData :: [ExperienceRecord] -> [TagCount]
aggregateTagData [ExperienceRecord]
records =
    let tagCountMap :: Map Text Int
tagCountMap = (Map Text Int -> ExperienceRecord -> Map Text Int)
-> Map Text Int -> [ExperienceRecord] -> Map Text Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map Text Int
acc ExperienceRecord
rec -> (Map Text Int -> Text -> Map Text Int)
-> Map Text Int -> [Text] -> Map Text Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map Text Int
m Text
tag -> (Int -> Int -> Int) -> Text -> Int -> Map Text Int -> Map Text Int
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Text
tag Int
1 Map Text Int
m) Map Text Int
acc (ExperienceRecord -> [Text]
disneyTags ExperienceRecord
rec)) Map Text Int
forall k a. Map k a
M.empty [ExperienceRecord]
records
        sortedTags :: [Text]
sortedTags = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Map Text Int -> [Text]
forall k a. Map k a -> [k]
M.keys Map Text Int
tagCountMap
    in (Text -> TagCount) -> [Text] -> [TagCount]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
t -> Text -> Int -> TagCount
TagCount Text
t (Map Text Int
tagCountMap Map Text Int -> Text -> Int
forall k a. Ord k => Map k a -> k -> a
M.! Text
t)) [Text]
sortedTags

-- | 年度別にデータを集約
aggregateByYear :: [ExperienceRecord] -> [YearData]
aggregateByYear :: [ExperienceRecord] -> [YearData]
aggregateByYear [ExperienceRecord]
records =
    let yearGrouped :: Map Int [ExperienceRecord]
yearGrouped = ([ExperienceRecord] -> [ExperienceRecord] -> [ExperienceRecord])
-> [(Int, [ExperienceRecord])] -> Map Int [ExperienceRecord]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [ExperienceRecord] -> [ExperienceRecord] -> [ExperienceRecord]
forall a. [a] -> [a] -> [a]
(++) [(Day -> Int
forall {a}. Num a => Day -> a
getYear (Day -> Int) -> Day -> Int
forall a b. (a -> b) -> a -> b
$ ExperienceRecord -> Day
date ExperienceRecord
rec, [ExperienceRecord
rec]) | ExperienceRecord
rec <- [ExperienceRecord]
records]
        sortedYears :: [Int]
sortedYears = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Map Int [ExperienceRecord] -> [Int]
forall k a. Map k a -> [k]
M.keys Map Int [ExperienceRecord]
yearGrouped
    in (Int -> YearData) -> [Int] -> [YearData]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
y -> Int -> [DailyCount] -> YearData
YearData Int
y ([ExperienceRecord] -> [DailyCount]
aggregateDailyData (Map Int [ExperienceRecord]
yearGrouped Map Int [ExperienceRecord] -> Int -> [ExperienceRecord]
forall k a. Ord k => Map k a -> k -> a
M.! Int
y))) [Int]
sortedYears
  where
    getYear :: Day -> a
getYear Day
day = let (Year
y, Int
_, Int
_) = Day -> (Year, Int, Int)
toGregorian Day
day in Year -> a
forall a. Num a => Year -> a
fromInteger Year
y

-- | 可視化データを生成
generateVisualizationData :: [Item a] -> Compiler VisualizationData
generateVisualizationData :: forall a. [Item a] -> Compiler VisualizationData
generateVisualizationData [Item a]
items = do
    [Maybe ExperienceRecord]
records <- [Item a]
-> (Item a -> Compiler (Maybe ExperienceRecord))
-> Compiler [Maybe ExperienceRecord]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Item a]
items ((Item a -> Compiler (Maybe ExperienceRecord))
 -> Compiler [Maybe ExperienceRecord])
-> (Item a -> Compiler (Maybe ExperienceRecord))
-> Compiler [Maybe ExperienceRecord]
forall a b. (a -> b) -> a -> b
$ \Item a
item -> do
        Metadata
meta <- Identifier -> Compiler Metadata
forall (m :: * -> *). MonadMetadata m => Identifier -> m Metadata
getMetadata (Item a -> Identifier
forall a. Item a -> Identifier
itemIdentifier Item a
item)
        Maybe ExperienceRecord -> Compiler (Maybe ExperienceRecord)
forall a. a -> Compiler a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ExperienceRecord -> Compiler (Maybe ExperienceRecord))
-> Maybe ExperienceRecord -> Compiler (Maybe ExperienceRecord)
forall a b. (a -> b) -> a -> b
$ Metadata -> Maybe ExperienceRecord
parseLogMetadata Metadata
meta

    let validRecords :: [ExperienceRecord]
validRecords = [ExperienceRecord
rec | Just ExperienceRecord
rec <- [Maybe ExperienceRecord]
records]
        dailyData :: [DailyCount]
dailyData = [ExperienceRecord] -> [DailyCount]
aggregateDailyData [ExperienceRecord]
validRecords
        tagData :: [TagCount]
tagData = [ExperienceRecord] -> [TagCount]
aggregateTagData [ExperienceRecord]
validRecords
        yearlyData :: [YearData]
yearlyData = [ExperienceRecord] -> [YearData]
aggregateByYear [ExperienceRecord]
validRecords

        timeSeriesData :: TimeSeriesData
timeSeriesData = TimeSeriesData { daily :: [DailyCount]
daily = [DailyCount]
dailyData }
        tagStatsData :: TagStats
tagStatsData = TagStats { tags :: [TagCount]
tags = [TagCount]
tagData }

    VisualizationData -> Compiler VisualizationData
forall a. a -> Compiler a
forall (m :: * -> *) a. Monad m => a -> m a
return VisualizationData
        { timeSeries :: TimeSeriesData
timeSeries = TimeSeriesData
timeSeriesData
        , tagStats :: TagStats
tagStats = TagStats
tagStatsData
        , yearlyTimeSeries :: [YearData]
yearlyTimeSeries = [YearData]
yearlyData
        }

-- | JSONファイルとして保存
saveVisualizationDataAsJSON :: VisualizationData -> FilePath -> IO ()
saveVisualizationDataAsJSON :: VisualizationData -> String -> IO ()
saveVisualizationDataAsJSON VisualizationData
vizData String
filepath =
    String -> ByteString -> IO ()
BL.writeFile String
filepath (VisualizationData -> ByteString
forall a. ToJSON a => a -> ByteString
encode VisualizationData
vizData)