{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Haskell.AbstractSyntax
  ( cf2abs, haskellAbstractSyntax, printFunctions )

  where

import BNFC.CF

import BNFC.Backend.CommonInterface.Backend

import BNFC.Backend.Common.Utils as Utils

import BNFC.Backend.Haskell.Options
import BNFC.Backend.Haskell.State
import BNFC.Backend.Haskell.Template (haskellTemplate)

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)

haskellAbstractSyntax :: LBNF -> State HaskellBackendState Result
haskellAbstractSyntax lbnf = do
  st <- get
  template <- haskellTemplate lbnf
  let cfName      = takeBaseName $ optInput $ globalOpt st
      rules       = filterRules $ astRules st
      hasData     = not $ null rules
      funs        = functions st
      toks        = tokens st
      inDirectory = inDir $ haskellOpts st
      nSpace      = nameSpace $ haskellOpts st
      tt          = tokenText $ haskellOpts st
      funct       = functor $ haskellOpts st
      gen         = generic $ haskellOpts st
      absSyntax   =
        cf2abs lbnf cfName inDirectory nSpace rules funs toks funct gen hasData tt
  return $ (mkFilePath inDirectory nSpace cfName "Abs" "hs", absSyntax) : template
  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)]
       -> Bool
       -> Bool
       -> Bool
       -> TokenText
       -> String
cf2abs lbnf cfName inDir nameSpace astRules functions toks functor generic hasData tokenText =
  docToString defaultLayoutOptions $
    cf2doc lbnf cfName inDir nameSpace astRules functions toks functor generic hasData tokenText

cf2doc :: LBNF
       -> String
       -> Bool
       -> Maybe String
       -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
       -> [(LabelName,Function)]
       -> [(CatName,TokenDef)]
       -> Bool
       -> Bool
       -> Bool
       -> TokenText
       -> Doc ()
cf2doc lbnf cfName inDir nameSpace astRules functions toks functor generic hasData tokenText =
  vsep . intersperse emptyDoc $
    prologue lbnf usedBuiltins cfName inDir nameSpace functor generic hasData tokenText
    :
    toBePrinted
  where
    usedBuiltins = map (toList . printBuiltinCat) (Map.keys $ _lbnfASTBuiltins lbnf)
    tokenNames   = toList <$> Map.keys (_lbnfTokenDefs lbnf)
    -- @defPosition@: should the @BNCF'Position@ type be defined?
    defPosition  = hasPosTokens || functor
    -- @hasPosition@: should the @HasPosition@ class be defined?
    hasPosition  = hasPosTokens || (functor && hasData)
    hasPosTokens = any isPositionToken (_lbnfTokenDefs lbnf)
    posTokens    = filter (isPosToken . snd) toks

    datas = if null astRules
            then Nothing
            else Just $ printDatas usedBuiltins tokenNames functor generic astRules

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

    tokens = if null toks
             then Nothing
             else Just $ printTokens generic tokenText toks

    posDef = if defPosition
             then Just positionDef
             else Nothing

    posInstances =
      if hasPosition
      then Just $ positionInstances astRules posTokens functor
      else Nothing

    toBePrinted = catMaybes [ datas, funs, tokens, posDef, posInstances ]

prologue :: LBNF
         -> [String]
         -> String
         -> Bool
         -> Maybe String
         -> Bool
         -> Bool
         -> Bool
         -> TokenText
         -> Doc ()
prologue lbnf usedBuiltins cfName inDir nameSpace functor generic hasData tokenText =
  vsep
    [ comment
    , pragmas lbnf functor generic hasData hasPosTokens hasIdentAndNoPos tokenText
    , "-- | The abstract syntax of language" <+> fromString cfName <> dot
    , emptyDoc
    , "module" <+> fromString (mkModule inDir nameSpace cfName "Abs") <+> "where"
    , imports usedBuiltins functor generic tokenText hasData hasIdentAndNoPos
      hasTokens hasPosTokens hasIdent
    ]

  where
    comment :: Doc ()
    comment = vsep
      [ "-- Haskel data types for the abstract syntax."
      , "-- Generated by the BNF converter."
      ]

    hasIdent :: Bool
    hasIdent = hasIdentifier $ _lbnfTokenDefs lbnf

    hasPosTokens :: Bool
    hasPosTokens = any isPositionToken (_lbnfTokenDefs lbnf)

    -- does the grammar have user defined tokens.
    hasTokens :: Bool
    hasTokens =
      if hasIdent
      -- remove 'builtin' Ident
      then not $ Map.null $ Map.delete ('I':|"dent") (_lbnfTokenDefs lbnf)
      else not $ Map.null $ _lbnfTokenDefs lbnf

    -- grammar presents @Ident@ builtin and no positions tokens.
    hasIdentAndNoPos :: Bool
    hasIdentAndNoPos = hasIdent || any isNoPositionToken (_lbnfTokenDefs lbnf)

