{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Haskell.GADT.AbstractSyntax where

import BNFC.CF

import BNFC.Backend.CommonInterface.Backend

import BNFC.Backend.Common.Utils as Utils

import BNFC.Backend.Haskell.AbstractSyntax (printFunctions)
import BNFC.Backend.Haskell.Options
import BNFC.Backend.Haskell.State
import BNFC.Backend.Haskell.GADT.ComposOp
import BNFC.Backend.Haskell.GADT.Template
import BNFC.Backend.Haskell.GADT.Utils

import BNFC.Backend.Haskell.Utilities.Utils

import BNFC.Options.GlobalOptions

import BNFC.Prelude

import Control.Monad.State

import qualified Data.Map     as Map
import           Data.List   (intersperse)
import           Data.String (fromString)

import Prettyprinter

import System.FilePath (takeBaseName)


haskellAbstractSyntaxGADT :: LBNF -> State HaskellBackendState Result
haskellAbstractSyntaxGADT lbnf = do
  st <- get
  template <- haskellGADTTemplate lbnf
  let cfName      = takeBaseName $ optInput $ globalOpt st
      rules       = filterRules $ astRules st
      funs        = functions st
      toks        = tokens st
      tt          = tokenText $ haskellOpts st
      inDirectory = inDir $ haskellOpts st
      nSpace      = nameSpace $ haskellOpts st
      absSyntax   =
        cf2abs lbnf cfName inDirectory nSpace rules funs toks tt
      composOpPath = mkFilePath inDirectory nSpace cfName "ComposOp" "hs"
      composOpMod  = composOp (mkModule inDirectory nSpace cfName "ComposOp")
      composOpFile = [(composOpPath, composOpMod)]
  return $ [(mkFilePath inDirectory nSpace cfName "Abs" "hs", absSyntax)] ++ template ++ composOpFile
  where
    filterRules :: [(Type, [(Label, ([Type], (Integer, ARHS)))])]
                -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
    filterRules rules =
      filter
      (\(_,l) -> not (null l))
      ((\(f,s) -> (f, filterLabelsAST fNames s)) <$> rules)

    -- Functions names.
    fNames :: [String]
    fNames = toList <$> Map.keys (_lbnfFunctions lbnf)

cf2abs :: LBNF
       -> String
       -> Bool
       -> Maybe String
       -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
       -> [(LabelName,Function)]
       -> [(CatName,TokenDef)]
       -> TokenText
       -> String
cf2abs lbnf cfName inDir nameSpace astRules functions toks tokenText =
  docToString defaultLayoutOptions $
    cf2doc lbnf cfName inDir nameSpace astRules functions toks tokenText

cf2doc :: LBNF
       -> String
       -> Bool
       -> Maybe String
       -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
       -> [(LabelName,Function)]
       -> [(CatName,TokenDef)]
       -> TokenText
       -> Doc ()
cf2doc lbnf cfName inDir nameSpace astRules functions tokens tokenText =
  (vsep . intersperse emptyDoc) $
    prologue absModule composOpModule hasPosTokens names tokenText emptyTree
    :
    toBePrinted
  where
    composOpModule = mkModule inDir nameSpace cfName "ComposOp"
    absModule      = mkModule inDir nameSpace cfName "Abs"

    dataNames      = printTypeName . fst <$> astRules
    tokenNames     = toList . fst <$> tokens
    funNames       = toList . fst <$> functions
    names          = dataNames ++ tokenNames ++ funNames

    hasData        = not $ null astRules
    hasFunctions   = not $ null functions
    hasTokens      = not $ null tokens
    hasPosTokens   = any isPositionToken (_lbnfTokenDefs lbnf)

    emptyTree      = not (hasData || hasTokens || hasFunctions)

    usedBuiltins   = map (toList . printBuiltinCat) (Map.keys $ _lbnfASTBuiltins lbnf)

    labelsArhss :: [(Label, ARHS)]
    labelsArhss = (\(l,(_,tup)) -> (l, snd tup)) <$> concatMap snd astRules

    labelsTypes :: [(Label, [Type])]
    labelsTypes =
      map
      (\(l,(ts,_)) -> (l,ts))
      (concatMap snd astRules)

    dataAndInstances =
      if not (null astRules) || not (null tokens)
      then Just $ printData names
      else Nothing

    tree =
      if not (null astRules) || not (null tokens)
      then Just $ printTree usedBuiltins tokenText astRules tokens
      else Nothing

    compos =
      if not (null astRules) || not (null tokens)
      then Just $ composInstances labelsArhss
      else Nothing

    shws =
      if not (null astRules) || not (null tokens)
      then Just $ showInstances labelsArhss tokens
      else Nothing

    eqInst = Just eqInstance

    ordInst = Just ordInstance

    index =
      if not (null astRules) || not (null tokens)
      then Just $ indexes labelsTypes tokenNames
      else Nothing

    jmEq =
      if not (null astRules) || not (null tokens)
      then Just $ johnMajorEq labelsArhss tokens
      else Nothing

    cmpSame =
      if not (null astRules) || not (null tokens)
      then Just $ compareSame labelsArhss tokens
      else Nothing

    funs =
      if null functions
      then Nothing
      else Just $ printFunctions False functions

    toBePrinted = catMaybes
      [dataAndInstances, tree, compos, shws, eqInst, ordInst, index, jmEq, cmpSame, funs]

prologue :: ModuleName
         -> ModuleName
         -> Bool
         -> [String]
         -> TokenText
         -> Bool
         -> Doc ()
prologue absName compOpName hasPosTokens toExport tokenText emptyTree = vsep
  [ "-- For GHC version 7.10 or higher"
  , emptyDoc
  , pragmas emptyTree
  , emptyDoc
  , "module" <+> fromString absName <+> exports <+> "where"
  , emptyDoc
  , imports compOpName hasPosTokens tokenText
  ]
  where
    exports :: Doc ()
    exports = tupled $ --parens $ hsep $ intersperse comma $
      [ if emptyTree then "Tree" else "Tree(..)" ] ++ (fromString <$> toExport) ++
      [ "johnMajorEq", "module" <+> fromString compOpName ]

pragmas :: Bool -> Doc ()
pragmas emptyTree = vsep $
  [ "{-# LANGUAGE GADTs, KindSignatures, DataKinds #-}" ]
  ++
  Utils.when emptyTree [ "{-# LANGUAGE EmptyCase #-}" ]
  ++
  ["{-# LANGUAGE LambdaCase #-}"]
  ++
  [ emptyDoc
  , "{-# OPTIONS_GHC -fno-warn-unused-binds #-}"
    -- unused-local-binds would be sufficient, but parses only from GHC 8.0
  , "{-# OPTIONS_GHC -fno-warn-unused-imports #-}"
  , "{-# OPTIONS_GHC -fno-warn-unused-matches #-}"
  , "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}"
    -- defects of coverage checker, e.g. in 8.2.2, may lead to warning
    -- about exceeded iterations for pattern match checker
  , "{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}"
  ]

imports :: ModuleName -> Bool -> TokenText -> Doc ()
imports compOpName hasPosTokens tokenText = vsep $
  [ "import Prelude ((.), (>), (&&), (==))"
  , if hasPosTokens
    then "import Prelude" <+>
      tupled (fromString <$> ("Int" : [ "(.)", "(>)", "(&&)", "(==)"]))
    else "import Prelude" <+>
      tupled (fromString <$> [ "(.)", "(>)", "(&&)", "(==)"])
  , "import qualified Prelude as P"
  , emptyDoc
  , "import" <+> fromString compOpName
  ]
  ++ Utils.when (tokenText == TextToken)
  [ emptyDoc
  , tokenTextImport tokenText
  ]

-- Dummy types.
printData :: [String]
          -> Doc ()
printData names = vsep
  [ "data Tag =" <+> (hsep . intersperse pipe) (fromString . (++ "_") <$> names)
  , vsep $ mkType <$> names
  ]
  where
    mkType :: String -> Doc ()
    mkType name = "type" <+> fromString name <+> "=" <+> "Tree" <+>
      fromString ("'" ++ name ++ "_")

-- Print Tree data type.
printTree :: [String]
          -> TokenText
          -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
          -> [(CatName,TokenDef)]
          -> Doc ()
printTree usedBuiltins tokenText astRules tokens = vsep
  [ "data Tree (a :: Tag) where"
  , indent 2 $ vsep
    [ vsep $ catField <$> astRules
    , vsep $ tokenField <$> tokens
    ]
  ]
  where
    catField :: (Type, [(Label, ([Type], (Integer, ARHS)))]) -> Doc ()
    catField (t, ls) = vsep $ printCase <$> ls
      where
        printCase :: (Label, ([Type], (Integer, ARHS))) -> Doc ()
        printCase (l, (ts, _)) = fromString (printLabelName l) <+> "::" <+>
          if null ts
          then "Tree" <+> fromString ("'" ++ printTypeName t ++ "_")
          else (hsep . intersperse "->") (printType <$> ts) <+>
          "-> Tree" <+> fromString ("'" ++ printTypeName t ++ "_")

        printType :: Type -> Doc ()
        printType ty =
          applyWhen (isListType ty) brackets $
          applyWhen (isTypeBuiltin ty) addQualified $
          fromString $ printTypeName ty

        applyWhen :: Bool -> (a -> a) -> a -> a
        applyWhen True  f x = f x
        applyWhen False _ x = x
        addQualified :: Doc () -> Doc ()
        addQualified name = "P." <> name
        isTypeBuiltin :: Type -> Bool
        isTypeBuiltin ty = printTypeName ty `elem` usedBuiltins

    tokenField :: (CatName,TokenDef) -> Doc ()
    tokenField (cName, TokenDef PositionToken _ _) =
      (fromString . toList) cName <+> ":: ((Int,Int)," <> "P." <> tokenTextType tokenText <> ") ->" <+>
      "Tree" <+> (fromString . toList) ("'" ++ toList cName ++ "_")
    tokenField (cName, TokenDef NoPositionToken _ _) =
      (fromString . toList) cName <+> "::" <> "P." <> tokenTextType tokenText <> " ->" <+> "Tree" <+>
      (fromString . toList) ("'" ++ toList cName ++ "_")

-- Compos instances for a category.
composInstances :: [(Label, ARHS)] -> Doc ()
composInstances labelsArhss = vsep $
  [ "instance Compos Tree where"
  , indent 2 "compos r a f = \\case"
  , indent 4 $ vsep $ treeCase <$> filter isTreeType labelsArhss
  ]
  ++
  Utils.when (not $ all isTreeType labelsArhss) [ indent 4 "t -> r t" ]
  where

    treeCase :: (Label, ARHS) -> Doc ()
    treeCase (l, arhs) = label <+>
      hsep args <+> "->" <+> "r" <+> label <+> "`a`" <+>
      (hsep . intersperse "`a`") (printRhs <$> zip3 args listArgs builtinArgs)

      where

      printRhs :: (Doc (), Bool, Bool) -> Doc ()
      printRhs (arg, False, True ) = "r" <+> arg
      printRhs (arg, True, True ) = "r" <+> arg
      printRhs (arg, True, False) =
        "P.foldr (\\ x z -> r (:) `a` f x `a` z) (r [])" <+> arg
      printRhs (arg, _, _ ) = "f" <+> arg

      label :: Doc ()
      label = fromString $ printLabelName l

      args :: [Doc ()]
      args = printArgs arhs

      -- Does an argument come from a list category.
      listArgs :: [Bool]
      listArgs = isItemListCat <$> filter isNTerminal arhs

      -- Does an argument come from a builtin category.
      builtinArgs :: [Bool]
      builtinArgs = isItemBuiltin <$> filter isNTerminal arhs


showInstances :: [(Label, ARHS)]
              -> [(CatName,TokenDef)]
              -> Doc ()
showInstances labelsArhss tokens = vsep
  [ "instance P.Show (Tree c) where"
  , indent 2 $ vsep
    ["showsPrec n = \\case"
    , indent 2 $ vsep
      [ vsep $ tokenInstance <$> tokens
      , vsep $ catInstance <$> labelsArhss
      , "where"
      , "opar = if n > 0 then P.showChar '(' else P.id"
      , "cpar = if n > 0 then P.showChar ')' else P.id"
      ]
    ]
  ]

  where

    catInstance :: (Label, ARHS) -> Doc ()
    catInstance (l, arhs) = label <+>
      if null args
      then "-> P.showString" <+> dquotes label
      else hsep args <+> "->" <+> rhs

      where

      rhs :: Doc ()
      rhs = if null args
        then "P.showString" <+> dquotes label
        else "opar . P.showString" <+> dquotes label <+> dot <+>
          (hsep . intersperse dot) (printArg <$> args) <+> ". cpar"

      printArg :: Doc () -> Doc ()
      printArg arg = "P.showChar ' ' . P.showsPrec 1" <+> arg

      label :: Doc ()
      label = fromString $ printLabelName l

      args :: [Doc ()]
      args  = printArgs arhs

    tokenInstance :: (CatName,TokenDef) -> Doc ()
    tokenInstance (cName, _)   = fromString (toList cName) <+> "str" <+> "->" <+>
      "opar . P.showString" <+> dquotes (fromString (toList cName)) <+> ". P.showChar ' ' . P.showsPrec 1 str . cpar"

eqInstance :: Doc ()
eqInstance = "instance P.Eq (Tree c) where (==) = johnMajorEq"

ordInstance :: Doc ()
ordInstance = "instance P.Ord (Tree c) where compare x y = P.compare (index x) (index y) `P.mappend` compareSame x y"

johnMajorEq :: [(Label, ARHS)] -> [(CatName,TokenDef)] -> Doc ()
johnMajorEq labelsRhss tokens = vsep
  [ "johnMajorEq :: Tree a -> Tree b -> P.Bool"
  , vsep $ catCase <$> labelsRhss
  , vsep $ tokenCase <$> tokens
  , "johnMajorEq _ _ = P.False"
  ]
  where
    catCase :: (Label, ARHS) -> Doc ()
    catCase (l,arhs) = hsep
      [ "johnMajorEq"
      , if null args
        then hsep [ label, label, "= P.True"]
        else hsep
          [ parens (label <+> hsep args)
          , parens (label <+> hsep (map (<> "_") args))
          , "="
          , (hsep . intersperse "&&") (eq <$> args)
          ]
      ]
      where
        eq :: Doc() -> Doc ()
        eq arg = arg <+> "==" <+> arg <> "_"
        label :: Doc ()
        label = fromString $ printLabelName l
        args :: [Doc ()]
        args = printArgs arhs

    tokenCase :: (CatName,TokenDef) -> Doc ()
    tokenCase (cName, _) = hsep
      [ "johnMajorEq"
      , parens (tokenName <+> "str")
      , parens (tokenName <+> "str_")
      , "= str == str_"
      ]
      where
        tokenName :: Doc ()
        tokenName = fromString $ toList cName

indexes :: [(Label, [Type])] -> [String] -> Doc ()
indexes labelsTypes tokNames = vsep
  [ "index :: Tree c -> P.Int"
  , indexCases
  ]
  where
    indexCases :: Doc ()
    indexCases = vsep $
      (\(d,i) -> "index" <+> d <+> "=" <+> fromString (show i))
      <$>
      zip ((catArg <$> labelsTypes) ++ (tokArg <$> tokNames)) [(1::Integer)..]

    catArg :: (Label, [Type]) -> Doc ()
    catArg (l, ts) = parens ( fromString (printLabelName l) <+>
      hsep (replicate (length ts) "_") )

    tokArg :: String -> Doc ()
    tokArg cName = parens ( fromString cName <+> "_")

compareSame :: [(Label, ARHS)] -> [(CatName,TokenDef)] -> Doc ()
compareSame labelsRhss tokens = vsep
  [ "compareSame :: Tree c -> Tree c -> P.Ordering"
  , vsep $ catCase <$> labelsRhss
  , vsep $ tokenCase <$> tokens
  , "compareSame _ _ = P.error \"BNFC error: compareSame\""
  ]
  where
    catCase :: (Label, ARHS) -> Doc ()
    catCase (l,arhs) = hsep
      [ "compareSame"
      , if null args
        then hsep [ label, label, "= P.EQ"]
        else hsep
          [ parens (label <+> hsep args)
          , parens (label <+> hsep (map (<> "_") args))
          , "="
          , rhs $ comp <$> args
          ]
      ]
      where

        rhs :: [Doc ()] -> Doc ()
        rhs []  = panic "Arguments lost shouldn't be empty."
        rhs [a] = a
        rhs (a:a1:[]) = "P.mappend" <+> parens a <+> parens a1
        rhs (a:a1:a2) = "P.mappend" <+> parens a <+>
          parens ( "P.mappend" <+> parens a1 <+> parens (rhs a2))

        comp :: Doc() -> Doc ()
        comp arg = "P.compare" <+> arg <+> arg <> "_"

        label :: Doc ()
        label = fromString $ printLabelName l

        args :: [Doc ()]
        args = printArgs arhs

    tokenCase :: (CatName,TokenDef) -> Doc ()
    tokenCase (c,_) = hsep
      [ "compareSame"
      , parens (tokenName <+> "str")
      , parens (tokenName <+> "str_")
      , "= P.compare str str_"
      ]
      where
        tokenName :: Doc ()
        tokenName = fromString $ toList c