{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}

module TMS.Spec where

import           Data.Adnot ((.:), (.:?), (.!=))
import qualified Data.Adnot as A
import qualified Data.Foldable as F
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Sequence as S

data TMSSpec = TMSSpec
  { specName      :: T.Text
  , specArtifacts :: S.Seq Artifact
  , specDefaults  :: M.Map T.Text T.Text
  , specTagsets   :: M.Map T.Text Tagset
  } deriving (Eq, Show)

instance A.FromAdnot TMSSpec where
  parseAdnot = A.withProd "TMSSpec" $ \o -> do
    specName      <- o .: "name"
    specArtifacts <- o .: "artifacts"
    specDefaults  <- o .:? "defaults" .!= mempty
    specTagsets   <- o .:? "tagsets"  .!= mempty
    return TMSSpec { .. }

data Artifact
  = ArtifactEvery T.Text ArtifactDesc
  | ArtifactAll T.Text ArtifactDesc
  | ArtifactJust T.Text ArtifactDesc
    deriving (Eq, Show)

instance A.FromAdnot Artifact where
  parseAdnot = A.withSum "artifact" $ \ t as -> do
    let [pathV, descV] = F.toList as
    path <- A.parseAdnot pathV
    desc <- A.parseAdnot descV
    case t of
      "every" -> return $ ArtifactEvery path desc
      "all"   -> return $ ArtifactAll path desc
      "just"  -> return $ ArtifactJust path desc
      _       -> Left "???"


data ArtifactDesc = ArtifactDesc
  { artifactProduces :: T.Text
  , artifactTagset   :: Maybe T.Text
  , artifactArgs     :: M.Map T.Text ArgExpr
  } deriving (Eq, Show)

instance A.FromAdnot ArtifactDesc where
  parseAdnot = A.withProd "artifact description" $ \ o -> do
    artifactProduces <- o .:  "produce"
    artifactTagset   <- o .:? "tagset"
    artifactArgs     <- o .:? "arguments" .!= mempty
    return ArtifactDesc { .. }

data ArgExpr
  = StringExpr T.Text
  | CallExpr T.Text (S.Seq ArgExpr)
    deriving (Eq, Show)

instance A.FromAdnot ArgExpr where
  parseAdnot (A.Sum tag payload) = do
    args <- mapM A.parseAdnot (F.toList payload)
    return (CallExpr tag (S.fromList args))
  parseAdnot (A.String s) = return (StringExpr s)

type Tagset = M.Map T.Text TagDesc

data TagDesc = BasicTag Int [TagFragment] deriving (Eq, Show)

instance A.FromAdnot TagDesc where
  parseAdnot = A.withSum "tag description" $ \ t vs -> do
    let (r:rs) = F.toList vs
    n' <- A.parseAdnot r
    rs' <- mapM A.parseAdnot rs
    return (BasicTag n' rs')


data TagFragment
  = TFString T.Text
  | TFIndex Int
    deriving (Eq, Show)

instance A.FromAdnot TagFragment where
  parseAdnot (A.Integer n) = return (TFIndex (fromIntegral n))
  parseAdnot (A.String t) = return (TFString t)
  parseAdnot _ = Left "Invalid fragment type"