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

-}

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

module BNFC.Backend.Haskell.CFtoAbstract (cf2Abstract, 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 )

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@, Generic@, @Typeable@?
-- functor   :: Bool      -- ^ Make the tree a functor?
cf2Abstract :: SharedOptions -> [Char] -> CF -> Doc
cf2Abstract Options{ [Char]
lang :: SharedOptions -> [Char]
lang :: [Char]
lang, TokenText
tokenText :: SharedOptions -> TokenText
tokenText :: TokenText
tokenText, Bool
generic :: SharedOptions -> Bool
generic :: Bool
generic, Bool
functor :: SharedOptions -> Bool
functor :: 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."
        ]
      ]

    -- Modules header
    , [ [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 DeriveTraversable #-}"          | Bool
fun ]
        , [ Doc
"{-# LANGUAGE FlexibleInstances #-}"          | Bool
fun ]
        , [ Doc
"{-# LANGUAGE GeneralizedNewtypeDeriving #-}" | Bool
hasIdentLikeNoPos ] -- for IsString
        , [ Doc
"{-# LANGUAGE LambdaCase #-}"                 | Bool
fun ]
        , [ Doc
"{-# LANGUAGE PatternSynonyms #-}"            | Bool
defPosition ]
        , [ Doc
"{-# LANGUAGE OverloadedStrings #-}"          | Bool -> Bool
not ([Doc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc]
definitions), TokenText
tokenText TokenText -> TokenText -> Bool
forall a. Eq a => a -> a -> Bool
/= TokenText
StringToken ]
        ]
      ]
    , [ Doc
"-- | The abstract syntax of language" Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
lang Doc -> Doc -> Doc
<> Doc
"." ]
    , [ [Doc] -> Doc
hsep [ Doc
"module", [Char] -> Doc
text [Char]
name, Doc
"where" ] ]

    -- Imports
    , [ [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] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
List.intercalate [Char]
", " [[Char]]
typeImports [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
            | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
typeImports ]
        , [ Int -> Doc -> Doc -> Doc -> Doc -> [Doc] -> Doc
prettyList Int
2 Doc
"import qualified Prelude as C" Doc
"(" Doc
")" Doc
"," ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc]
qualifiedPreludeImports
            | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Doc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc]
qualifiedPreludeImports ]
        , [ Doc
"import qualified Data.String"
            | Bool
hasIdentLikeNoPos ] -- 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
$
        [ Bool -> [Doc] -> [Doc]
forall m. Monoid m => Bool -> m -> m
when Bool
hasTextualToks ([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 ]
        ]
      ]

    -- AST types
    , (Data -> Doc) -> [Data] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> [[Char]] -> Data -> Doc
prData Bool
functor (Bool -> [[Char]]
derivingClasses Bool
functor)) [Data]
datas

    -- Smart constructors
    , [Doc]
