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

-}

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

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

import Prelude hiding ((<>))
import Data.Maybe
import qualified Data.List as List

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

import BNFC.Backend.Haskell.Utils
  ( avoidReservedWords, catToType, catvars, mkDefName
  , tokenTextImport, tokenTextType, typeToHaskell )

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

cf2Abstract
  :: TokenText -- ^ Use @ByteString@ or @Text@ instead of @String@?
  -> Bool      -- ^ Derive @Data@, Generic@, @Typeable@?
  -> Bool      -- ^ Make the tree a functor?
  -> String    -- ^ Module name.
  -> CF        -- ^ Grammar.
  -> Doc
cf2Abstract :: TokenText -> Bool -> Bool -> String -> CF -> Doc
cf2Abstract TokenText
tokenText Bool
generic Bool
functor String
name CF
cf = [Doc] -> Doc
vsep ([Doc] -> Doc) -> ([[Doc]] -> [Doc]) -> [[Doc]] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Doc]] -> Doc) -> [[Doc]] -> Doc
forall a b. (a -> b) -> a -> b
$
    [ [ [Doc] -> Doc
vcat
        [ Doc
"-- Haskell data types for the abstract syntax."
        , Doc
"-- Generated by the BNF converter."
        ]
      ]
    , [ [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([[Doc]] -> [Doc]) -> [[Doc]] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Doc]] -> Doc) -> [[Doc]] -> Doc
forall a b. (a -> b) -> a -> b
$
        [ [ Doc
"{-# LANGUAGE DeriveDataTypeable #-}" | Bool
gen ]
        , [ Doc
"{-# LANGUAGE DeriveGeneric #-}"      | Bool
gen ]
        , [ Doc
"{-# LANGUAGE GeneralizedNewtypeDeriving #-}" | Bool
hasIdentLike  ] -- for IsString
        ]
      ]
    , [ [Doc] -> Doc
hsep [ Doc
"module", String -> Doc
text String
name, Doc
"where" ] ]
    , [ [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([[Doc]] -> [Doc]) -> [[Doc]] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Doc]] -> Doc) -> [[Doc]] -> Doc
forall a b. (a -> b) -> a -> b
$
        [ [ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"import Prelude (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeImports String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
functorImportsUnqual String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" ]
        , [ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"import qualified Prelude as C (Eq, Ord, Show, Read" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
functorImportsQual String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" ]
        , [ Doc
"import qualified Data.String" | Bool
hasIdentLike ] -- for IsString
        ]
      ]
    , [ [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([[Doc]] -> [Doc]) -> [[Doc]] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Doc]] -> Doc) -> [[Doc]] -> Doc
forall a b. (a -> b) -> a -> b
$
        [ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text ([String] -> [Doc]) -> [String] -> [Doc]
forall a b. (a -> b) -> a -> b
$ TokenText -> [String]
tokenTextImport TokenText
tokenText
        , [ Doc
"import qualified Data.Data    as C (Data, Typeable)" | Bool
gen ]
        , [ Doc
"import qualified GHC.Generics as C (Generic)"        | Bool
gen ]
        ]
      ]
    , ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
`map` CF -> [String]
specialCats CF
cf) ((String -> Doc) -> [Doc]) -> (String -> Doc) -> [Doc]
forall a b. (a -> b) -> a -> b
$ \ String
c ->
        let hasPos :: Bool
hasPos = CF -> String -> Bool
forall f. CFG f -> String -> Bool
isPositionCat CF
cf String
c
        in  TokenText -> Bool -> [String] -> String -> Doc
prSpecialData TokenText
tokenText Bool
hasPos (Bool -> [String]
derivingClassesTokenType Bool
hasPos) String
c
    , (Data -> [Doc]) -> [Data] -> [Doc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> [String] -> Data -> [Doc]
prData String
functorName [String]
derivingClasses) [Data]
datas
    , Bool -> CF -> [Doc]
definedRules Bool
functor CF
cf
    , [ Doc
"" ] -- ensure final newline
    ]
  where
    hasIdentLike :: Bool
hasIdentLike = CF -> Bool
forall g. CFG g -> Bool
hasIdentLikeTokens CF
cf
    datas :: [Data]
datas = CF -> [Data]
cf2data CF
cf
    gen :: Bool
gen   = Bool
generic Bool -> Bool -> Bool
&& Bool -> Bool
not ([Data] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Data]
datas)
    derivingClasses :: [String]
derivingClasses = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"C." String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ String
"Eq", String
"Ord", String
"Show", String
"Read" ]
      , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
when Bool
generic [ String
"Data", String
"Typeable", String
"Generic" ]
      ]
    derivingClassesTokenType :: Bool -> [String]
derivingClassesTokenType Bool
hasPos = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [String]
derivingClasses
      , [ String
"Data.String.IsString" | Bool -> Bool
not Bool
hasPos ]
      ]
    typeImports :: String
