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

    -- 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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 a. Eq a => a -> [a] -> 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 a b. a -> [b] -> [a]
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

-- | Parametrize 'definedRules' so that it can be used for Agda as well.

data DefCfg = DefCfg
  { DefCfg -> [Char] -> [Char]
sanitizeName :: String -> String
  , DefCfg -> [Char]
hasType      :: String
  , DefCfg -> [Char]
arrow        :: String
  , DefCfg -> [Char]
lambda       :: String
  , DefCfg -> [Char]
cons         :: String
  , DefCfg -> [Char] -> [Char]
convTok      :: String -> String
  , DefCfg -> Exp -> Exp
convLitInt   :: Exp -> Exp
  , DefCfg -> [Base] -> [Base]
polymorphism :: [Base] -> [Base]
  }

haskellDefCfg :: DefCfg
haskellDefCfg :: DefCfg
haskellDefCfg = DefCfg
  { sanitizeName :: [Char] -> [Char]
sanitizeName = [[Char]] -> [Char] -> [Char]
avoidReservedWords []
  , hasType :: [Char]
hasType      = [Char]
"::"
  , arrow :: [Char]
arrow        = [Char]
"->"
  , lambda :: [Char]
lambda       = [Char]
"\\"
  , cons :: [Char]
cons         = [Char]
"(:)"
  , convTok :: [Char] -> [Char]
convTok      = [Char] -> [Char]
forall a. a -> a
id
  , convLitInt :: Exp -> Exp
convLitInt   = Exp -> Exp
forall a. a -> a
id
  , polymorphism :: [Base] -> [Base]
polymorphism = [Base] -> [Base]
forall a. a -> a
id
  }

-- | Generate Haskell code for the @define@d constructors.
definedRules :: Bool -> CF -> [Doc]
definedRules :: Bool -> CF -> [Doc]
definedRules = DefCfg -> Bool -> CF -> [Doc]
definedRules' DefCfg
haskellDefCfg

-- | Generate Haskell/Agda code for the @define@d constructors.
definedRules' :: DefCfg -> Bool -> CF -> [Doc]
definedRules' :: DefCfg -> Bool -> CF -> [Doc]
definedRules' DefCfg{[Char]
[Char] -> [Char]
[Base] -> [Base]
Exp -> Exp
sanitizeName :: DefCfg -> [Char] -> [Char]
hasType :: DefCfg -> [Char]
arrow :: DefCfg -> [Char]
lambda :: DefCfg -> [Char]
cons :: DefCfg -> [Char]
convTok :: DefCfg -> [Char] -> [Char]
convLitInt :: DefCfg -> Exp -> Exp
polymorphism :: DefCfg -> [Base] -> [Base]
sanitizeName :: [Char] -> [Char]
hasType :: [Char]
arrow :: [Char]
lambda :: [Char]
cons :: [Char]
convTok :: [Char] -> [Char]
convLitInt :: Exp -> Exp
polymorphism :: [Base] -> [Base]
..} 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
e Base
_) = [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]
hasType, [Char] -> Type -> [Char]
typeToHaskell' [Char]
arrow (Type -> [Char]) -> Type -> [Char]
forall a b. (a -> b) -> a -> b
$ Type -> Type
typ (Type -> Type) -> Type -> Type
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
$ [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ ([Char] -> Doc) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Doc
text [ [Char]
fName, [Char]
"=", [Char]
lambda ]
        , ([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]) -> [[Char]] -> [[Char]]
forall a. ([Char] -> a) -> [a] -> [a]
addFunctorArg [Char] -> [Char]
forall a. a -> a
id ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (([Char], Base) -> [Char]) -> Telescope -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char]
sanitizeName ([Char] -> [Char])
-> (([Char], Base) -> [Char]) -> ([Char], Base) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], Base) -> [Char]
forall a b. (a, b) -> a
fst) Telescope
args
        , [ [Char] -> Doc
text [Char]
arrow, Exp -> Doc
forall a. Pretty a => a -> Doc
pretty (Exp -> Doc) -> Exp -> Doc
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
sanitize Exp
e ]
        ]
      ]
    ]
    where
    fName :: [Char]