definitions

    -- Token definition types
    , (([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

    -- 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.
    , [ [Doc] -> Doc
vcat
        [ Doc
"-- | Start position (line, column) of something."
        , Doc
""
        , Doc
"type" Doc -> Doc -> Doc
<+> Doc
forall a. IsString a => a
posType Doc -> Doc -> Doc
<+> Doc
"=" Doc -> Doc -> Doc
<+> Doc
"C.Maybe (C.Int, C.Int)"
        , Doc
""
        , Doc
"pattern" Doc -> Doc -> Doc
<+> Doc
forall a. IsString a => a
noPosConstr Doc -> Doc -> Doc
<+> Doc
"::" Doc -> Doc -> Doc
<+> Doc
forall a. IsString a => a
posType
        , Doc
"pattern" Doc -> Doc -> Doc
<+> Doc
forall a. IsString a => a
noPosConstr Doc -> Doc -> Doc
<+> Doc
"=" Doc -> Doc -> Doc
<+> Doc
"C.Nothing"
        , Doc
""
        , Doc
"pattern" Doc -> Doc -> Doc
<+> Doc
forall a. IsString a => a
posConstr Doc -> Doc -> Doc
<+> Doc
":: C.Int -> C.Int ->" Doc -> Doc -> Doc
<+> Doc
forall a. IsString a => a
posType
        , Doc
"pattern" Doc -> Doc -> Doc
<+> Doc
forall a. IsString a => a
posConstr Doc -> Doc -> Doc
<+> Doc
"line col =" Doc -> Doc -> Doc
<+> Doc
"C.Just (line, col)"
        ]
      | Bool
defPosition
      ]

    -- HasPosition class
    , [ [Doc] -> Doc
vcat
        [ Doc
"-- | Get the start position of something."
        , Doc
""
        , Doc
"class" Doc -> Doc -> Doc
<+> Doc
forall a. IsString a => a
hasPositionClass Doc -> Doc -> Doc
<+> Doc
"a where"
        , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
forall a. IsString a => a
hasPositionMethod Doc -> Doc -> Doc
<+> Doc
":: a ->" Doc -> Doc -> Doc
<+> Doc
forall a. IsString a => a
posType
        ]
      | Bool
hasPosition
      ]

    , Bool -> [Doc] -> [Doc]
forall m. Monoid m => Bool -> m -> m
when Bool
functor ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (Data -> Doc) -> [Data] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Data -> Doc
instanceHasPositionData [Data]
datas

    , ([Char] -> Doc) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Doc
instanceHasPositionTokenType [[Char]]
positionCats

    , [ Doc
"" ] -- ensure final newline
    ]
  where
    definitions :: [Doc]
definitions  = Bool -> CF -> [Doc]
definedRules Bool
functor CF
cf

    datas :: [Data]
datas        = CF -> [Data]
cf2data CF
cf
    positionCats :: [[Char]]
positionCats = ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (CF -> [Char] -> Bool
forall f. CFG f -> [Char] -> Bool
isPositionCat CF
cf) ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ CF -> [[Char]]
specialCats CF
cf

    hasIdentLikeNoPos :: Bool
hasIdentLikeNoPos = CF -> Bool
forall g. CFG g -> Bool
hasIdentLikeTokens CF
cf
    hasTextualToks :: Bool
hasTextualToks    = CF -> Bool
forall g. CFG g -> Bool
hasTextualTokens CF
cf
    hasPosToks :: Bool
hasPosToks   = CF -> Bool
forall g. CFG g -> Bool
hasPositionTokens CF
cf
    hasData :: Bool
hasData      = Bool -> Bool
not ([Data] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Data]
datas)
    -- @defPosition@: should the @BNCF'Position@ type be defined?
    defPosition :: Bool
defPosition  = Bool
hasPosToks Bool -> Bool -> Bool
|| Bool
functor
    -- @hasPosition@: should the @HasPosition@ class be defined?
    hasPosition :: Bool
hasPosition  = Bool
hasPosToks Bool -> Bool -> Bool
|| Bool
fun
    gen :: Bool
gen   = Bool
generic Bool -> Bool -> Bool
&& Bool
hasData
    fun :: Bool
fun   = Bool
functor Bool -> Bool -> Bool
&& Bool
hasData

    stdClasses :: [[Char]]
stdClasses = [ [Char]
"Eq", [Char]
"Ord", [Char]
"Show", [Char]
"Read" ]
    funClasses :: [[Char]]
funClasses = [ [Char]
"Functor", [Char]
"Foldable", [Char]
"Traversable" ]
    genClasses :: [[Char]]
genClasses = [ [Char]
"Data", [Char]
"Typeable", [Char]
"Generic" ]
    derivingClasses :: Bool -> [[Char]]
derivingClasses Bool
functor = ([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]]
stdClasses
      , Bool -> [[Char]] -> [[Char]]
forall m. Monoid m => Bool -> m -> m
when Bool
functor [[Char]]
funClasses
      , Bool -> [[Char]] -> [[Char]]
forall m. Monoid m => Bool -> m -> m
when Bool
generic [[Char]]
genClasses
      ]
    derivingClassesTokenType :: Bool -> [[Char]]
