{-
    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 -> [Char] -> CF -> Doc
cf2Abstract TokenText
tokenText Bool
generic Bool
functor [Char]
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", [Char] -> Doc
text [Char]
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
$
        [ [ [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"import Prelude (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
typeImports [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
functorImportsUnqual [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")" ]
        , [ [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"import qualified Prelude as C (Eq, Ord, Show, Read" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
functorImportsQual [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")" ]
        , [ 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
$
        [ ([Char] -> Doc) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Doc
text ([[Char]] -> [Doc]) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> a -> b
$ TokenText -> [[Char]]
tokenTextImport TokenText
tokenText
        , [ Doc
"import qualified Data.Data    as C (Data, Typeable)" | Bool
gen ]
        , [ Doc
"import qualified GHC.Generics as C (Generic)"        | Bool
gen ]
        ]
      ]
    , (([Char] -> Doc) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
`map` CF -> [[Char]]
specialCats CF
cf) (([Char] -> Doc) -> [Doc]) -> ([Char] -> Doc) -> [Doc]
forall a b. (a -> b) -> a -> b
$ \ [Char]
c ->
        let hasPos :: Bool
hasPos = CF -> [Char] -> Bool
forall f. CFG f -> [Char] -> Bool
isPositionCat CF
cf [Char]
c
        in  TokenText -> Bool -> [[Char]] -> [Char] -> Doc
prSpecialData TokenText
tokenText Bool
hasPos (Bool -> [[Char]]
derivingClassesTokenType Bool
hasPos) [Char]
c
    , (Data -> [Doc]) -> [Data] -> [Doc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char] -> [[Char]] -> Data -> [Doc]
prData [Char]
functorName [[Char]]
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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Data]
datas)
    derivingClasses :: [[Char]]
derivingClasses = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"C." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ [Char]
"Eq", [Char]
"Ord", [Char]
"Show", [Char]
"Read" ]
      , Bool -> [[Char]] -> [[Char]]
forall m. Monoid m => Bool -> m -> m
when Bool
generic [ [Char]
"Data", [Char]
"Typeable", [Char]
"Generic" ]
      ]
    derivingClassesTokenType :: Bool -> [[Char]]
derivingClassesTokenType Bool
hasPos = [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [[Char]]
derivingClasses
      , [ [Char]
"Data.String.IsString" | Bool -> Bool
not Bool
hasPos ]
      ]
    typeImports :: [Char]
typeImports = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
List.intercalate [Char]
", " ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ [Char]
"Char", [Char]
"Double" ]
      , [ [Char]
"Int" | CF -> Bool
forall g. CFG g -> Bool
hasPositionTokens CF
cf ]
      , [ [Char]
"Integer", [Char]
"String" ]
      ]
    functorImportsUnqual :: [Char]
functorImportsUnqual
      | Bool
functor   = [Char]
", map, fmap"
      | Bool
otherwise = [Char]
""
    functorImportsQual :: [Char]
functorImportsQual
      | Bool
functor   = [Char]
", Functor"
      | Bool
otherwise = [Char]
""
    functorName :: [Char]
functorName
      | Bool
functor   = [Char]
"C.Functor"
      | Bool
otherwise = [Char]
""

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 :: [Char] -> [[Char]] -> Data -> [Doc]
prData [Char]
functorName [[Char]]
derivingClasses (Cat
cat,[([Char], [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 ([([Char], [Cat])] -> Doc
constructors [([Char], [Cat])]
rules)
        Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
nest Int
2 ([[Char]] -> Doc
deriving_ [[Char]]
derivingClasses)
      ]
    , [ [Char] -> Data -> Doc
genFunctorInstance [Char]
functorName (Cat
cat, [([Char], [Cat])]
rules) | Bool
functor ]
    ]
  where
    functor :: Bool
functor            = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
functorName
    prRule :: ([Char], [Cat]) -> Doc
prRule ([Char]
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 [ [[Char] -> Doc
text [Char]
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 [ [[Char] -> Doc
text (Cat -> [Char]
forall a. Show a => a -> [Char]
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 :: [([Char], [Cat])] -> Doc
constructors []    = Doc
empty
    constructors (([Char], [Cat])
h:[([Char], [Cat])]
t) = [Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc
"=" Doc -> Doc -> Doc
<+> ([Char], [Cat]) -> Doc
prRule ([Char], [Cat])
h] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (([Char], [Cat]) -> Doc) -> [([Char], [Cat])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc
"|" Doc -> Doc -> Doc
<+>) (Doc -> Doc) -> (([Char], [Cat]) -> Doc) -> ([Char], [Cat]) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [Cat]) -> Doc
prRule) [([Char], [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 :: [Char] -> Data -> Doc
genFunctorInstance [Char]
functorName (Cat
cat, [([Char], [Cat])]
cons) =
    Doc
"instance" Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
functorName Doc -> Doc -> Doc
<+> [Char] -> Doc
text (Cat -> [Char]
forall a. Show a => a -> [Char]
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 ((([Char], [Cat]) -> Doc) -> [([Char], [Cat])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Cat]) -> Doc
mkCase [([Char], [Cat])]
cons)))
  where
    mkCase :: ([Char], [Cat]) -> Doc
mkCase ([Char]
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
$
        [ [ [Char] -> Doc
text [Char]
f, Doc
"a" ]
        , [Doc]
vars
        , [ Doc
"->", [Char] -> Doc
text [Char]
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 -> [[Char]] -> [Char] -> Doc
prSpecialData TokenText
tokenText Bool
position [[Char]]
classes [Char]
cat = [Doc] -> Doc
vcat
    [ [Doc] -> Doc
hsep [ Doc
"newtype", [Char] -> Doc
text [Char]
cat, Doc
"=", [Char] -> Doc
text [Char]
cat, Doc
contentSpec ]
    , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Doc
deriving_ [[Char]]
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 = [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ TokenText -> [Char]
tokenTextType TokenText
tokenText

-- | Generate 'deriving' clause
--
-- >>> deriving_ ["Show", "Read"]
-- deriving (Show, Read)
--
deriving_ :: [String] -> Doc
deriving_ :: [[Char]] -> Doc
deriving_ [[Char]]
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
$ ([Char] -> Doc) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Doc
text [[Char]]
cls)

-- | Generate Haskell code for the @define@d constructors.
definedRules :: Bool -> CF -> [Doc]
definedRules :: Bool -> CF -> [Doc]
definedRules Bool
functor CF
cf = [ RFun -> [[Char]] -> Exp -> Doc
forall {f}. IsFun f => f -> [[Char]] -> Exp -> Doc
mkDef RFun
f [[Char]]
xs Exp
e | FunDef RFun
f [[Char]]
xs Exp
e <- CF -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CF
cf ]
  where
    mkDef :: f -> [[Char]] -> Exp -> Doc
mkDef f
f [[Char]]
xs Exp
e = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ([Char] -> Doc) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Doc
text ([[Char]] -> [Doc]) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ [[Char]] -> [Char]
unwords [ f -> [Char]
forall f. IsFun f => f -> [Char]
mkDefName f
f, [Char]
"::", Type -> [Char]
typeToHaskell (Type -> [Char]) -> Type -> [Char]
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
        ]
      , [ [[Char]] -> [Char]
unwords ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ f -> [Char]
forall f. IsFun f => f -> [Char]
mkDefName f
f [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
xs' [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [ [Char]
"=", Exp -> [Char]
forall a. Show a => a -> [Char]
show (Exp -> [Char]) -> Exp -> [Char]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
sanitize Exp
e ] ]
      ]
      where xs' :: [[Char]]
xs' = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall {t} {a}. IsString t => (t -> a) -> [a] -> [a]
addFunctorArg [Char] -> [Char]
forall a. a -> a
id ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
avoidReservedWords [[Char]]
xs
    sanitize :: Exp -> Exp
sanitize = \case
      App [Char]
x [Exp]
es      -> [Char] -> [Exp] -> Exp
App [Char]
x ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ ([Char] -> Exp) -> [Exp] -> [Exp]
forall {t} {a}. IsString t => (t -> a) -> [a] -> [a]
addFunctorArg ([Char] -> [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 [Char]
x         -> [Char] -> Exp
Var ([Char] -> Exp) -> [Char] -> Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
avoidReservedWords [Char]
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