{-
    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 -> String -> CF -> Doc
cf2Abstract Options{ String
lang :: SharedOptions -> String
lang :: String
lang, TokenText
tokenText :: SharedOptions -> TokenText
tokenText :: TokenText
tokenText, Bool
generic :: SharedOptions -> Bool
generic :: Bool
generic, Bool
functor :: SharedOptions -> Bool
functor :: 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
$
    [ []

    -- 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
<+> String -> Doc
text String
lang Doc -> Doc -> Doc
<> Doc
"." ]
    , [ [Doc] -> Doc
hsep [ Doc
"module", String -> Doc
text String
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
$
        [ [ 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 -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
", " [String]
typeImports String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
            | 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]
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
$ (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 ]
        ]
      ]

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

    -- Smart constructors
    , [Doc]
definitions

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

    -- 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

    , (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
instanceHasPositionTokenType [String]
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 :: [String]
positionCats = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (CF -> String -> Bool
forall f. CFG f -> String -> Bool
isPositionCat CF
cf) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ CF -> [String]
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 :: [String]
stdClasses = [ String
"Eq", String
"Ord", String
"Show", String
"Read" ]
    funClasses :: [String]
funClasses = [ String
"Functor", String
"Foldable", String
"Traversable" ]
    genClasses :: [String]
genClasses = [ String
"Data", String
"Typeable", String
"Generic" ]
    derivingClasses :: Bool -> [String]
derivingClasses Bool
functor = (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]
stdClasses
      , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
when Bool
functor [String]
funClasses
      , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
when Bool
generic [String]
genClasses
      ]
    derivingClassesTokenType :: Bool -> [String]
derivingClassesTokenType Bool
hasPos = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ Bool -> [String]
derivingClasses Bool
False
      , [ String
"Data.String.IsString" | Bool -> Bool
not Bool
hasPos ]
      ]
    -- import Prelude (Char, Double, Integer, String)
    typeImports :: [String]
typeImports =
      (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ String
s -> Bool
hasData        Bool -> Bool -> Bool
&& String
s String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CF -> [String]
forall function. CFG function -> [String]
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
&& String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"String")
        [String]
baseTokenCatNames
    qualifiedPreludeImports :: [Doc]
qualifiedPreludeImports = [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
", " [String]
stdClasses | Bool
hasTextualToks Bool -> Bool -> Bool
|| Bool
hasData ]
      , [ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
", " [String]
funClasses | Bool
fun ]
      , [ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"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 -> [String] -> Data -> Doc
prData Bool
functor [String]
derivingClasses (Cat
cat,[(String, [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
$
        [(String, [Cat])] -> Doc
constructors [(String, [Cat])]
rules ]
  , [ Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [String] -> Doc
deriving_ [String]
derivingClasses ]
  ]
  where
    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 ]
    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 String String -> Bool
forall a b. Either a b -> Bool
isRight (Either String String -> Bool)
-> (Cat -> Either String String) -> Cat -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Either String String
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 :: [(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 @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, [(String, [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" ]
  , ((String, [Cat]) -> Doc) -> [(String, [Cat])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\ (String
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 [ [String -> Doc
text String
c, Doc
pos], Doc
"_" Doc -> [Cat] -> [Doc]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Cat]
args, [Doc
"->", Doc
pos] ]) [(String, [Cat])]
rules
  ]
  where
  dat :: Doc
dat = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Cat -> String
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 -> [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
"(C.Int, C.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 HasPosition instances for Ident types
--
-- >>> instanceHasPositionTokenType catIdent
-- instance HasPosition Ident where
--   hasPosition (Ident (p, _)) = C.Just p

instanceHasPositionTokenType :: TokenCat -> Doc
instanceHasPositionTokenType :: String -> Doc
instanceHasPositionTokenType String
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 = String -> Doc
text String
cat

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

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

haskellDefCfg :: DefCfg
haskellDefCfg :: DefCfg
haskellDefCfg = DefCfg :: (String -> String)
-> String
-> String
-> String
-> String
-> (String -> String)
-> (Exp -> Exp)
-> ([Base] -> [Base])
-> DefCfg
DefCfg
  { sanitizeName :: String -> String
sanitizeName = [String] -> String -> String
avoidReservedWords []
  , hasType :: String
hasType      = String
"::"
  , arrow :: String
arrow        = String
"->"
  , lambda :: String
lambda       = String
"\\"
  , cons :: String
cons         = String
"(:)"
  , convTok :: String -> String
convTok      = String -> String
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{String
String -> String
[Base] -> [Base]
Exp -> Exp
polymorphism :: [Base] -> [Base]
convLitInt :: Exp -> Exp
convTok :: String -> String
cons :: String
lambda :: String
arrow :: String
hasType :: String
sanitizeName :: String -> String
polymorphism :: DefCfg -> [Base] -> [Base]
convLitInt :: DefCfg -> Exp -> Exp
convTok :: DefCfg -> String -> String
cons :: DefCfg -> String
lambda :: DefCfg -> String
arrow :: DefCfg -> String
hasType :: DefCfg -> String
sanitizeName :: DefCfg -> String -> String
..} 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
    [ [ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [ String
fName, String
hasType, String -> Type -> String
typeToHaskell' String
arrow (Type -> String) -> Type -> String
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
        [ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text [ String
fName, String
"=", String
lambda ]
        , (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) -> [String] -> [String]
forall a. (String -> a) -> [a] -> [a]
addFunctorArg String -> String
forall a. a -> a
id ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ((String, Base) -> String) -> Telescope -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
sanitizeName (String -> String)
-> ((String, Base) -> String) -> (String, Base) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Base) -> String
forall a b. (a, b) -> a
fst) Telescope
args
        , [ String -> Doc
text String
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 :: String
fName = RFun -> String
forall f. IsFun f => f -> String
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
$ String -> Base
forall a. a -> Base' a
BaseT String
"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 = (String -> String) -> Base -> Base
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> String) -> Base -> Base)
-> (String -> String) -> Base -> Base
forall a b. (a -> b) -> a -> b
$ \ String
x -> if String -> Bool
tokTyp String
x then String
x else String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' a"
    tokTyp :: String -> Bool
    tokTyp :: String -> Bool
tokTyp = (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CF -> [String]
forall function. CFG function -> [String]
literals CF
cf)
    sanitize :: Exp -> Exp
    sanitize :: Exp -> Exp
sanitize = \case
      App String
x Type
t [Exp]
es
        | String -> Bool
forall a. IsFun a => a -> Bool
isConsFun String
x -> String -> Type -> [Exp] -> Exp
forall f. f -> Type -> [Exp' f] -> Exp' f
App String
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
        | String -> Bool
forall a. IsFun a => a -> Bool
isNilFun String
x  -> String -> Type -> [Exp] -> Exp
forall f. f -> Type -> [Exp' f] -> Exp' f
App String
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
        | String -> Bool
tokTyp String
x    -> String -> Type -> [Exp] -> Exp
forall f. f -> Type -> [Exp' f] -> Exp' f
App (String -> String
convTok String
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   -> String -> Type -> [Exp] -> Exp
forall f. f -> Type -> [Exp' f] -> Exp' f
App (String -> String
sanitizeName String
x) Type
t ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (String -> Exp) -> [Exp] -> [Exp]
forall a. (String -> a) -> [a] -> [a]
addFunctorArg (\ String
x -> String -> Type -> [Exp] -> Exp
forall f. f -> Type -> [Exp' f] -> Exp' f
App String
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 String
x         -> String -> Exp
forall f. String -> Exp' f
Var (String -> Exp) -> String -> Exp
forall a b. (a -> b) -> a -> b
$ String -> String
sanitizeName String
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 :: (String -> a) -> [a] -> [a]
addFunctorArg String -> a
g = Bool -> ([a] -> [a]) -> [a] -> [a]
forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
functor (String -> a
g String
"_a" a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)