{-# LANGUAGE NoImplicitPrelude #-}

{-
    BNF Converter: Abstract syntax Generator
    Copyright (C) 2004  Author:  Markus Forberg

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA
-}

module BNFC.Backend.Haskell.CFtoAbstract (cf2Abstract) where

import Prelude'

import BNFC.CF
import BNFC.PrettyPrint
import BNFC.Utils                 ( when )

import BNFC.Backend.Haskell.Utils ( catToType, catvars )

-- | Create a Haskell module containing data type definitions for the abstract syntax.

cf2Abstract
  :: Bool     -- ^ Use ByteString instead of String
  -> Bool     -- ^ Use GHC specific extensions
  -> Bool     -- ^ Make the tree a functor
  -> String   -- ^ module name
  -> CF       -- ^ Grammar
  -> Doc
cf2Abstract byteStrings ghcExtensions functor name cf = vsep . concat $
    [ [ vcat
        [ "-- Haskell data types for the abstract syntax."
        , "-- Generated by the BNF converter."
        ]
      ]
    , [ vcat
        [ "{-# LANGUAGE DeriveDataTypeable #-}"
        , "{-# LANGUAGE DeriveGeneric #-}"
        ]
      | ghcExtensions
      ]
    , [ hsep [ "module", text name, "where" ] ]
    , [ vcat . concat $
        [ [ "import qualified Data.ByteString.Char8 as BS" | byteStrings   ]
        , [ "import Data.Data    (Data, Typeable)"         | ghcExtensions ]
        , [ "import GHC.Generics (Generic)"                | ghcExtensions ]
        ]
      ]
    , map (\ c -> prSpecialData byteStrings (isPositionCat cf c) derivingClasses c) $ specialCats cf
    , concatMap (prData functor derivingClasses) $ cf2data cf
    , [ "" ] -- ensure final newline
    ]
  where
    derivingClasses = concat
      [ [ "Eq", "Ord", "Show", "Read" ]
      , when ghcExtensions ["Data","Typeable","Generic"]
      ]

-- |
--
-- >>> vsep $ 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:
-- >>> vsep $ 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:
-- >>> vsep $ prData True ["Show"] (Cat "C", [("C1", [Cat "C"]), ("CIdent", [TokenCat "Ident"])])
-- data C a = C1 a (C a) | CIdent a Ident
--   deriving (Show)
-- <BLANKLINE>
-- instance Functor C where
--     fmap f x = case x of
--         C1 a c -> C1 (f a) (fmap f c)
--         CIdent a ident -> CIdent (f a) ident
--
-- The case for lists:
-- >>> vsep $ prData True ["Show"] (Cat "ExpList", [("Exps", [ListCat (Cat "Exp")])])
-- data ExpList a = Exps a [Exp a]
--   deriving (Show)
-- <BLANKLINE>
-- instance Functor ExpList where
--     fmap f x = case x of
--         Exps a exps -> Exps (f a) (map (fmap f) exps)
--
prData :: Bool -> [String] -> Data -> [Doc]
prData functor derivingClasses (cat,rules) = concat
    [ [ hang ("data" <+> dataType) 4 (constructors rules)
        $+$ nest 2 (deriving_ derivingClasses)
      ]
    , [ genFunctorInstance (cat, rules) | functor ]
    ]
  where
    prRule (fun, cats) = hsep $ concat [ [text fun], ["a" | functor], map prArg cats ]
    dataType           = hsep $ concat [ [text (show cat)], ["a" | functor] ]
    prArg              = catToType $ if functor then Just "a" else Nothing
    constructors []    = empty
    constructors (h:t) = sep $ ["=" <+> prRule h] ++ map (("|" <+>) . prRule) t

-- | Generate a functor instance declaration:
--
-- >>> genFunctorInstance (Cat "C", [("C1", [Cat "C", Cat "C"]), ("CIdent", [TokenCat "Ident"])])
-- instance Functor C where
--     fmap f x = case x of
--         C1 a c1 c2 -> C1 (f a) (fmap f c1) (fmap f c2)
--         CIdent a ident -> CIdent (f a) ident
--
-- >>> genFunctorInstance (Cat "SomeLists", [("Ints", [ListCat (TokenCat "Integer")]), ("Exps", [ListCat (Cat "Exp")])])
-- instance Functor SomeLists where
--     fmap f x = case x of
--         Ints a integers -> Ints (f a) integers
--         Exps a exps -> Exps (f a) (map (fmap f) exps)
--
genFunctorInstance :: Data -> Doc
genFunctorInstance (cat, cons) =
    "instance Functor" <+> text (show cat) <+> "where"
    $+$ nest 4 ("fmap f x = case x of" $+$ nest 4 (vcat (map mkCase cons)))
  where
    mkCase (f, args) = hsep . concat $
        [ [ text f, "a" ]
        , vars
        , [ "->", text f, "(f a)" ]
        , zipWith recurse vars args
        ]
      where vars = catvars args
    -- We recursively call fmap on non-terminals only if they are not token categories.
    recurse var = \case
      TokenCat{}         -> var
      ListCat TokenCat{} -> var
      ListCat{}          -> parens ("map (fmap f)" <+> var)
      _                  -> parens ("fmap f"       <+> var)


-- | Generate a newtype declaration for Ident types
--
-- >>> prSpecialData False False ["Show"] catIdent
-- newtype Ident = Ident String
--   deriving (Show)
--
-- >>> prSpecialData False True ["Show"] catIdent
-- newtype Ident = Ident ((Int,Int),String)
--   deriving (Show)
--
-- >>> prSpecialData True False ["Show"] catIdent
-- newtype Ident = Ident BS.ByteString
--   deriving (Show)
--
-- >>> prSpecialData True True ["Show"] catIdent
-- newtype Ident = Ident ((Int,Int),BS.ByteString)
--   deriving (Show)
--
prSpecialData
  :: Bool     -- ^ If True, use ByteString instead of String
  -> Bool     -- ^ If True, store the token position
  -> [String] -- ^ Derived classes
  -> TokenCat -- ^ Token category name
  -> Doc
prSpecialData byteStrings position classes cat = vcat
    [ hsep [ "newtype", ppcat, "=", ppcat, contentSpec ]
    , nest 2 $ deriving_ classes
    ]
  where
    ppcat    = text cat
    contentSpec | position    = parens ( "(Int,Int)," <> stringType)
                | otherwise   = stringType
    stringType  | byteStrings = "BS.ByteString"
                | otherwise   = "String"

-- | Generate 'deriving' clause
--
-- >>> deriving_ ["Show", "Read"]
-- deriving (Show, Read)
--
deriving_ :: [String] -> Doc
deriving_ cls = "deriving" <+> parens (hsep $ punctuate "," $ map text cls)