pragmas :: LBNF -> Bool -> Bool -> Bool -> Bool -> Bool -> TokenText -> Doc ()
pragmas lbnf functor generic hasData hasPosTokens hasIdentAndNoPos tokenText = vsep $ concat
  [ [ emptyDoc ]
  , Utils.when (generic && hasData)
    [ "{-# LANGUAGE DeriveDataTypeable #-}"
    , "{-# LANGUAGE DeriveGeneric #-}"
    ]
  , Utils.when (functor && hasData)
    [ "{-# LANGUAGE DeriveTraversable #-}"
    , "{-# LANGUAGE FlexibleInstances #-}"
    ]
  , Utils.when hasIdentAndNoPos
    [ "{-# LANGUAGE GeneralizedNewtypeDeriving #-}" ]
  , Utils.when (functor && hasData)
    [ "{-# LANGUAGE LambdaCase #-}" ]
  , Utils.when (functor || hasPosTokens)
    [ "{-# LANGUAGE PatternSynonyms #-}" ]
  , Utils.when (anyFunction && notString)
    [ "{-# LANGUAGE OverloadedStrings #-}" ]
  , Utils.when ( (generic && hasData) || (functor && hasData) || hasIdentAndNoPos ||
                (functor && hasPosTokens) || (anyFunction && notString) )
    [ emptyDoc ]
  ]

  where

  notString :: Bool
  notString = tokenText /= StringToken

  anyFunction :: Bool
  anyFunction = not $ Map.null $ _lbnfFunctions lbnf


imports :: [String]
        -> Bool
        -> Bool
        -> TokenText
        -> Bool
        -> Bool
        -> Bool
        -> Bool
        -> Bool
        -> Doc ()
imports
  usedBuiltins functor generic tokenText hasData hasIdentAndNoPos hasTokens hasPosTokens hasIdent =
  vsep $ concat
    [ [ emptyDoc ]
    , Utils.when (not $ null builtinsToImport)
      [ "import qualified Prelude as T" <+> tupled builtinsToImport ]
    , Utils.when (not $ null preludeImports)
      [ "import qualified Prelude as C" <> softline <> qPreludeImports ]
    , Utils.when (generic && hasData)
      [ emptyDoc
      , "import qualified Data.Data    as C (Data, Typeable)"
      , "import qualified GHC.Generics as C (Generic)"
      ]
    , Utils.when hasIdentAndNoPos
      [ emptyDoc
      , "import Data.String"
      ]
    , Utils.when ((hasTokens || hasIdent) && (tokenText /= StringToken))
      [ emptyDoc
      , tokenTextImport tokenText
      ]
    , Utils.when (generic && hasData)
      [ emptyDoc
      , "import qualified Data.Data    as C (Data, Typeable)"
      , "import qualified GHC.Generics as C (Generic)"
      ]
    ]
  where

    builtinsToImport :: [Doc ()]
    builtinsToImport =
      fromString
      <$>
      filter
      (\b -> (b `elem` usedBuiltins)
      ||
      ( (hasTokens || hasIdent)
        && tokenText == StringToken
        && b == "String") )
      ["Char", "Double", "Integer", "String"]

    qPreludeImports :: Doc ()
    qPreludeImports = nest 2 $ tupled preludeImports

    preludeImports :: [Doc ()]
    preludeImports =
      Utils.when (hasData || hasIdent || hasTokens) stdClasses
      ++
      Utils.when (functor && hasData) funClasses
      ++
      Utils.when (functor || hasPosTokens) ["Int, Maybe(..)"]

funClasses :: [Doc ()]
funClasses = [ "Functor", "Foldable", "Traversable" ]

genClasses :: [Doc ()]
genClasses = [ "Data", "Typeable", "Generic" ]

stdClasses :: [Doc ()]
stdClasses = [ "Eq", "Ord", "Show", "Read" ]

derivingClasses :: Bool -> Bool -> Doc ()
derivingClasses functor generic = indent 2 $ "deriving" <+> tupled toBeDerived
  where
    toBeDerived :: [Doc ()]
    toBeDerived = map ("C." <>) $ concat
      [ stdClasses
      , Utils.when functor funClasses
      , Utils.when generic genClasses
      ]

derivingClassesTokens :: Bool -> Bool -> Doc ()
derivingClassesTokens generic noPosToken = indent 2 $ "deriving" <+> tupled toBeDerived
  where
    toBeDerived :: [Doc ()]
    toBeDerived =
      map ("C." <>) (stdClasses ++ Utils.when generic genClasses)
      ++ Utils.when noPosToken ["Data.String.IsString"]

