content: {-
      BNF Converter: Abstract syntax Generator
      Copyright (C) 2004  Author:  Markus Forsberg
  
  -}
  
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE RecordWildCards #-}
  
  module BNFC.Backend.Haskell.CFtoAbstract
    ( cf2Abstract
    , DefCfg(..), definedRules', definedRules
    ) where
  
  import Prelude hiding ((<>))
  import Data.Either (isRight)
  import Data.Maybe
  import qualified Data.List as List
  
  import BNFC.CF
  import BNFC.Options               ( SharedOptions(..), TokenText(..) )
  import BNFC.PrettyPrint
  import BNFC.Utils                 ( when, applyWhen )
  
  import BNFC.Backend.Haskell.Utils
    ( avoidReservedWords, catToType, mkDefName
    , tokenTextImport, tokenTextType, typeToHaskell'
    , posType, posConstr, noPosConstr
    , hasPositionClass, hasPositionMethod
    )
  
  -- | Create a Haskell module containing data type definitions for the abstract syntax.
  
  cf2Abstract
    :: SharedOptions
    -> String    -- ^ Module name.
    -> CF        -- ^ Grammar.
    -> Doc
  -- tokenText :: TokenText -- ^ Use @ByteString@ or @Text@ instead of @String@?
  -- generic   :: Bool      -- ^ Derive @Data@ and Generic@?
  -- functor   :: Bool      -- ^ Make the tree a functor?
  cf2Abstract Options{ lang, tokenText, generic, functor } name cf = vsep . concat $
      [ []
  
      -- Modules header
      , [ vcat . concat $
          [ [ "{-# LANGUAGE DeriveDataTypeable #-}"         | gen ]
          , [ "{-# LANGUAGE DeriveGeneric #-}"              | gen ]
          , [ "{-# LANGUAGE DeriveTraversable #-}"          | fun ]
          , [ "{-# LANGUAGE FlexibleInstances #-}"          | fun ]
          , [ "{-# LANGUAGE GeneralizedNewtypeDeriving #-}" | hasIdentLikeNoPos ] -- for IsString
          , [ "{-# LANGUAGE LambdaCase #-}"                 | fun ]
          , [ "{-# LANGUAGE PatternSynonyms #-}"            | defPosition ]
          , [ "{-# LANGUAGE OverloadedStrings #-}"          | not (null definitions), tokenText /= StringToken ]
          ]
        ]
      , [ "-- | The abstract syntax of language" <+> text lang <> "." ]
      , [ hsep [ "module", text name, "where" ] ]
  
      -- Imports
      , [ vcat . concat $
          [ [ text $ "import Prelude (" ++ List.intercalate ", " typeImports ++ ")"
              | not $ null typeImports ]
          , [ prettyList 2 "import qualified Prelude as C" "(" ")" "," $ qualifiedPreludeImports
              | not $ null qualifiedPreludeImports ]
          , [ "import qualified Data.String"
              | hasIdentLikeNoPos ] -- for IsString
          ]
        ]
      , [ vcat . concat $
          [ when hasTextualToks $ map text $ tokenTextImport tokenText
          , [ "import qualified Data.Data    as C (Data)"    | gen ]
          , [ "import qualified GHC.Generics as C (Generic)" | gen ]
          ]
        ]
  
      -- AST types
      , map (prData functor (derivingClasses functor)) datas
  
      -- Smart constructors
      , definitions
  
      -- Token definition types
      , (`map` specialCats cf) $ \ c ->
          let hasPos = isPositionCat cf c
          in  prSpecialData tokenText hasPos (derivingClassesTokenType hasPos) c
  
      -- BNFC'Position type
        -- We generate these synonyms for position info when --functor,
        -- regardless whether it is used in the abstract syntax.
        -- It may be used in the parser.
      , [ vcat
          [ "-- | Start position (line, column) of something."
          , ""
          , "type" <+> posType <+> "=" <+> "C.Maybe (C.Int, C.Int)"
          , ""
          , "pattern" <+> noPosConstr <+> "::" <+> posType
          , "pattern" <+> noPosConstr <+> "=" <+> "C.Nothing"
          , ""
          , "pattern" <+> posConstr <+> ":: C.Int -> C.Int ->" <+> posType
          , "pattern" <+> posConstr <+> "line col =" <+> "C.Just (line, col)"
          ]
        | defPosition
        ]
  
      -- HasPosition class
      , [ vcat
          [ "-- | Get the start position of something."
          , ""
          , "class" <+> hasPositionClass <+> "a where"
          , nest 2 $ hasPositionMethod <+> ":: a ->" <+> posType
          ]
        | hasPosition
        ]
  
      , when functor $ map instanceHasPositionData datas
  
      , map instanceHasPositionTokenType positionCats
  
      , [ "" ] -- ensure final newline
      ]
    where
      definitions  = definedRules functor cf
  
      datas        = cf2data cf
      positionCats = filter (isPositionCat cf) $ specialCats cf
  
      hasIdentLikeNoPos = hasIdentLikeTokens cf
      hasTextualToks    = hasTextualTokens cf
      hasPosToks   = hasPositionTokens cf
      hasData      = not (null datas)
      -- @defPosition@: should the @BNCF'Position@ type be defined?
      defPosition  = hasPosToks || functor
      -- @hasPosition@: should the @HasPosition@ class be defined?
      hasPosition  = hasPosToks || fun
      gen   = generic && hasData
      fun   = functor && hasData
  
      stdClasses = [ "Eq", "Ord", "Show", "Read" ]
      funClasses = [ "Functor", "Foldable", "Traversable" ]
      genClasses = [ "Data", "Generic" ]
      derivingClasses functor = map ("C." ++) $ concat
        [ stdClasses
        , when functor funClasses
        , when generic genClasses
        ]
      derivingClassesTokenType hasPos = concat
        [ derivingClasses False
        , [ "Data.String.IsString" | not hasPos ]
        ]
      -- import Prelude (Char, Double, Integer, String)
      typeImports =
        filter (\ s -> hasData        && s `elem` cfgLiterals cf
                    || hasTextualToks && tokenText == StringToken && s == "String")
          baseTokenCatNames
      qualifiedPreludeImports = concat
        [ [ text $ List.intercalate ", " stdClasses | hasTextualToks || hasData ]
        , [ text $ List.intercalate ", " funClasses | fun ]
        , [ text $ "Int, Maybe(..)" | defPosition ]
        ]
  
  -- |
  --
  -- >>> prData False ["Eq", "Ord", "Show", "Read"] (Cat "C", [("C1", [Cat "C"]), ("CIdent", [Cat "Ident"])])
  -- data C = C1 C | CIdent Ident
  --   deriving (Eq, Ord, Show, Read)
  --
  -- Note that the layout adapts if it does not fit in one line:
  -- >>> prData False ["Show"] (Cat "C", [("CAbracadabra",[]),("CEbrecedebre",[]),("CIbricidibri",[]),("CObrocodobro",[]),("CUbrucudubru",[])])
  -- data C
  --     = CAbracadabra
  --     | CEbrecedebre
  --     | CIbricidibri
  --     | CObrocodobro
  --     | CUbrucudubru
  --   deriving (Show)
  --
  -- If the first argument is @True@, generate a functor:
  -- >>> prData True ["Show", "Functor"] (Cat "C", [("C1", [Cat "C"]), ("CIdent", [TokenCat "Ident"])])
  -- type C = C' BNFC'Position
  -- data C' a = C1 a (C' a) | CIdent a Ident
  --   deriving (Show, Functor)
  --
  -- The case for lists:
  -- >>> prData True ["Show", "Functor"] (Cat "ExpList", [("Exps", [ListCat (Cat "Exp")])])
  -- type ExpList = ExpList' BNFC'Position
  -- data ExpList' a = Exps a [Exp' a]
  --   deriving (Show, Functor)
  --
  prData :: Bool -> [String] -> Data -> Doc
  prData functor derivingClasses (cat,rules) = vcat $ concat
    [ [ hsep [ "type", unprimedType, "=", primedType, posType ] | functor ]
    , [ hang ("data" <+> dataType) 4 $
          constructors rules ]
    , [ nest 2 $ deriving_ derivingClasses ]
    ]
    where
      prRule (fun, cats) = hsep $ concat [ [text fun], ["a" | functor], map prArg cats ]
      unprimedType       = pretty cat
      primedType         = prime unprimedType
      prime              = (<> "'")
      dataType | functor = primedType <+> "a"
               |otherwise= unprimedType
      prArg c
        | functor && (not .isRight . baseCat) c
                         = catToType prime "a" c
        | otherwise      = catToType id empty c
      constructors []    = empty
      constructors (h:t) = sep $ ["=" <+> prRule h] ++ map (("|" <+>) . prRule) t
  
  -- | Generate @instance HasPosition@ for a data type.
  --
  -- >>> instanceHasPositionData (Cat "C", [("C1", [Cat "C"]), ("CIdent", [Cat "Ident"])])
  -- instance HasPosition C where
  --   hasPosition = \case
  --     C1 p _ -> p
  --     CIdent p _ -> p
  --
  -- >>> instanceHasPositionData (Cat "ExpList", [("Exps", [ListCat (Cat "Exp")])])
  -- instance HasPosition ExpList where
  --   hasPosition = \case
  --     Exps p _ -> p
  
  instanceHasPositionData :: Data -> Doc
  instanceHasPositionData (cat, rules) = vcat . concat $
    [ [ "instance" <+> hasPositionClass <+> dat <+> "where" ]
    , [ nest 2 $ "hasPosition = \\case" ]
    , map (\ (c, args) -> nest 4 . hsep $ concat [ [text c, pos], "_" <$ args, ["->", pos] ]) rules
    ]
    where
    dat = text $ catToStr cat
    pos = "p"
  
  -- | Generate a newtype declaration for Ident types
  --
  -- >>> prSpecialData StringToken False ["Show","Data.String.IsString"] catIdent
  -- newtype Ident = Ident String
  --   deriving (Show, Data.String.IsString)
  --
  -- >>> prSpecialData StringToken True ["Show"] catIdent
  -- newtype Ident = Ident ((C.Int, C.Int), String)
  --   deriving (Show)
  --
  -- >>> prSpecialData TextToken False ["Show"] catIdent
  -- newtype Ident = Ident Data.Text.Text
  --   deriving (Show)
  --
  -- >>> prSpecialData ByteStringToken False ["Show"] catIdent
  -- newtype Ident = Ident BS.ByteString
  --   deriving (Show)
  --
  -- >>> prSpecialData ByteStringToken True ["Show"] catIdent
  -- newtype Ident = Ident ((C.Int, C.Int), BS.ByteString)
  --   deriving (Show)
  --
  prSpecialData
    :: TokenText  -- ^ Format of token content.
    -> Bool       -- ^ If @True@, store the token position.
    -> [String]   -- ^ Derived classes.
    -> TokenCat   -- ^ Token category name.
    -> Doc
  prSpecialData tokenText position classes cat = vcat
      [ hsep [ "newtype", text cat, "=", text cat, contentSpec ]
      , nest 2 $ deriving_ classes
      ]
    where
      contentSpec | position    = parens ( "(C.Int, C.Int), " <> stringType)
                  | otherwise   = stringType
      stringType = text $ tokenTextType tokenText
  
  -- | Generate 'deriving' clause
  --
  -- >>> deriving_ ["Show", "Read"]
  -- deriving (Show, Read)
  --
  deriving_ :: [String] -> Doc
  deriving_ cls = "deriving" <+> parens (hsep $ punctuate "," $ map text cls)
  
  -- | Generate HasPosition instances for Ident types
  --
  -- >>> instanceHasPositionTokenType catIdent
  -- instance HasPosition Ident where
  --   hasPosition (Ident (p, _)) = C.Just p
  
  instanceHasPositionTokenType :: TokenCat -> Doc
  instanceHasPositionTokenType cat = vcat
    [ "instance" <+> hasPositionClass <+> t <+> "where"
    , nest 2 $ "hasPosition " <> parens (t <+> "(p, _)") <+> "= C.Just p"
    ]
    where
    t = text cat
  
  -- | Parametrize 'definedRules' so that it can be used for Agda as well.
  
  data DefCfg = DefCfg
    { sanitizeName :: String -> String
    , hasType      :: String
    , arrow        :: String
    , lambda       :: String
    , cons         :: String
    , convTok      :: String -> String
    , convLitInt   :: Exp -> Exp
    , polymorphism :: [Base] -> [Base]
    }
  
  haskellDefCfg :: DefCfg
  haskellDefCfg = DefCfg
    { sanitizeName = avoidReservedWords []
    , hasType      = "::"
    , arrow        = "->"
    , lambda       = "\\"
    , cons         = "(:)"
    , convTok      = id
    , convLitInt   = id
    , polymorphism = id
    }
  
  -- | Generate Haskell code for the @define@d constructors.
  definedRules :: Bool -> CF -> [Doc]
  definedRules = definedRules' haskellDefCfg
  
  -- | Generate Haskell/Agda code for the @define@d constructors.
  definedRules' :: DefCfg -> Bool -> CF -> [Doc]
  definedRules' DefCfg{..} functor cf = map mkDef $ definitions cf
    where
    mkDef (Define f args e _) = vcat $ concat
      [ [ text $ unwords [ fName, hasType, typeToHaskell' arrow $ typ $ wpThing t ]
        | t <- maybeToList $ sigLookup f cf
        ]
      , [ hsep $ concat
          [ map text [ fName, "=", lambda ]
          , map text $ addFunctorArg id $ map (sanitizeName . fst) args
          , [ text arrow, pretty $ sanitize e ]
          ]
        ]
      ]
      where
      fName = mkDefName f
      typ :: Type -> Type
      typ = applyWhen functor $ \ (FunT ts t) ->
              FunT (polymorphism $ BaseT "a" : map addParam ts) $ addParam t
      addParam :: Base -> Base
      addParam = fmap $ \ x -> if tokTyp x then x else x ++ "' a"
      tokTyp :: String -> Bool
      tokTyp = (`elem` literals cf)
      sanitize :: Exp -> Exp
      sanitize = \case
        App x t es
          | isConsFun x -> App cons t $ map sanitize es
          | isNilFun x  -> App x t $ map sanitize es
          | tokTyp x    -> App (convTok x) t $ map sanitize es
          | otherwise   -> App (sanitizeName x) t $ addFunctorArg (\ x -> App x dummyType []) $ map sanitize es
        Var x         -> Var $ sanitizeName x
        e@LitInt{}    -> convLitInt e
        e@LitDouble{} -> e
        e@LitChar{}   -> e
        e@LitString{} -> e
      -- Functor argument
      addFunctorArg :: (String -> a) -> [a] -> [a]
      addFunctorArg g = applyWhen functor (g "_a" :)
  