content: {-# language LambdaCase #-}
  {-# language DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveGeneric #-}
  
  {-|
  Module      : Language.Python.Syntax.CommaSep
  Copyright   : (C) CSIRO 2017-2019
  License     : BSD3
  Maintainer  : Isaac Elliott <isaace71295@gmail.com>
  Stability   : experimental
  Portability : non-portable
  -}
  
  module Language.Python.Syntax.CommaSep
    ( Comma(..)
    , CommaSep(..), _CommaSep, csTrailingWhitespace
    , appendCommaSep, maybeToCommaSep, listToCommaSep
    , CommaSep1(..)
    , commaSep1Head, appendCommaSep1, listToCommaSep1, listToCommaSep1'
    , CommaSep1'(..)
    , _CommaSep1'
    )
  where
  
  import Control.Lens.Getter ((^.))
  import Control.Lens.Iso (Iso, iso)
  import Control.Lens.Lens (lens)
  import Control.Lens.Setter ((.~))
  import Control.Lens.Traversal (Traversal')
  import Data.Coerce (coerce)
  import Data.Function ((&))
  import Data.Functor (($>))
  import Data.Functor.Apply ((<.>))
  import Data.List.NonEmpty (NonEmpty(..))
  import Data.Maybe (fromMaybe)
  import Data.Semigroup (Semigroup(..))
  import Data.Semigroup.Foldable (Foldable1(..))
  import Data.Semigroup.Traversable (Traversable1(..), foldMap1Default)
  import GHC.Generics (Generic)
  
  import Language.Python.Syntax.Punctuation
  import Language.Python.Syntax.Whitespace (Whitespace (Space), HasTrailingWhitespace (..))
  
  -- | Items separated by commas, with optional whitespace following each comma
  data CommaSep a
    = CommaSepNone
    | CommaSepOne a
    | CommaSepMany a Comma (CommaSep a)
    deriving (Eq, Show, Functor, Foldable, Traversable, Generic)
  
  -- | 'Traversal' targeting the trailing whitespace in a comma separated list.
  --
  -- This can't be an instance of 'HasTrailingWhitespace' because 'CommaSepNone' never
  -- has trailing whitespace.
  csTrailingWhitespace
    :: HasTrailingWhitespace a
    => Traversal' (CommaSep a) [Whitespace]
  csTrailingWhitespace _ CommaSepNone = pure CommaSepNone
  csTrailingWhitespace f (CommaSepOne a) = CommaSepOne <$> trailingWhitespace f a
  csTrailingWhitespace f (CommaSepMany a (MkComma b) CommaSepNone) =
    (\b' -> CommaSepMany a (MkComma b') CommaSepNone) <$> f b
  csTrailingWhitespace f (CommaSepMany a b c) =
    CommaSepMany a b <$> csTrailingWhitespace f c
  
  
  -- | Convert a maybe to a singleton or nullary 'CommaSep'
  maybeToCommaSep :: Maybe a -> CommaSep a
  maybeToCommaSep = maybe CommaSepNone CommaSepOne
  
  -- | Convert a list to a 'CommaSep'
  --
  -- Anywhere where whitespace is ambiguous, this function puts a single space
  listToCommaSep :: [a] -> CommaSep a
  listToCommaSep [] = CommaSepNone
  listToCommaSep [a] = CommaSepOne a
  listToCommaSep (a:as) = CommaSepMany a (MkComma [Space]) $ listToCommaSep as
  
  -- | Appends two comma separated values together.
  --
  -- The provided whitespace is to follow the joining comma which is added
  appendCommaSep :: [Whitespace] -> CommaSep a -> CommaSep a -> CommaSep a
  appendCommaSep _  CommaSepNone b = b
  appendCommaSep _  (CommaSepOne a) CommaSepNone = CommaSepOne a
  appendCommaSep ws (CommaSepOne a) (CommaSepOne b) = CommaSepMany a (MkComma ws) (CommaSepOne b)
  appendCommaSep ws (CommaSepOne a) (CommaSepMany b c cs) = CommaSepMany a (MkComma ws) (CommaSepMany b c cs)
  appendCommaSep ws (CommaSepMany a c cs) b = CommaSepMany a c (appendCommaSep ws cs b)
  
  instance Semigroup (CommaSep a) where
    (<>) = appendCommaSep [Space]
  
  instance Monoid (CommaSep a) where
    mempty  = CommaSepNone
    mappend = (<>)
  
  -- | Non-empty 'CommaSep'
  data CommaSep1 a
    = CommaSepOne1 a
    | CommaSepMany1 a Comma (CommaSep1 a)
    deriving (Eq, Show, Functor, Foldable, Traversable, Generic)
  
  instance Foldable1 CommaSep1 where; foldMap1 = foldMap1Default
  instance Traversable1 CommaSep1 where
    traverse1 f = go
      where
        go (CommaSepOne1 a) = CommaSepOne1 <$> f a
        go (CommaSepMany1 a b c) = (\a' c' -> CommaSepMany1 a' b c') <$> f a <.> go c
  
  -- | Get the first element of a 'CommaSep1'
  commaSep1Head :: CommaSep1 a -> a
  commaSep1Head (CommaSepOne1 a) = a
  commaSep1Head (CommaSepMany1 a _ _) = a
  
  -- | Appends two non-empty comma separated values together.
  --
  -- The provided whitespace is to follow the joining comma which is added
  appendCommaSep1 :: [Whitespace] -> CommaSep1 a -> CommaSep1 a -> CommaSep1 a
  appendCommaSep1 ws a b =
    CommaSepMany1
      (case a of; CommaSepOne1 x -> x;  CommaSepMany1 x _ _  -> x)
      (case a of; CommaSepOne1 _ -> MkComma ws; CommaSepMany1 _ ws' _ -> ws')
      (case a of; CommaSepOne1 _ -> b;  CommaSepMany1 _ _ x  -> x <> b)
  
  instance Semigroup (CommaSep1 a) where
    (<>) = appendCommaSep1 [Space]
  
  instance HasTrailingWhitespace s => HasTrailingWhitespace (CommaSep1 s) where
    trailingWhitespace =
      lens
        (\case
           CommaSepOne1 a -> a ^. trailingWhitespace
           CommaSepMany1 _ _ a -> a ^. trailingWhitespace)
        (\cs ws ->
           case cs of
             CommaSepOne1 a ->
               CommaSepOne1 (a & trailingWhitespace .~ ws)
             CommaSepMany1 a b c -> CommaSepMany1 (coerce a) b (c & trailingWhitespace .~ ws))
  
  -- | Convert a 'NonEmpty' to a 'CommaSep1'
  --
  -- Anywhere where whitespace is ambiguous, this function puts a single space
  listToCommaSep1 :: NonEmpty a -> CommaSep1 a
  listToCommaSep1 (a :| as) = go (a:as)
    where
      go [] = error "impossible"
      go [x] = CommaSepOne1 x
      go (x:xs) = CommaSepMany1 x (MkComma [Space]) $ go xs
  
  -- | Non-empty 'CommaSep', optionally terminated by a comma
  --
  -- Assumes that the contents consumes trailing whitespace
  data CommaSep1' a
    = CommaSepOne1' a (Maybe Comma)
    | CommaSepMany1' a Comma (CommaSep1' a)
    deriving (Eq, Show, Functor, Foldable, Traversable, Generic)
  
  instance Foldable1 CommaSep1' where; foldMap1 = foldMap1Default
  instance Traversable1 CommaSep1' where
    traverse1 f = go
      where
        go (CommaSepOne1' a b) = (\a' -> CommaSepOne1' a' b) <$> f a
        go (CommaSepMany1' a b c) = (\a' c' -> CommaSepMany1' a' b c') <$> f a <.> go c
  
  -- | Iso to unpack a 'CommaSep'
  _CommaSep
    :: Iso
         (Maybe (a, [(Comma, a)], Maybe Comma))
         (Maybe (b, [(Comma, b)], Maybe Comma))
         (CommaSep a)
         (CommaSep b)
  _CommaSep = iso toCs fromCs
    where
      toCs :: Maybe (a, [(Comma, a)], Maybe Comma) -> CommaSep a
      toCs Nothing = CommaSepNone
      toCs (Just (a, b, c)) =
        case b of
          [] -> maybe (CommaSepOne a) (\c' -> CommaSepMany a c' CommaSepNone) c
          (d, e):ds -> CommaSepMany a d $ toCs (Just (e, ds, c))
  
      fromCs :: CommaSep a -> Maybe (a, [(Comma, a)], Maybe Comma)
      fromCs CommaSepNone = Nothing
      fromCs (CommaSepOne a) = Just (a, [], Nothing)
      fromCs (CommaSepMany a b c) =
        case fromCs c of
          Nothing -> Just (a, [], Just b)
          Just (x, y, z) -> Just (a, (b, x) : y, z)
  
  -- | Iso to unpack a 'CommaSep1''
  _CommaSep1'
    :: Iso
         (a, [(Comma, a)], Maybe Comma)
         (b, [(Comma, b)], Maybe Comma)
         (CommaSep1' a)
         (CommaSep1' b)
  _CommaSep1' = iso toCs fromCs
    where
      toCs (a, [], b) = CommaSepOne1' a b
      toCs (a, (b, c) : bs, d) = CommaSepMany1' a b $ toCs (c, bs, d)
  
      fromCs (CommaSepOne1' a b) = (a, [], b)
      fromCs (CommaSepMany1' a b c) =
        let
          (d, e, f) = fromCs c
        in
          (a, (b, d) : e, f)
  
  -- | Attempt to insert comma separators into a list, which will not be
  -- terminated by a comma.
  --
  -- If the list is empty, 'Nothing' is returned.
  listToCommaSep1' :: [a] -> Maybe (CommaSep1' a)
  listToCommaSep1' [] = Nothing
  listToCommaSep1' [a] = Just (CommaSepOne1' a Nothing)
  listToCommaSep1' (a:as) =
    CommaSepMany1' a (MkComma [Space]) <$> listToCommaSep1' as
  
  instance HasTrailingWhitespace s => HasTrailingWhitespace (CommaSep1' s) where
    trailingWhitespace =
      lens
        (\case
           CommaSepOne1' a b -> maybe (a ^. trailingWhitespace) (^. trailingWhitespace) b
           CommaSepMany1' _ _ a -> a ^. trailingWhitespace)
        (\cs ws ->
           case cs of
             CommaSepOne1' a b ->
               CommaSepOne1'
                 (fromMaybe (a & trailingWhitespace .~ ws) $ b $> coerce a)
                 (b $> MkComma ws)
             CommaSepMany1' a b c ->
               CommaSepMany1' (coerce a) b (c & trailingWhitespace .~ ws))
  