positionDef :: Doc ()
positionDef = vsep
  [ "-- | Start position (line, column) of something."
  , emptyDoc
  , "type BNFC'Position = C.Maybe (C.Int, C.Int)"
  , emptyDoc
  , "pattern BNFC'NoPosition :: BNFC'Position"
  , "pattern BNFC'NoPosition = C.Nothing"
  , emptyDoc
  , "pattern BNFC'Position :: C.Int -> C.Int -> BNFC'Position"
  , "pattern BNFC'Position line col = C.Just (line, col)"
  , emptyDoc
  , "-- | Get the start position of something."
  , emptyDoc
  , "class HasPosition a where"
  , indent 2 "hasPosition :: a -> BNFC'Position"
  ]

-- | Instances of the @HasPosition@ class.

positionInstances :: [(Type, [(Label, ([Type], (Integer, ARHS)))])]
                  -> [(CatName,TokenDef)]
                  -> Bool
                  -> Doc ()
positionInstances rules posTokens functor = (vsep . intersperse emptyDoc) $
    -- categories instances.
    Utils.when (not (null rules) && functor) (catPosInstance <$> rules')
    ++
    -- position tokens instances
    Utils.when (not (null posTokens)) (tokenPosInstance <$> posTokens)

  where
    -- Get rid of (Integer, ARHS).
    rules' :: [(Type, [(Label, [Type])])]
    rules' = ( \(t,ls) -> (t, ( \(l,(ts, _)) -> (l,ts)) <$> ls ) )
             <$>
             rules

    -- HasPosition instance coming from category (ordinary rule).

    catPosInstance :: (Type, [(Label, [Type])]) -> Doc ()
    catPosInstance (t, lts) = vsep
      [ "instance HasPosition" <+> fromString (printTypeName t) <+> "where"
      , indent 2 $ "hasPosition =" <+> backslash <> "case"
      , indent 4 $ vsep $ instanceCase <$> lts
      ]
      where
        instanceCase :: (Label, [Type]) -> Doc ()
        instanceCase (l, ts) = fromString (printLabelName l) <+> "p" <+>
          if null ts
          then "-> p"
          else fromString (intersperse ' ' (replicate (length ts) '_')) <+> "-> p"

    -- HasPosition instance coming from podition tokens.

    tokenPosInstance :: (CatName,TokenDef) -> Doc ()
    tokenPosInstance (c, _) = vsep
      [ "instance HasPosition" <+> fromString (toList c) <+> "where"
      , indent 2 $ "hasPosition" <+> parens (fromString (toList c) <+> "(p, _)") <+>
        "= C.Just p"
      ]

-- | Print Haskell datatypes defined by AST rules.

printDatas :: [String]
           -> [String]
           -> Bool
           -> Bool
           -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
           -> Doc ()
printDatas usedBuiltins tokenNames functor generic =
  vsep .
  intersperse emptyDoc .
  fmap (uncurry (printData usedBuiltins tokenNames functor generic))

printData :: [String]
          -> [String]
          -> Bool
          -> Bool
          -> Type
          -> [(Label, ([Type], (Integer, ARHS)))]
          -> Doc ()
printData usedBuiltins tokenNames functor generic t labelItems =
  vsep $ concat
  [ Utils.when functor
    [ "type" <+> unprimedType <+> "=" <+> primedType <+> fromString posType ]
  , [ hang 4 $ vsep [ "data" <+> dataType, constructorsBlock] ]
  , [ derivingClasses functor generic ]
  ]
  where
    unprimedType :: Doc ()
    unprimedType = fromString $ printTypeName t
    primedType = unprimedType <> "'"
    dataType :: Doc ()
    dataType =
      if functor
      then primedType <+> "a"
      else unprimedType
    constructorsBlock :: Doc ()
    constructorsBlock = vsep $ zipWith
      (\s (l,(ts,arhs)) -> vsep
        [ s <+> printConstructor usedBuiltins tokenNames functor l ts
        , printHaddockInData t l arhs])
      ("=" : repeat "|")
      (f <$> labelItems)

    f :: (Label, ([Type], (Integer, ARHS))) -> (Label, ([Type], ARHS))
    f (l,(ts,tup)) = (l,(ts, snd tup))

-- | Print data type constructor and relative arguments

printConstructor :: [String] -> [String] -> Bool -> Label -> [Type] -> Doc ()
printConstructor usedBuiltins tokenNames functor label items =
    hsep $ constructor : arguments
    where
      constructor :: Doc ()
      constructor =
        if functor
        then fromString (printLabelName label) <+> "a"
        else fromString $ printLabelName label
      arguments :: [Doc ()]
      arguments = printArg <$> items

      printArg :: Type -> Doc ()
      printArg t =
        if functor
        then applyWhen (isListType t) brackets $
             applyWhen (isTypeBuiltin t) addQualified $
             applyWhen (isCat t && not (isListType t)) parens $
             applyWhen (isCat t) mkFunctor $
             fromString $ printTypeName t
        else applyWhen (isListType t) brackets $
             applyWhen (isTypeBuiltin t) addQualified $
             fromString $ printTypeName t

      applyWhen :: Bool -> (a -> a) -> a -> a
      applyWhen True  f x = f x
      applyWhen False _ x = x
      addQualified :: Doc () -> Doc ()
      addQualified name = "T." <> name
      isTypeBuiltin :: Type -> Bool
      isTypeBuiltin t = printTypeName t `elem` usedBuiltins
      isCat :: Type -> Bool
      isCat t = not (isTypeBuiltin t) && notElem (printTypeName t) tokenNames
      mkFunctor :: Doc () -> Doc ()
      mkFunctor t = t <> "'" <+> "a"

-- | Print Rule from which a datatype constructor came from as haddock comment.

printHaddockInData :: Type -> Label -> ARHS -> Doc ()
printHaddockInData t _ items =
  "-- ^" <+> fromString (printTypeName t) <+> "::=" <+> items2doc items
    where
      items2doc :: ARHS -> Doc ()
      items2doc itemss = hsep (fromString . printItemName <$> itemss)

-- | Print functions given by the define pragma.

printFunctions :: Bool -> [(LabelName,Function)] -> Doc ()
printFunctions functor = vsep . intersperse emptyDoc . fmap (uncurry (printFunction functor))

printFunction :: Bool -> LabelName -> Function -> Doc ()
printFunction functor label fun = vsep [ haddock, header, withBody ]
  where
    name :: Doc ()
    name = fromString $ toList label
    haddock :: Doc ()
    haddock = "-- |" <+> "define" <+> name <+> hsep paramsNames
      <+> "=" <+> (fromString . printExp False functorParam . funBody) fun
    header :: Doc ()
    header = name <+> "::" <+> paramsTypes <+> "->" <+> returnType
    paramsTypes :: Doc ()
    paramsTypes =
      if functor
      then "a ->" <+> hsep (intersperse "->" (paramT <$> types))
      else hsep (intersperse "->" (paramT <$> types))
    paramT :: Type -> Doc ()
    paramT t =
      if functor && not (isBuiltinType t)
      then (fromString . printTypeName) t <> "' a"
      else (fromString . printTypeName) t
    types :: [Type]
    types = paramType <$> funPars fun
    returnType :: Doc ()
    returnType =
      if functor
      then (fromString . printTypeName . funType) fun <> "' a"
      else (fromString . printTypeName . funType) fun
    paramsNames :: [Doc ()]
    paramsNames = fromString . toList . paramName <$> funPars fun
    withBody :: Doc ()
    withBody =
      name <+> args <+> "=" <+>
      (fromString . printExp functor functorParam . funBody) fun
    args :: Doc ()
    args =
      if functor
      then hsep (fromString functorParam : paramsNames)
      else hsep paramsNames
    functorParam :: String
    functorParam = mkFunctorParam "a"
    mkFunctorParam :: String -> String
    mkFunctorParam a =
      if a `notElem` (l : paramNames)
      then a
      else mkFunctorParam (a ++ "'")
      where
        l :: String
        l = toList label
        paramNames :: [String]
        paramNames = toList . paramName <$> funPars fun


-- | Print user defined tokens.

printTokens :: Bool -> TokenText -> [(CatName,TokenDef)] -> Doc ()
printTokens generic tokenText =
  vsep . intersperse emptyDoc . fmap (uncurry (printToken generic tokenText))

printToken :: Bool -> TokenText -> CatName -> TokenDef -> Doc ()
printToken generic tokenText catName tokenDef = case tokenDef of
  (TokenDef PositionToken _ _) -> vsep
    [ hang 4 $ vsep ["newtype" <+> tName
      ,"=" <+> tName <+> "(" <> "(C.Int, C.Int)" <> "," <+> argType <> ")"]
    , derivingClassesTokens generic False]
      where
        tName = (fromString . toList) catName
        argType = tokArgType tokenText
  (TokenDef NoPositionToken _ _) -> vsep
    [ hang 4 $ vsep [ "newtype" <+> tName
      , "=" <+> tName <+> argType ]
    , derivingClassesTokens generic True ]
      where
        tName = fromString . toList $ catName
        argType = tokArgType tokenText

tokArgType :: TokenText -> Doc ()
tokArgType = \case
  StringToken -> "T.String"
  TextToken   -> "Data.Text.Text"