typeImports = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ String
"Char", String
"Double" ]
      , [ String
"Int" | CF -> Bool
forall g. CFG g -> Bool
hasPositionTokens CF
cf ]
      , [ String
"Integer", String
"String" ]
      ]
    functorImportsUnqual :: String
functorImportsUnqual
      | Bool
functor   = String
", map, fmap"
      | Bool
otherwise = String
""
    functorImportsQual :: String
functorImportsQual
      | Bool
functor   = String
", Functor"
      | Bool
otherwise = String
""
    functorName :: String
functorName
      | Bool
functor   = String
"C.Functor"
      | Bool
otherwise = String
""

type FunctorName = String

-- |
--
-- >>> vsep $ prData "" ["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 "" ["Show"] (Cat "C", [("CAbracadabra",[]),("CEbrecedebre",[]),("CIbricidibri",[]),("CObrocodobro",[]),("CUbrucudubru",[])])
-- data C
--     = CAbracadabra
--     | CEbrecedebre
--     | CIbricidibri
--     | CObrocodobro
--     | CUbrucudubru
--   deriving (Show)
--
-- If the first argument is not null, generate a functor:
-- >>> vsep $ prData "Functor" ["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 "Functor" ["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 :: FunctorName -> [String] -> Data -> [Doc]
prData :: String -> [String] -> Data -> [Doc]
prData String
functorName [String]
derivingClasses (Cat
cat,[(String, [Cat])]
rules) = [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ Doc -> Int -> Doc -> Doc
hang (Doc
"data" Doc -> Doc -> Doc
<+> Doc
dataType) Int
4 ([(String, [Cat])] -> Doc
constructors [(String, [Cat])]
rules)
        Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
nest Int
2 ([String] -> Doc
deriving_ [String]
derivingClasses)
      ]
    , [ String -> Data -> Doc
genFunctorInstance String
functorName (Cat
cat, [(String, [Cat])]
rules) | Bool
functor ]
    ]
  where
    functor :: Bool
functor            = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
functorName
    prRule :: (String, [Cat]) -> Doc
prRule (String
fun, [Cat]
cats) = [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [String -> Doc
text String
fun], [Doc
"a" | Bool
functor], (Cat -> Doc) -> [Cat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> Doc
prArg [Cat]
cats ]
    dataType :: Doc
dataType           = [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [String -> Doc
text (Cat -> String
forall a. Show a => a -> String
show Cat
cat)], [Doc
"a" | Bool
functor] ]
    prArg :: Cat -> Doc
prArg              = (Doc -> Doc) -> Doc -> Cat -> Doc
catToType Doc -> Doc
forall a. a -> a
id (Doc -> Cat -> Doc) -> Doc -> Cat -> Doc
forall a b. (a -> b) -> a -> b
$ if Bool
functor then Doc
"a" else Doc
empty
    constructors :: [(String, [Cat])] -> Doc
constructors []    = Doc
empty
    constructors ((String, [Cat])
h:[(String, [Cat])]
t) = [Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc
"=" Doc -> Doc -> Doc
<+> (String, [Cat]) -> Doc
prRule (String, [Cat])
h] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ ((String, [Cat]) -> Doc) -> [(String, [Cat])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc
"|" Doc -> Doc -> Doc
<+>) (Doc -> Doc) -> ((String, [Cat]) -> Doc) -> (String, [Cat]) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [Cat]) -> Doc
prRule) [(String, [Cat])]
t

-- | Generate a functor instance declaration:
--
-- >>> genFunctorInstance "Functor" (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 "Functor" (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 :: FunctorName -> Data -> Doc
genFunctorInstance :: String -> Data -> Doc
genFunctorInstance String
functorName (Cat
cat, [(String, [Cat])]
cons) =
    Doc
"instance" Doc -> Doc -> Doc
<+> String -> Doc
text String
functorName Doc -> Doc -> Doc
<+> String -> Doc
text (Cat -> String
forall a. Show a => a -> String
show Cat
cat) Doc -> Doc -> Doc
<+> Doc
"where"
    Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
nest Int
4 (Doc
"fmap f x = case x of" Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
nest Int
4 ([Doc] -> Doc
vcat (((String, [Cat]) -> Doc) -> [(String, [Cat])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String, [Cat]) -> Doc
mkCase [(String, [Cat])]
cons)))
  where
    mkCase :: (String, [Cat]) -> Doc
mkCase (String
f, [Cat]
args) = [Doc] -> Doc
hsep ([Doc] -> Doc) -> ([[Doc]] -> [Doc]) -> [[Doc]] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Doc]] -> Doc) -> [[Doc]] -> Doc
forall a b. (a -> b) -> a -> b
$
        [ [ String -> Doc
text String
f, Doc
"a" ]
        , [Doc]
vars
        , [ Doc
"->", String -> Doc
text String
f, Doc
"(f a)" ]
        , (Doc -> Cat -> Doc) -> [Doc] -> [Cat] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Doc -> Cat -> Doc
recurse [Doc]
vars [Cat]
args
        ]
      where vars :: [Doc]