derivingClassesTokenType Bool
hasPos = [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ Bool -> [[Char]]
derivingClasses Bool
False
      , [ [Char]
"Data.String.IsString" | Bool -> Bool
not Bool
hasPos ]
      ]
    -- import Prelude (Char, Double, Integer, String)
    typeImports :: [[Char]]
typeImports =
      ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ [Char]
s -> Bool
hasData        Bool -> Bool -> Bool
&& [Char]
s [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CF -> [[Char]]
forall function. CFG function -> [[Char]]
cfgLiterals CF
cf
                  Bool -> Bool -> Bool
|| Bool
hasTextualToks Bool -> Bool -> Bool
&& TokenText
tokenText TokenText -> TokenText -> Bool
forall a. Eq a => a -> a -> Bool
== TokenText
StringToken Bool -> Bool -> Bool
&& [Char]
s [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"String")
        [[Char]]
baseTokenCatNames
    qualifiedPreludeImports :: [Doc]
qualifiedPreludeImports = [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
List.intercalate [Char]
", " [[Char]]
stdClasses | Bool
hasTextualToks Bool -> Bool -> Bool
|| Bool
hasData ]
      , [ [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
List.intercalate [Char]
", " [[Char]]
funClasses | Bool
fun ]
      , [ [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"Int, Maybe(..)" | Bool
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 :: Bool -> [[Char]] -> Data -> Doc
prData Bool
functor [[Char]]
derivingClasses (Cat
cat,[([Char], [Cat])]
rules) = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ [Doc] -> Doc
hsep [ Doc
"type", Doc
unprimedType, Doc
"=", Doc
primedType, Doc
forall a. IsString a => a
posType ] | Bool
functor ]
  , [ Doc -> Int -> Doc -> Doc
hang (Doc
"data" Doc -> Doc -> Doc
<+> Doc
dataType) Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [([Char], [Cat])] -> Doc
constructors [([Char], [Cat])]
rules ]
  , [ Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Doc
deriving_ [[Char]]
derivingClasses ]
  ]
  where
    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 ]
    unprimedType :: Doc
unprimedType       = Cat -> Doc
forall a. Pretty a => a -> Doc
pretty Cat
cat
    primedType :: Doc
primedType         = Doc -> Doc
prime Doc
unprimedType
    prime :: Doc -> Doc
prime              = (Doc -> Doc -> Doc
<> Doc
"'")
    dataType :: Doc
dataType | Bool
functor = Doc
primedType Doc -> Doc -> Doc
<+> Doc
"a"
             |Bool
otherwise= Doc
unprimedType
    prArg :: Cat -> Doc
prArg Cat
c
      | Bool
functor Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> (Cat -> Bool) -> Cat -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Either [Char] [Char] -> Bool
forall a b. Either a b -> Bool
isRight (Either [Char] [Char] -> Bool)
-> (Cat -> Either [Char] [Char]) -> Cat -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Either [Char] [Char]
baseCat) Cat
c
                       = (Doc -> Doc) -> Doc -> Cat -> Doc
catToType Doc -> Doc
prime Doc
"a" Cat
c
      | Bool
otherwise      = (Doc -> Doc) -> Doc -> Cat -> Doc
catToType Doc -> Doc
forall a. a -> a
id Doc
empty Cat
c
    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 @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 :: Data -> Doc
