{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ApplicativeDo #-}
module Gyehoek.Sexp.Syntax
  ( DatumF(..)
  , Simple(..)
  , CompoundF(..)
  , Prefix(..)
  , Delimiter(..)
  , Label(..)
  , SourcePos(..)
  , Datum
  , Cofree((:<))
  , Fix(..)
  , Compound
  , Indentation(..)
  , Syn(..)
  , pattern Simple
  , pattern Compound
  , pattern Labeled
  , pattern LabelRef
  , pattern Meta
  , pattern MetaSplice
  , pattern Abbrev
  , pattern Vector
  , pattern DotList
  , pattern Gyehoek.Sexp.Syntax.List
  , syntax
  , indentation
  , adorn
  , indentWith
  , pattern Bytevector
  , pattern Symbol
  , pattern String
  , pattern Character
  , pattern Number
  , pattern Boolean
  , Ann(..)
  , noAnn
  , ann
  , pattern List'
  , position
  , stripAnn
  ) where

import Language.Haskell.TH.Syntax (Lift (lift), liftData)
import Data.Scientific (Scientific)
import Data.ByteString (ByteString)
import Gyehoek.Prelude hiding ((:<), Simple)
import Text.Megaparsec.Pos (SourcePos(..), sourcePosPretty)
import Control.Comonad.Cofree (Cofree((:<)), _extract, _unwrap)
import Data.Fix (Fix (..))
import Data.Functor.Foldable
import Text.Show.Deriving (deriveShow1)
import Data.Eq.Deriving (deriveEq1)
import qualified Control.Comonad.Trans.Cofree as F
import Prettyprinter (Pretty (pretty), viaShow)
import Gyehoek.Lift1 (Lift1 (liftLift))
import Data.Data (Typeable, cast)
import Language.Haskell.TH
import qualified Data.Text as T
import Control.Comonad.Trans.Cofree (tailF)


data DatumF a
  = SimpleF Simple
  | CompoundF (CompoundF a)
  | LabeledF Label a
  | LabelRefF Label
  | MetaF Text
  | MetaSpliceF Text
  deriving stock (Show, Eq, Data, Generic, Lift, Functor, Foldable, Traversable)
  deriving anyclass (NFData)

data Simple
  = SimpleBoolean Bool
  | SimpleNumber Scientific
  | SimpleCharacter Char
  | SimpleString Text
  | SimpleSymbol Text
  | SimpleBytevector ByteString
  deriving stock (Show, Eq, Data, Generic, Lift)
  deriving anyclass (NFData)

data CompoundF a
  = ListF Indentation (List a)
  | DotListF (NonEmpty a) a
  | VectorF (List a)
  | AbbrevF Prefix a
  deriving stock (Show, Eq, Data, Generic, Lift, Functor, Foldable, Traversable)
  deriving anyclass (NFData)

data Prefix
  = Quote | Backtick | Comma | CommaAt
  deriving stock (Show, Eq, Data, Generic, Lift)
  deriving anyclass (NFData)

data Delimiter
  = Paren
  | Square
  | Curly
  deriving stock (Show, Eq, Data, Generic, Lift)
  deriving anyclass (NFData)

newtype Label = MkLabel Natural
  deriving stock (Data, Generic, Lift)
  deriving newtype (Eq, Ord, Show)
  deriving anyclass (NFData)



type Datum = Cofree DatumF Ann
type Compound = CompoundF Datum

data Indentation
  = NSpecial Int
  | Ordinary
  deriving stock (Data, Eq, Generic, Show, Lift, Read)
  deriving anyclass (NFData)

data Syn
  = SynMacro
  | SynBuiltin
  | SynProcedure
  | SynParen Int
  | SynString
  | SynConstant
  | SynNone
  deriving (Show, Read, Data, Generic, Eq, Lift)

data Ann = MkAnn
  { syntax :: Syn
  , position :: Maybe SourcePos
  }
  deriving (Show, Data, Eq, Generic)

noAnn :: Ann
noAnn = MkAnn
  { syntax = SynNone
  , position = Nothing
  }

-- requisite of the Pretty instance for invertible-grammar's error type.
instance Pretty Ann where
  pretty = pretty . maybe "<unknown>" sourcePosPretty . view #position

deriveShow1 ''CompoundF
deriveEq1 ''CompoundF
deriveShow1 ''DatumF
deriveEq1 ''DatumF


--- modification and extraction of annotations

ann :: Lens' Datum Ann
ann = _extract

syntax :: Lens' Datum Syn
syntax = ann . #syntax

position :: Lens' Datum (Maybe SourcePos)
position = ann . #position

indentation :: Traversal' Datum Indentation
indentation k (syn :< CompoundF (ListF ind xs)) = do
  ind' <- k ind
  pure $ syn :< CompoundF (ListF ind' xs)
indentation k a = pure a

adorn :: Syn -> Datum -> Datum
adorn = set syntax

indentWith :: Indentation -> Datum -> Datum
indentWith = set indentation

stripAnn :: Datum -> Fix DatumF
stripAnn = hoist tailF


--- pattern synonyms

pattern Simple :: Simple -> Datum
pattern Simple a <- _ :< SimpleF a
  where Simple a = noAnn :< SimpleF a

pattern Compound :: CompoundF Datum -> Datum
pattern Compound a <- _ :< CompoundF a
  where Compound a = noAnn :< CompoundF a

pattern Labeled :: Label -> Datum -> Datum
pattern Labeled l a <- _ :< LabeledF l a
  where Labeled l a = noAnn :< LabeledF l a

pattern LabelRef :: Label -> Datum
pattern LabelRef l <- _ :< LabelRefF l
  where LabelRef l = noAnn :< LabelRefF l

pattern MetaSplice :: Text -> Datum
pattern MetaSplice x <- _ :< MetaSpliceF x
  where MetaSplice x = noAnn :< MetaSpliceF x

pattern Meta :: Text -> Datum
pattern Meta x <- _ :< MetaF x
  where Meta x = noAnn :< MetaF x

pattern List :: List Datum -> Datum
pattern List a <- _ :< CompoundF (ListF _ a)
  where List a = noAnn :< CompoundF (ListF Ordinary a)

pattern List' :: Indentation -> List Datum -> Datum
pattern List' ind a <- _ :< CompoundF (ListF ind a)
  where List' ind a = noAnn :< CompoundF (ListF ind a)

pattern DotList :: NonEmpty Datum -> Datum -> Datum
pattern DotList xs x <- _ :< CompoundF (DotListF xs x)
  where DotList xs x = noAnn :< CompoundF (DotListF xs x)

pattern Vector :: [Datum] -> Datum
pattern Vector xs <- _ :< CompoundF (VectorF xs)
  where Vector xs = noAnn :< CompoundF (VectorF xs)

pattern Abbrev :: Prefix -> Datum -> Datum
pattern Abbrev p a <- _ :< CompoundF (AbbrevF p a)
  where Abbrev p a = noAnn :< CompoundF (AbbrevF p a)

pattern Boolean a = Simple (SimpleBoolean a)
pattern Number a = Simple (SimpleNumber a)
pattern Character a = Simple (SimpleCharacter a)
pattern String a = Simple (SimpleString a)
pattern Symbol a = Simple (SimpleSymbol a)
pattern Bytevector a = Simple (SimpleBytevector a)


--- Lift1 instances

instance Lift1 DatumF where
  liftLift l = \case
    SimpleF s -> [|SimpleF $(lift s)|]
    CompoundF c -> [|CompoundF $(liftLift l c)|]
    LabeledF lbl x -> [|LabeledF $(lift lbl) $(l x)|]
    LabelRefF lbl -> [|LabelRefF $(lift lbl)|]
    MetaF x -> [|MetaF $(lift x)|]
    MetaSpliceF x -> [|MetaSpliceF $(lift x)|]

instance Lift1 CompoundF where
  liftLift l = \case
    ListF ind xs -> [|ListF $(lift ind) $(liftLift l xs)|]
    DotListF xs t -> [|DotListF $(liftLift l xs) $(l t)|]
    VectorF xs -> [|VectorF $(liftLift l xs)|]
    AbbrevF p x -> [|AbbrevF $(lift p) $(l x)|]