-- | cribbed from sexp-grammar:Language.SexpGrammar.Base
module Gyehoek.Sexp.Grammar.Base
  ( module Gyehoek.Sexp.Syntax
  , module Data.InvertibleGrammar.Combinators
  , expected, unexpected
  -- * types
  , G
  , Grammar
  , DatumGrammar
  , DataGrammar
  , Grammar
  , ListContext
  , (:-)((:-))
  -- * lists
  , list
  , el
  , rest
  -- * atoms
  , simple
  , string
  , symbol
  , sym
  , boolean
  , number
  , integer
  , headTagged1'
  , headTagged1
  , headTagged2
  , int
  , letLike
  , ifLike
  , headTagged0'
  , headTagged0
  , lambdaLike
  , lambdaKeyword
  , kappaKeyword
  , beginLike
  , prismIso
  , isoIso
  ) where

import Data.InvertibleGrammar
import Data.InvertibleGrammar.Base
import Data.InvertibleGrammar.Combinators
import Gyehoek.Prelude hiding (iso, cons, coerced, Iso, Simple, simple)
import Gyehoek.Sexp.Syntax hiding (position)
import Gyehoek.Sexp.Print (printDatum')
import Data.Scientific (Scientific)
import qualified Data.Scientific as Sci
import qualified Data.Text as T
import Control.Monad.RWS (modify)


-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Gyehoek.Sexp.Grammar

type G = Grammar Ann

type DatumGrammar a = forall t. G (Datum :- t) (a :- t)
type DataGrammar a = forall t. G (List Datum :- t) (a :- t)

-- | extract\/inject an annotation from\/into a 'Datum'.
position :: G (Datum :- t) (Ann :- Datum :- t)
position = Iso
  (\(s :- t) -> view ann s :- s :- t)
  (\(a :- s :- t) -> (s & ann .~ a) :- t)

locate :: G (Datum :- t) (Datum :- t)
locate =
  position
  >>> onHead Locate
  >>> Iso
    (\(_ :- t) -> t)
    (\t -> noAnn :- t)

modifyAnn :: (Ann -> Ann) -> G (Datum :- t) (Datum :- t)
modifyAnn f = Iso
  (\(d:-t) -> (d & ann %~ f) :- t)
  (\(d:-t) -> (d & ann %~ f) :- t)

newtype ListContext = MkListContext (List Datum)

unexpectedSimple :: Simple -> Mismatch
unexpectedSimple = unexpected . printDatum' . Simple

unexpectedDatum :: Datum -> Mismatch
unexpectedDatum = unexpected . printDatum'

list
  :: G (ListContext :- t) (ListContext :- t')
  -> G (Datum :- t) t'
list = listWithIndentation Ordinary

listWithIndentation
  :: Indentation
  -> G (ListContext :- t) (ListContext :- t')
  -> G (Datum :- t) t'
listWithIndentation ind g = begin >>> Dive (g >>> end)
  where
    begin = locate >>> partialOsi
      (\case
          List xs -> Right . MkListContext $ xs
          _ -> Left $ expected "list")
      (List' ind . coerce)
    end = Flip $ PartialIso
      (\t -> MkListContext [] :- t)
      (\(MkListContext lst :- t) ->
         case lst of
           [] -> Right t
           d:_ -> Left $ unexpectedDatum d)

-- |
-- >>> decodeTest (list $ el simple) "(in-here!)"
-- SimpleSymbol "in-here!"
el
  :: G (Datum :- t) t'
  -> G (ListContext :- t) (ListContext :- t')
el g = coerced (Flip cons >>> onTail g >>> Step)

-- | matches the remainder of a list
--
-- >>> decodeTest (list $ rest simple) "(ga na da ra)"
-- [ SimpleSymbol "ga"
-- , SimpleSymbol "na"
-- , SimpleSymbol "da"
-- , SimpleSymbol "ra"
-- ]
rest
  :: (forall t'. G (Datum :- t') (a :- t'))
  -> G (ListContext :- t) (ListContext :- List a :- t)
rest g =
  iso coerce coerce >>>
  onHead (Traverse (sealed g >>> Step)) >>>
  Iso (\a -> MkListContext [] :- a) (\(_ :- a) -> a)


-- atoms

-- | matches simple forms — atomic S-expressions.
--
-- >>> decodeTest simple "call/cc"
-- SimpleSymbol "call/cc"
simple :: G (Datum :- t) (Simple :- t)
simple = locate >>> partialOsi
  (\case Simple s -> Right s
         _ -> Left . expected $ "atom")
  Simple

prismGrammar
  -- | expected
  :: Text
  -- | unexpected
  -> (s -> Mismatch)
  -> Prism' s a
  -> Grammar p (s :- t) (a :- t)
prismGrammar exp unexp p =
  partialOsi
    ((_Left %~ \x -> expected exp <> unexp x) . matching p)
    (review p)

-- |
-- >>> decodeTest symbol "symbolic-of-what???"
-- "symbolic-of-what???"
symbol :: G (Datum :- t) (Text :- t)
symbol = simple >>> prismGrammar "symbol" unexpectedSimple #SimpleSymbol

-- |
-- >>> let grammar = list $ el (sym "a-specific-symbol") >>> el string
-- >>> decodeTest grammar "(a-specific-symbol \"this works\")"
-- "this works"
-- >>> decodeTest grammar "(some-other-symbol \"this does not\")"
-- *** Exception:
-- <none>:1:2: mismatch:
--     Expected: symbol a-specific-symbol
--     But got:  some-other-symbol
-- ...
sym :: Text -> G (Datum :- t) t
sym s = simple >>> Flip (PartialIso
  (SimpleSymbol s :-)
  (\(a :- t) ->
      case a of
        SimpleSymbol s' | s == s' -> Right t
        other -> Left $ expected ("symbol " <> s) <>
                        unexpectedSimple other))

-- |
-- >>> decodeTest string "\"these r annoying to escape\""
-- "these r annoying to escape"
-- >>> encodeTest string "john Haskell"
-- "john Haskell"
string :: G (Datum :- t) (Text :- t)
string = simple >>> prismGrammar "string" unexpectedSimple #SimpleString

-- |
-- >>> decodeTest boolean "#t"
-- True
-- >>> decodeTest boolean "#false"
-- False
-- >>> encodeTest boolean True
-- #t
boolean :: G (Datum :- t) (Bool :- t)
boolean = simple >>> prismGrammar "boolean" unexpectedSimple #SimpleBoolean

-- |
-- >>> decodeTest number "123"
-- 123.0
-- >>> encodeTest number (fromInteger 456)
-- 456
number :: G (Datum :- t) (Scientific :- t)
number = simple >>> prismGrammar "number" unexpectedSimple #SimpleNumber

-- |
-- >>> decodeTest integer "123"
-- 123
-- >>> encodeTest number 456
-- 456
integer :: G (Datum :- t) (Integer :- t)
integer = number >>> partialOsi
  ((_Left %~ (unexpected . T.pack . show @Double)) . Sci.floatingOrInteger)
  fromIntegral

int :: G (Datum :- t) (Int :- t)
int = integer >>> iso fromIntegral fromIntegral


-- high-level combinators

headTagged0 :: Text -> G (Datum :- t) t
headTagged0 s = list $ el (sym s)

headTagged0' :: Text -> DatumGrammar a -> G (Datum :- t) (List a :- t)
headTagged0' s gt = list $ el (sym s) >>> rest gt

headTagged1 :: Text -> DatumGrammar a -> G (Datum :- t) (a :- t)
headTagged1 s g1 = list $ el (sym s) >>> el g1

headTagged1'
  :: Text
  -> DatumGrammar a -> DatumGrammar b
  -> G (Datum :- t) (List b :- a :- t)
headTagged1' s g1 gt = list $ el (sym s) >>> el g1 >>> rest gt

headTagged2
  :: Text
  -> DatumGrammar a -> DatumGrammar b
  -> G (Datum :- t) (b :- a :- t)
headTagged2 s g1 g2 = list $ el (sym s) >>> el g1 >>> el g2

ifLike
  -- | keyword
  :: Text
  -- | condition
  -> DatumGrammar a
  -- | consequent (then-branch)
  -> DatumGrammar b
  -- | alternative (else-branch)
  -> DatumGrammar c
  -> G (Datum :- t) (c :- b :- a :- t)
ifLike kw c t f = list $ el (symBuiltin kw) >>> el c >>> el t >>> el f

symBuiltin :: Text -> G (Datum :- t) t
symBuiltin s = modifyAnn (#syntax .~ SynBuiltin) >>> sym s

letLike
  :: Text
  -> (forall t. G (Datum :- t) (a :- t))
  -> (forall t. G (Datum :- t) (b :- t))
  -> G (Datum :- (List (a, b) :- t1)) t2
  -> G (Datum :- t1) t2
letLike kw name rhs e = listWithIndentation (NSpecial 1) $
  el (symBuiltin kw) >>> el bindings >>> el e
  where
    bindings = list $ rest binding
    binding :: G (Datum :- t) ((_, _) :- t)
    binding = list (el name >>> el rhs) >>> pair

lambdaLike
  :: (forall t. G (Datum :- t) t)
  -> DatumGrammar a
  -> G (ListContext :- a :- t) (ListContext :- t')
  -> G (Datum :- t) t'
lambdaLike kw formals body = listWithIndentation (NSpecial 1) $
  el (modifyAnn (#syntax .~ SynBuiltin) >>> kw)
  >>> el formals
  >>> body

lambdaKeyword :: G (Datum :- t) t
lambdaKeyword = coproduct [ sym "λ", sym "lambda" ]

kappaKeyword :: G (Datum :- t) t
kappaKeyword = coproduct [ sym "κ", sym "kappa" ]

beginLike
  :: Text
  -> DatumGrammar a
  -> G (Datum :- t) (List a :- t)
beginLike kw g =
  listWithIndentation (NSpecial 0) $
    el (symBuiltin kw) >>> rest g

isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t)
isoIso l = iso (view l) (review l)

prismIso :: Mismatch -> Prism' s a -> Grammar p (s :- t) (a :- t)
prismIso mm p = partialOsi
  (maybe (Left mm) Right . preview p)
  (review p)