instanceHasPositionData (Cat
cat, [([Char], [Cat])]
rules) = [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
"instance" Doc -> Doc -> Doc
<+> Doc
forall a. IsString a => a
hasPositionClass Doc -> Doc -> Doc
<+> Doc
dat Doc -> Doc -> Doc
<+> Doc
"where" ]
  , [ Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"hasPosition = \\case" ]
  , (([Char], [Cat]) -> Doc) -> [([Char], [Cat])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\ ([Char]
c, [Cat]
args) -> Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [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]
c, Doc
pos], Doc
"_" Doc -> [Cat] -> [Doc]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Cat]
args, [Doc
"->", Doc
pos] ]) [([Char], [Cat])]
rules
  ]
  where
  dat :: Doc
dat = [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ Cat -> [Char]
catToStr Cat
cat
  pos :: Doc
pos = Doc
"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 -> 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
"(C.Int, C.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 HasPosition instances for Ident types
--
-- >>> instanceHasPositionTokenType catIdent
-- instance HasPosition Ident where
--   hasPosition (Ident (p, _)) = C.Just p

instanceHasPositionTokenType :: TokenCat -> Doc
instanceHasPositionTokenType :: [Char] -> Doc
instanceHasPositionTokenType [Char]
cat = [Doc] -> Doc
vcat
  [ Doc
"instance" Doc -> Doc -> Doc
<+> Doc
forall a. IsString a => a
hasPositionClass Doc -> Doc -> Doc
<+> Doc
t Doc -> Doc -> Doc
<+> Doc
"where"
  , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"hasPosition " Doc -> Doc -> Doc
<> Doc -> Doc
parens (Doc
t Doc -> Doc -> Doc
<+> Doc
"(p, _)") Doc -> Doc -> Doc
<+> Doc
"= C.Just p"
  ]
  where
  t :: Doc
t = [Char] -> Doc
text [Char]
cat


-- | Generate Haskell code for the @define@d constructors.
definedRules :: Bool -> CF -> [Doc]
definedRules :: Bool -> CF -> [Doc]
definedRules Bool
functor CF
cf = (Define -> Doc) -> [Define] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Define -> Doc
mkDef ([Define] -> [Doc]) -> [Define] -> [Doc]
forall a b. (a -> b) -> a -> b
$ CF -> [Define]
forall f. CFG f -> [Define]
definitions CF
cf
  where
  mkDef :: Define -> Doc
mkDef (Define RFun
f Telescope
args Exp' [Char]
e Base
t) = [Doc] -> Doc
vcat ([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] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [ [Char]
fName, [Char]
"::", Type -> [Char]
typ (Type -> [Char]) -> Type -> [Char]
forall a b. (a -> b) -> a -> b
$ WithPosition Type -> Type
forall a. WithPosition a -> a
wpThing WithPosition Type
t ]
      | 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
$ RFun -> CF -> Maybe (WithPosition Type)
forall a. IsFun a => a -> CF -> Maybe (WithPosition Type)
sigLookup RFun
f CF
cf
      ]
    , [ [Doc] -> Doc
hsep ([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]
fName [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
xs') [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [ Doc
"=", Exp' [Char] -> Doc
forall a. Pretty a => a -> Doc
pretty (Exp' [Char] -> Doc) -> Exp' [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ Exp' [Char] -> Exp' [Char]
sanitize Exp' [Char]
e ] ]
    ]
    where
    fName :: [Char]
fName = RFun -> [Char]
forall f. IsFun f => f -> [Char]
mkDefName RFun
f
    xs :: [[Char]]
xs    = (([Char], Base) -> [Char]) -> Telescope -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Base) -> [Char]
forall a b. (a, b) -> a
fst Telescope
args
    avoidReserved :: [Char] -> [Char]
avoidReserved = [[Char]] -> [Char] -> [Char]
avoidReservedWords [[Char]
fName]
    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]
avoidReserved [[Char]]
xs
    typ :: Type -> [Char]
typ (FunT [Base]
ts Base
t) | Bool
functor = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
List.intercalate [Char]
" -> " ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"a" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: ((Base -> [Char]) -> [Base] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Base -> [Char]
funBase ([Base] -> [[Char]]) -> [Base] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [Base]
ts [Base] -> [Base] -> [Base]
forall a. [a] -> [a] -> [a]
++ [Base
t])
    typ Type
t = Type -> [Char]
typeToHaskell Type
t
    sanitize :: Exp' [Char] -> Exp' [Char]
sanitize = \case
      App [Char]
x Type
t [Exp' [Char]]
es
        | [Char] -> Bool
forall a. IsFun a => a -> Bool
isNilCons [Char]
x -> [Char] -> Type -> [Exp' [Char]] -> Exp' [Char]
forall f. f -> Type -> [Exp' f] -> Exp' f
App [Char]
x Type
t ([Exp' [Char]] -> Exp' [Char]) -> [Exp' [Char]] -> Exp' [Char]
forall a b. (a -> b) -> a -> b
$ (Exp' [Char] -> Exp' [Char]) -> [Exp' [Char]] -> [Exp' [Char]]
forall a b. (a -> b) -> [a] -> [b]
map Exp' [Char] -> Exp' [Char]
sanitize [Exp' [Char]]
es
        | [Char] -> Bool
tokTyp [Char]
x    -> [Char] -> Type -> [Exp' [Char]] -> Exp' [Char]
forall f. f -> Type -> [Exp' f] -> Exp' f
App [Char]
x Type
t ([Exp' [Char]] -> Exp' [Char]) -> [Exp' [Char]] -> Exp' [Char]
forall a b. (a -> b) -> a -> b
$ (Exp' [Char] -> Exp' [Char]) -> [Exp' [Char]] -> [Exp' [Char]]
forall a b. (a -> b) -> [a] -> [b]
map Exp' [Char] -> Exp' [Char]
sanitize [Exp' [Char]]
es
        | Bool
otherwise   -> [Char] -> Type -> [Exp' [Char]] -> Exp' [Char]
forall f. f -> Type -> [Exp' f] -> Exp' f
App [Char]
x Type
t ([Exp' [Char]] -> Exp' [Char]) -> [Exp' [Char]] -> Exp' [Char]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Exp' [Char]) -> [Exp' [Char]] -> [Exp' [Char]]
forall {t} {a}. IsString t => (t -> a) -> [a] -> [a]
addFunctorArg (\ [Char]
e -> [Char] -> Type -> [Exp' [Char]] -> Exp' [Char]
forall f. f -> Type -> [Exp' f] -> Exp' f
App [Char]
e Type
dummyType []) ([Exp' [Char]] -> [Exp' [Char]]) -> [Exp' [Char]] -> [Exp' [Char]]
forall a b. (a -> b) -> a -> b
$ (Exp' [Char] -> Exp' [Char]) -> [Exp' [Char]] -> [Exp' [Char]]
forall a b. (a -> b) -> [a] -> [b]
map Exp' [Char] -> Exp' [Char]
sanitize [Exp' [Char]]
es
      Var [Char]
x         -> [Char] -> Exp' [Char]
forall f. [Char] -> Exp' f
Var ([Char] -> Exp' [Char]) -> [Char] -> Exp' [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
avoidReserved [Char]
x
      e :: Exp' [Char]
e@LitInt{}    -> Exp' [Char]
e
      e :: Exp' [Char]
e@LitDouble{} -> Exp' [Char]
e
      e :: Exp' [Char]
e@LitChar{}   -> Exp' [Char]
e
      e :: Exp' [Char]
e@LitString{} -> Exp' [Char]
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
    funBase :: Base -> String
    funBase :: Base -> [Char]
funBase = \case
      BaseT [Char]
x
        | [Char] -> Bool
tokTyp [Char]
x  -> [Char]
x
        | Bool
otherwise -> [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' a"
      ListT Base
b -> [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Char]
"[", Base -> [Char]
funBase Base
b, [Char]
"]" ]
    tokTyp :: [Char] -> Bool
tokTyp = ([Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CF -> [[Char]]
forall function. CFG function -> [[Char]]
literals CF
cf)