fName = RFun -> [Char]
forall f. IsFun f => f -> [Char]
mkDefName RFun
f
    typ :: Type -> Type
    typ :: Type -> Type
typ = Bool -> (Type -> Type) -> Type -> Type
forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
functor ((Type -> Type) -> Type -> Type) -> (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ \ (FunT [Base]
ts Base
t) ->
            [Base] -> Base -> Type
FunT ([Base] -> [Base]
polymorphism ([Base] -> [Base]) -> [Base] -> [Base]
forall a b. (a -> b) -> a -> b
$ [Char] -> Base
forall a. a -> Base' a
BaseT [Char]
"a" Base -> [Base] -> [Base]
forall a. a -> [a] -> [a]
: (Base -> Base) -> [Base] -> [Base]
forall a b. (a -> b) -> [a] -> [b]
map Base -> Base
addParam [Base]
ts) (Base -> Type) -> Base -> Type
forall a b. (a -> b) -> a -> b
$ Base -> Base
addParam Base
t
    addParam :: Base -> Base
    addParam :: Base -> Base
addParam = ([Char] -> [Char]) -> Base -> Base
forall a b. (a -> b) -> Base' a -> Base' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Char] -> [Char]) -> Base -> Base)
-> ([Char] -> [Char]) -> Base -> Base
forall a b. (a -> b) -> a -> b
$ \ [Char]
x -> if [Char] -> Bool
tokTyp [Char]
x then [Char]
x else [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' a"
    tokTyp :: String -> Bool
    tokTyp :: [Char] -> Bool
tokTyp = ([Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CF -> [[Char]]
forall function. CFG function -> [[Char]]
literals CF
cf)
    sanitize :: Exp -> Exp
    sanitize :: Exp -> Exp
sanitize = \case
      App [Char]
x Type
t [Exp]
es
        | [Char] -> Bool
forall a. IsFun a => a -> Bool
isConsFun [Char]
x -> [Char] -> Type -> [Exp] -> Exp
forall f. f -> Type -> [Exp' f] -> Exp' f
App [Char]
cons Type
t ([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
        | [Char] -> Bool
forall a. IsFun a => a -> Bool
isNilFun [Char]
x  -> [Char] -> Type -> [Exp] -> Exp
forall f. f -> Type -> [Exp' f] -> Exp' f
App [Char]
x Type
t ([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
        | [Char] -> Bool
tokTyp [Char]
x    -> [Char] -> Type -> [Exp] -> Exp
forall f. f -> Type -> [Exp' f] -> Exp' f
App ([Char] -> [Char]
convTok [Char]
x) Type
t ([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
        | Bool
otherwise   -> [Char] -> Type -> [Exp] -> Exp
forall f. f -> Type -> [Exp' f] -> Exp' f
App ([Char] -> [Char]
sanitizeName [Char]
x) Type
t ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ ([Char] -> Exp) -> [Exp] -> [Exp]
forall a. ([Char] -> a) -> [a] -> [a]
addFunctorArg (\ [Char]
x -> [Char] -> Type -> [Exp] -> Exp
forall f. f -> Type -> [Exp' f] -> Exp' f
App [Char]
x Type
dummyType []) ([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
forall f. [Char] -> Exp' f
Var ([Char] -> Exp) -> [Char] -> Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
sanitizeName [Char]
x
      e :: Exp
e@LitInt{}    -> Exp -> Exp
convLitInt Exp
e
      e :: Exp
e@LitDouble{} -> Exp
e
      e :: Exp
e@LitChar{}   -> Exp
e
      e :: Exp
e@LitString{} -> Exp
e
    -- Functor argument
    addFunctorArg :: (String -> a) -> [a] -> [a]
    addFunctorArg :: forall a. ([Char] -> a) -> [a] -> [a]
addFunctorArg [Char] -> a
g = Bool -> ([a] -> [a]) -> [a] -> [a]
forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
functor ([Char] -> a
g [Char]
"_a" a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)