vars = [Cat] -> [Doc]
catvars [Cat]
args
    -- We recursively call fmap on non-terminals only if they are not token categories.
    recurse :: Doc -> Cat -> Doc
recurse Doc
var = \case
      TokenCat{}         -> Doc
var
      ListCat TokenCat{} -> Doc
var
      ListCat{}          -> Doc -> Doc
parens (Doc
"map (fmap f)" Doc -> Doc -> Doc
<+> Doc
var)
      Cat
_                  -> Doc -> Doc
parens (Doc
"fmap f"       Doc -> Doc -> Doc
<+> Doc
var)


-- | 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 ((Int, 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 ((Int, 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 -> Bool -> [String] -> String -> Doc
prSpecialData TokenText
tokenText Bool
position [String]
classes String
cat = [Doc] -> Doc
vcat
    [ [Doc] -> Doc
hsep [ Doc
"newtype", String -> Doc
text String
cat, Doc
"=", String -> Doc
text String
cat, Doc
contentSpec ]
    , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [String] -> Doc
deriving_ [String]
classes
    ]
  where
    contentSpec :: Doc
contentSpec | Bool
position    = Doc -> Doc
parens ( Doc
"(Int, Int), " Doc -> Doc -> Doc
<> Doc
stringType)
                | Bool
otherwise   = Doc
stringType
    stringType :: Doc
stringType = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ TokenText -> String
tokenTextType TokenText
tokenText

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

-- | Generate Haskell code for the @define@d constructors.
definedRules :: Bool -> CF -> [Doc]
definedRules :: Bool -> CF -> [Doc]
definedRules Bool
functor CF
cf = [ RFun -> [String] -> Exp -> Doc
forall f. IsFun f => f -> [String] -> Exp -> Doc
mkDef RFun
f [String]
xs Exp
e | FunDef RFun
f [String]
xs Exp
e <- CF -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CF
cf ]
  where
    mkDef :: f -> [String] -> Exp -> Doc
mkDef f
f [String]
xs Exp
e = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text ([String] -> [Doc]) -> [String] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ [String] -> String
unwords [ f -> String
forall f. IsFun f => f -> String
mkDefName f
f, String
"::", Type -> String
typeToHaskell (Type -> String) -> Type -> String
forall a b. (a -> b) -> a -> b
$ WithPosition Type -> Type
forall a. WithPosition a -> a
wpThing WithPosition Type
t ]
        | Bool -> Bool
not Bool
functor  -- TODO: make type signatures work with --functor
        , WithPosition Type
t <- Maybe (WithPosition Type) -> [WithPosition Type]
forall a. Maybe a -> [a]
maybeToList (Maybe (WithPosition Type) -> [WithPosition Type])
-> Maybe (WithPosition Type) -> [WithPosition Type]
forall a b. (a -> b) -> a -> b
$ f -> CF -> Maybe (WithPosition Type)
forall a. IsFun a => a -> CF -> Maybe (WithPosition Type)
sigLookup f
f CF
cf
        ]
      , [ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ f -> String
forall f. IsFun f => f -> String
mkDefName f
f String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
xs' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"=", Exp -> String
forall a. Show a => a -> String
show (Exp -> String) -> Exp -> String
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
sanitize Exp
e ] ]
      ]
      where xs' :: [String]
xs' = (String -> String) -> [String] -> [String]
forall t a. IsString t => (t -> a) -> [a] -> [a]
addFunctorArg String -> String
forall a. a -> a
id ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
avoidReservedWords [String]
xs
    sanitize :: Exp -> Exp
sanitize = \case
      App String
x [Exp]
es      -> String -> [Exp] -> Exp
App String
x ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (String -> Exp) -> [Exp] -> [Exp]
forall t a. IsString t => (t -> a) -> [a] -> [a]
addFunctorArg (String -> [Exp] -> Exp
`App` []) ([Exp] -> [Exp]) -> [Exp] -> [Exp]
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp) -> [Exp] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Exp
sanitize [Exp]
es
      Var String
x         -> String -> Exp
Var (String -> Exp) -> String -> Exp
forall a b. (a -> b) -> a -> b
$ String -> String
avoidReservedWords String
x
      e :: Exp
e@LitInt{}    -> Exp
e
      e :: Exp
e@LitDouble{} -> Exp
e
      e :: Exp
e@LitChar{}   -> Exp
e
      e :: Exp
e@LitString{} -> Exp
e
    -- Functor argument
    addFunctorArg :: (t -> a) -> [a] -> [a]
addFunctorArg t -> a
g
      | Bool
functor = (t -> a
g t
"_a" a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)
      | Bool
otherwise = [a] -> [a]
forall a. a -> a
id