{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Haskell.AbstractSyntax
  ( cf2abs, haskellAbstractSyntax, printFunctions )

  where

import BNFC.CF

import BNFC.Backend.CommonInterface.Backend

import BNFC.Backend.Common.Utils as Utils

import BNFC.Backend.Haskell.Options
import BNFC.Backend.Haskell.State
import BNFC.Backend.Haskell.Template (haskellTemplate)

import BNFC.Backend.Haskell.Utilities.Utils

import BNFC.Options.GlobalOptions

import BNFC.Prelude

import Control.Monad.State

import qualified Data.Map        as Map
import           Data.List       (intersperse)
import           Data.String     (fromString)

import Prettyprinter

import System.FilePath (takeBaseName)

haskellAbstractSyntax :: LBNF -> State HaskellBackendState Result
haskellAbstractSyntax :: LBNF -> State HaskellBackendState Result
haskellAbstractSyntax LBNF
lbnf = do
  HaskellBackendState
st <- StateT HaskellBackendState Identity HaskellBackendState
forall s (m :: * -> *). MonadState s m => m s
get
  Result
template <- LBNF -> State HaskellBackendState Result
haskellTemplate LBNF
lbnf
  let cfName :: String
cfName      = String -> String
takeBaseName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ GlobalOptions -> String
optInput (GlobalOptions -> String) -> GlobalOptions -> String
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> GlobalOptions
globalOpt HaskellBackendState
st
      rules :: [(Type, [(Label, ([Type], (Integer, ARHS)))])]
rules       = [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
filterRules ([(Type, [(Label, ([Type], (Integer, ARHS)))])]
 -> [(Type, [(Label, ([Type], (Integer, ARHS)))])])
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
forall a b. (a -> b) -> a -> b
$ HaskellBackendState
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules HaskellBackendState
st
      hasData :: Bool
hasData     = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Type, [(Label, ([Type], (Integer, ARHS)))])]
rules
      funs :: [(LabelName, Function)]
funs        = HaskellBackendState -> [(LabelName, Function)]
functions HaskellBackendState
st
      toks :: [(LabelName, TokenDef)]
toks        = HaskellBackendState -> [(LabelName, TokenDef)]
tokens HaskellBackendState
st
      inDirectory :: Bool
inDirectory = HaskellBackendOptions -> Bool
inDir (HaskellBackendOptions -> Bool) -> HaskellBackendOptions -> Bool
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
      nSpace :: Maybe String
nSpace      = HaskellBackendOptions -> Maybe String
nameSpace (HaskellBackendOptions -> Maybe String)
-> HaskellBackendOptions -> Maybe String
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
      tt :: TokenText
tt          = HaskellBackendOptions -> TokenText
tokenText (HaskellBackendOptions -> TokenText)
-> HaskellBackendOptions -> TokenText
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
      funct :: Bool
funct       = HaskellBackendOptions -> Bool
functor (HaskellBackendOptions -> Bool) -> HaskellBackendOptions -> Bool
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
      gen :: Bool
gen         = HaskellBackendOptions -> Bool
generic (HaskellBackendOptions -> Bool) -> HaskellBackendOptions -> Bool
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
      absSyntax :: String
absSyntax   =
        LBNF
-> String
-> Bool
-> Maybe String
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(LabelName, Function)]
-> [(LabelName, TokenDef)]
-> Bool
-> Bool
-> Bool
-> TokenText
-> String
cf2abs LBNF
lbnf String
cfName Bool
inDirectory Maybe String
nSpace [(Type, [(Label, ([Type], (Integer, ARHS)))])]
rules [(LabelName, Function)]
funs [(LabelName, TokenDef)]
toks Bool
funct Bool
gen Bool
hasData TokenText
tt
  Result -> State HaskellBackendState Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> State HaskellBackendState Result)
-> Result -> State HaskellBackendState Result
forall a b. (a -> b) -> a -> b
$ (Bool -> Maybe String -> String -> String -> String -> String
mkFilePath Bool
inDirectory Maybe String
nSpace String
cfName String
"Abs" String
"hs", String
absSyntax) (String, String) -> Result -> Result
forall a. a -> [a] -> [a]
: Result
template
  where
    filterRules :: [(Type, [(Label, ([Type], (Integer, ARHS)))])]
                -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
    filterRules :: [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
filterRules [(Type, [(Label, ([Type], (Integer, ARHS)))])]
rules =
      ((Type, [(Label, ([Type], (Integer, ARHS)))]) -> Bool)
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
forall a. (a -> Bool) -> [a] -> [a]
filter
      (\(Type
_,[(Label, ([Type], (Integer, ARHS)))]
l) -> Bool -> Bool
not ([(Label, ([Type], (Integer, ARHS)))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Label, ([Type], (Integer, ARHS)))]
l))
      ((\(Type
f,[(Label, ([Type], (Integer, ARHS)))]
s) -> (Type
f, [String]
-> [(Label, ([Type], (Integer, ARHS)))]
-> [(Label, ([Type], (Integer, ARHS)))]
filterLabelsAST [String]
fNames [(Label, ([Type], (Integer, ARHS)))]
s)) ((Type, [(Label, ([Type], (Integer, ARHS)))])
 -> (Type, [(Label, ([Type], (Integer, ARHS)))]))
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
rules)

    -- Functions names.
    fNames :: [String]
    fNames :: [String]
fNames = LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (LabelName -> String) -> [LabelName] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map LabelName (WithPosition Function) -> [LabelName]
forall k a. Map k a -> [k]
Map.keys (LBNF -> Map LabelName (WithPosition Function)
_lbnfFunctions LBNF
lbnf)

cf2abs :: LBNF
       -> String
       -> Bool
       -> Maybe String
       -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
       -> [(LabelName,Function)]
       -> [(CatName,TokenDef)]
       -> Bool
       -> Bool
       -> Bool
       -> TokenText
       -> String
cf2abs :: LBNF
-> String
-> Bool
-> Maybe String
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(LabelName, Function)]
-> [(LabelName, TokenDef)]
-> Bool
-> Bool
-> Bool
-> TokenText
-> String
cf2abs LBNF
lbnf String
cfName Bool
inDir Maybe String
nameSpace [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules [(LabelName, Function)]
functions [(LabelName, TokenDef)]
toks Bool
functor Bool
generic Bool
hasData TokenText
tokenText =
  LayoutOptions -> Doc () -> String
docToString LayoutOptions
defaultLayoutOptions (Doc () -> String) -> Doc () -> String
forall a b. (a -> b) -> a -> b
$
    LBNF
-> String
-> Bool
-> Maybe String
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(LabelName, Function)]
-> [(LabelName, TokenDef)]
-> Bool
-> Bool
-> Bool
-> TokenText
-> Doc ()
cf2doc LBNF
lbnf String
cfName Bool
inDir Maybe String
nameSpace [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules [(LabelName, Function)]
functions [(LabelName, TokenDef)]
toks Bool
functor Bool
generic Bool
hasData TokenText
tokenText

cf2doc :: LBNF
       -> String
       -> Bool
       -> Maybe String
       -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
       -> [(LabelName,Function)]
       -> [(CatName,TokenDef)]
       -> Bool
       -> Bool
       -> Bool
       -> TokenText
       -> Doc ()
cf2doc :: LBNF
-> String
-> Bool
-> Maybe String
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(LabelName, Function)]
-> [(LabelName, TokenDef)]
-> Bool
-> Bool
-> Bool
-> TokenText
-> Doc ()
cf2doc LBNF
lbnf String
cfName Bool
inDir Maybe String
nameSpace [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules [(LabelName, Function)]
functions [(LabelName, TokenDef)]
toks Bool
functor Bool
generic Bool
hasData TokenText
tokenText =
  [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ())
-> ([Doc ()] -> [Doc ()]) -> [Doc ()] -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
forall ann. Doc ann
emptyDoc ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
    LBNF
-> [String]
-> String
-> Bool
-> Maybe String
-> Bool
-> Bool
-> Bool
-> TokenText
-> Doc ()
prologue LBNF
lbnf [String]
usedBuiltins String
cfName Bool
inDir Maybe String
nameSpace Bool
functor Bool
generic Bool
hasData TokenText
tokenText
    Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
:
    [Doc ()]
toBePrinted
  where
    usedBuiltins :: [String]
usedBuiltins = (BuiltinCat -> String) -> [BuiltinCat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (LabelName -> String)
-> (BuiltinCat -> LabelName) -> BuiltinCat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinCat -> LabelName
printBuiltinCat) (Map BuiltinCat (List1 Position) -> [BuiltinCat]
forall k a. Map k a -> [k]
Map.keys (Map BuiltinCat (List1 Position) -> [BuiltinCat])
-> Map BuiltinCat (List1 Position) -> [BuiltinCat]
forall a b. (a -> b) -> a -> b
$ LBNF -> Map BuiltinCat (List1 Position)
_lbnfASTBuiltins LBNF
lbnf)
    tokenNames :: [String]
tokenNames   = LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (LabelName -> String) -> [LabelName] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map LabelName (WithPosition TokenDef) -> [LabelName]
forall k a. Map k a -> [k]
Map.keys (LBNF -> Map LabelName (WithPosition TokenDef)
_lbnfTokenDefs LBNF
lbnf)
    -- @defPosition@: should the @BNCF'Position@ type be defined?
    defPosition :: Bool
defPosition  = Bool
hasPosTokens Bool -> Bool -> Bool
|| Bool
functor
    -- @hasPosition@: should the @HasPosition@ class be defined?
    hasPosition :: Bool
hasPosition  = Bool
hasPosTokens Bool -> Bool -> Bool
|| (Bool
functor Bool -> Bool -> Bool
&& Bool
hasData)
    hasPosTokens :: Bool
hasPosTokens = (WithPosition TokenDef -> Bool)
-> Map LabelName (WithPosition TokenDef) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any WithPosition TokenDef -> Bool
isPositionToken (LBNF -> Map LabelName (WithPosition TokenDef)
_lbnfTokenDefs LBNF
lbnf)
    posTokens :: [(LabelName, TokenDef)]
posTokens    = ((LabelName, TokenDef) -> Bool)
-> [(LabelName, TokenDef)] -> [(LabelName, TokenDef)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TokenDef -> Bool
isPosToken (TokenDef -> Bool)
-> ((LabelName, TokenDef) -> TokenDef)
-> (LabelName, TokenDef)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LabelName, TokenDef) -> TokenDef
forall a b. (a, b) -> b
snd) [(LabelName, TokenDef)]
toks

    datas :: Maybe (Doc ())
datas = if [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules
            then Maybe (Doc ())
forall a. Maybe a
Nothing
            else Doc () -> Maybe (Doc ())
forall a. a -> Maybe a
Just (Doc () -> Maybe (Doc ())) -> Doc () -> Maybe (Doc ())
forall a b. (a -> b) -> a -> b
$ [String]
-> [String]
-> Bool
-> Bool
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> Doc ()
printDatas [String]
usedBuiltins [String]
tokenNames Bool
functor Bool
generic [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules

    funs :: Maybe (Doc ())
funs = if [(LabelName, Function)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LabelName, Function)]
functions
           then Maybe (Doc ())
forall a. Maybe a
Nothing
           else Doc () -> Maybe (Doc ())
forall a. a -> Maybe a
Just (Doc () -> Maybe (Doc ())) -> Doc () -> Maybe (Doc ())
forall a b. (a -> b) -> a -> b
$ Bool -> [(LabelName, Function)] -> Doc ()
printFunctions Bool
functor [(LabelName, Function)]
functions

    tokens :: Maybe (Doc ())
tokens = if [(LabelName, TokenDef)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LabelName, TokenDef)]
toks
             then Maybe (Doc ())
forall a. Maybe a
Nothing
             else Doc () -> Maybe (Doc ())
forall a. a -> Maybe a
Just (Doc () -> Maybe (Doc ())) -> Doc () -> Maybe (Doc ())
forall a b. (a -> b) -> a -> b
$ Bool -> TokenText -> [(LabelName, TokenDef)] -> Doc ()
printTokens Bool
generic TokenText
tokenText [(LabelName, TokenDef)]
toks

    posDef :: Maybe (Doc ())
posDef = if Bool
defPosition
             then Doc () -> Maybe (Doc ())
forall a. a -> Maybe a
Just Doc ()
positionDef
             else Maybe (Doc ())
forall a. Maybe a
Nothing

    posInstances :: Maybe (Doc ())
posInstances =
      if Bool
hasPosition
      then Doc () -> Maybe (Doc ())
forall a. a -> Maybe a
Just (Doc () -> Maybe (Doc ())) -> Doc () -> Maybe (Doc ())
forall a b. (a -> b) -> a -> b
$ [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(LabelName, TokenDef)] -> Bool -> Doc ()
positionInstances [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules [(LabelName, TokenDef)]
posTokens Bool
functor
      else Maybe (Doc ())
forall a. Maybe a
Nothing

    toBePrinted :: [Doc ()]
toBePrinted = [Maybe (Doc ())] -> [Doc ()]
forall a. [Maybe a] -> [a]
catMaybes [ Maybe (Doc ())
datas, Maybe (Doc ())
funs, Maybe (Doc ())
tokens, Maybe (Doc ())
posDef, Maybe (Doc ())
posInstances ]

prologue :: LBNF
         -> [String]
         -> String
         -> Bool
         -> Maybe String
         -> Bool
         -> Bool
         -> Bool
         -> TokenText
         -> Doc ()
prologue :: LBNF
-> [String]
-> String
-> Bool
-> Maybe String
-> Bool
-> Bool
-> Bool
-> TokenText
-> Doc ()
prologue LBNF
lbnf [String]
usedBuiltins String
cfName Bool
inDir Maybe String
nameSpace Bool
functor Bool
generic Bool
hasData TokenText
tokenText =
  [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
    [ Doc ()
comment
    , LBNF -> Bool -> Bool -> Bool -> Bool -> Bool -> TokenText -> Doc ()
pragmas LBNF
lbnf Bool
functor Bool
generic Bool
hasData Bool
hasPosTokens Bool
hasIdentAndNoPos TokenText
tokenText
    , Doc ()
"-- | The abstract syntax of language" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
cfName Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
dot
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"module" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString (Bool -> Maybe String -> String -> String -> String
mkModule Bool
inDir Maybe String
nameSpace String
cfName String
"Abs") Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"where"
    , [String]
-> Bool
-> Bool
-> TokenText
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Doc ()
imports [String]
usedBuiltins Bool
functor Bool
generic TokenText
tokenText Bool
hasData Bool
hasIdentAndNoPos
      Bool
hasTokens Bool
hasPosTokens Bool
hasIdent
    ]

  where
    comment :: Doc ()
    comment :: Doc ()
comment = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"-- Haskel data types for the abstract syntax."
      , Doc ()
"-- Generated by the BNF converter."
      ]

    hasIdent :: Bool
    hasIdent :: Bool
hasIdent = Map LabelName (WithPosition TokenDef) -> Bool
hasIdentifier (Map LabelName (WithPosition TokenDef) -> Bool)
-> Map LabelName (WithPosition TokenDef) -> Bool
forall a b. (a -> b) -> a -> b
$ LBNF -> Map LabelName (WithPosition TokenDef)
_lbnfTokenDefs LBNF
lbnf

    hasPosTokens :: Bool
    hasPosTokens :: Bool
hasPosTokens = (WithPosition TokenDef -> Bool)
-> Map LabelName (WithPosition TokenDef) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any WithPosition TokenDef -> Bool
isPositionToken (LBNF -> Map LabelName (WithPosition TokenDef)
_lbnfTokenDefs LBNF
lbnf)

    -- does the grammar have user defined tokens.
    hasTokens :: Bool
    hasTokens :: Bool
hasTokens =
      if Bool
hasIdent
      -- remove 'builtin' Ident
      then Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map LabelName (WithPosition TokenDef) -> Bool
forall k a. Map k a -> Bool
Map.null (Map LabelName (WithPosition TokenDef) -> Bool)
-> Map LabelName (WithPosition TokenDef) -> Bool
forall a b. (a -> b) -> a -> b
$ LabelName
-> Map LabelName (WithPosition TokenDef)
-> Map LabelName (WithPosition TokenDef)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (Char
'I'Char -> String -> LabelName
forall a. a -> [a] -> NonEmpty a
:|String
"dent") (LBNF -> Map LabelName (WithPosition TokenDef)
_lbnfTokenDefs LBNF
lbnf)
      else Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map LabelName (WithPosition TokenDef) -> Bool
forall k a. Map k a -> Bool
Map.null (Map LabelName (WithPosition TokenDef) -> Bool)
-> Map LabelName (WithPosition TokenDef) -> Bool
forall a b. (a -> b) -> a -> b
$ LBNF -> Map LabelName (WithPosition TokenDef)
_lbnfTokenDefs LBNF
lbnf

    -- grammar presents @Ident@ builtin and no positions tokens.
    hasIdentAndNoPos :: Bool
    hasIdentAndNoPos :: Bool
hasIdentAndNoPos = Bool
hasIdent Bool -> Bool -> Bool
|| (WithPosition TokenDef -> Bool)
-> Map LabelName (WithPosition TokenDef) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any WithPosition TokenDef -> Bool
isNoPositionToken (LBNF -> Map LabelName (WithPosition TokenDef)
_lbnfTokenDefs LBNF
lbnf)

pragmas :: LBNF -> Bool -> Bool -> Bool -> Bool -> Bool -> TokenText -> Doc ()
pragmas :: LBNF -> Bool -> Bool -> Bool -> Bool -> Bool -> TokenText -> Doc ()
pragmas LBNF
lbnf Bool
functor Bool
generic Bool
hasData Bool
hasPosTokens Bool
hasIdentAndNoPos TokenText
tokenText = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ [[Doc ()]] -> [Doc ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ Doc ()
forall ann. Doc ann
emptyDoc ]
  , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (Bool
generic Bool -> Bool -> Bool
&& Bool
hasData)
    [ Doc ()
"{-# LANGUAGE DeriveDataTypeable #-}"
    , Doc ()
"{-# LANGUAGE DeriveGeneric #-}"
    ]
  , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (Bool
functor Bool -> Bool -> Bool
&& Bool
hasData)
    [ Doc ()
"{-# LANGUAGE DeriveTraversable #-}"
    , Doc ()
"{-# LANGUAGE FlexibleInstances #-}"
    ]
  , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when Bool
hasIdentAndNoPos
    [ Doc ()
"{-# LANGUAGE GeneralizedNewtypeDeriving #-}" ]
  , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (Bool
functor Bool -> Bool -> Bool
&& Bool
hasData)
    [ Doc ()
"{-# LANGUAGE LambdaCase #-}" ]
  , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (Bool
functor Bool -> Bool -> Bool
|| Bool
hasPosTokens)
    [ Doc ()
"{-# LANGUAGE PatternSynonyms #-}" ]
  , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (Bool
anyFunction Bool -> Bool -> Bool
&& Bool
notString)
    [ Doc ()
"{-# LANGUAGE OverloadedStrings #-}" ]
  , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when ( (Bool
generic Bool -> Bool -> Bool
&& Bool
hasData) Bool -> Bool -> Bool
|| (Bool
functor Bool -> Bool -> Bool
&& Bool
hasData) Bool -> Bool -> Bool
|| Bool
hasIdentAndNoPos Bool -> Bool -> Bool
||
                (Bool
functor Bool -> Bool -> Bool
&& Bool
hasPosTokens) Bool -> Bool -> Bool
|| (Bool
anyFunction Bool -> Bool -> Bool
&& Bool
notString) )
    [ Doc ()
forall ann. Doc ann
emptyDoc ]
  ]

  where

  notString :: Bool
  notString :: Bool
notString = TokenText
tokenText TokenText -> TokenText -> Bool
forall a. Eq a => a -> a -> Bool
/= TokenText
StringToken

  anyFunction :: Bool
  anyFunction :: Bool
anyFunction = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map LabelName (WithPosition Function) -> Bool
forall k a. Map k a -> Bool
Map.null (Map LabelName (WithPosition Function) -> Bool)
-> Map LabelName (WithPosition Function) -> Bool
forall a b. (a -> b) -> a -> b
$ LBNF -> Map LabelName (WithPosition Function)
_lbnfFunctions LBNF
lbnf


imports :: [String]
        -> Bool
        -> Bool
        -> TokenText
        -> Bool
        -> Bool
        -> Bool
        -> Bool
        -> Bool
        -> Doc ()
imports :: [String]
-> Bool
-> Bool
-> TokenText
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Doc ()
imports
  [String]
usedBuiltins Bool
functor Bool
generic TokenText
tokenText Bool
hasData Bool
hasIdentAndNoPos Bool
hasTokens Bool
hasPosTokens Bool
hasIdent =
  [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ [[Doc ()]] -> [Doc ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ Doc ()
forall ann. Doc ann
emptyDoc ]
    , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (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 ()]
builtinsToImport)
      [ Doc ()
"import qualified Prelude as T" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
tupled [Doc ()]
builtinsToImport ]
    , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (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 ()]
preludeImports)
      [ Doc ()
"import qualified Prelude as C" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
softline Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
qPreludeImports ]
    , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (Bool
generic Bool -> Bool -> Bool
&& Bool
hasData)
      [ Doc ()
forall ann. Doc ann
emptyDoc
      , Doc ()
"import qualified Data.Data    as C (Data, Typeable)"
      , Doc ()
"import qualified GHC.Generics as C (Generic)"
      ]
    , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when Bool
hasIdentAndNoPos
      [ Doc ()
forall ann. Doc ann
emptyDoc
      , Doc ()
"import Data.String"
      ]
    , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when ((Bool
hasTokens Bool -> Bool -> Bool
|| Bool
hasIdent) Bool -> Bool -> Bool
&& (TokenText
tokenText TokenText -> TokenText -> Bool
forall a. Eq a => a -> a -> Bool
/= TokenText
StringToken))
      [ Doc ()
forall ann. Doc ann
emptyDoc
      , TokenText -> Doc ()
tokenTextImport TokenText
tokenText
      ]
    , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (Bool
generic Bool -> Bool -> Bool
&& Bool
hasData)
      [ Doc ()
forall ann. Doc ann
emptyDoc
      , Doc ()
"import qualified Data.Data    as C (Data, Typeable)"
      , Doc ()
"import qualified GHC.Generics as C (Generic)"
      ]
    ]
  where

    builtinsToImport :: [Doc ()]
    builtinsToImport :: [Doc ()]
builtinsToImport =
      String -> Doc ()
forall a. IsString a => String -> a
fromString
      (String -> Doc ()) -> [String] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter
      (\String
b -> (String
b String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
usedBuiltins)
      Bool -> Bool -> Bool
||
      ( (Bool
hasTokens Bool -> Bool -> Bool
|| Bool
hasIdent)
        Bool -> Bool -> Bool
&& TokenText
tokenText TokenText -> TokenText -> Bool
forall a. Eq a => a -> a -> Bool
== TokenText
StringToken
        Bool -> Bool -> Bool
&& String
b String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"String") )
      [String
"Char", String
"Double", String
"Integer", String
"String"]

    qPreludeImports :: Doc ()
    qPreludeImports :: Doc ()
qPreludeImports = Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
tupled [Doc ()]
preludeImports

    preludeImports :: [Doc ()]
    preludeImports :: [Doc ()]
preludeImports =
      Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (Bool
hasData Bool -> Bool -> Bool
|| Bool
hasIdent Bool -> Bool -> Bool
|| Bool
hasTokens) [Doc ()]
stdClasses
      [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
      Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (Bool
functor Bool -> Bool -> Bool
&& Bool
hasData) [Doc ()]
funClasses
      [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
      Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (Bool
functor Bool -> Bool -> Bool
|| Bool
hasPosTokens) [Doc ()
"Int, Maybe(..)"]

funClasses :: [Doc ()]
funClasses :: [Doc ()]
funClasses = [ Doc ()
"Functor", Doc ()
"Foldable", Doc ()
"Traversable" ]

genClasses :: [Doc ()]
genClasses :: [Doc ()]
genClasses = [ Doc ()
"Data", Doc ()
"Typeable", Doc ()
"Generic" ]

stdClasses :: [Doc ()]
stdClasses :: [Doc ()]
stdClasses = [ Doc ()
"Eq", Doc ()
"Ord", Doc ()
"Show", Doc ()
"Read" ]

derivingClasses :: Bool -> Bool -> Doc ()
derivingClasses :: Bool -> Bool -> Doc ()
derivingClasses Bool
functor Bool
generic = Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
"deriving" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
tupled [Doc ()]
toBeDerived
  where
    toBeDerived :: [Doc ()]
    toBeDerived :: [Doc ()]
toBeDerived = (Doc () -> Doc ()) -> [Doc ()] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
map (Doc ()
"C." Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<>) ([Doc ()] -> [Doc ()]) -> [Doc ()] -> [Doc ()]
forall a b. (a -> b) -> a -> b
$ [[Doc ()]] -> [Doc ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Doc ()]
stdClasses
      , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when Bool
functor [Doc ()]
funClasses
      , Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when Bool
generic [Doc ()]
genClasses
      ]

derivingClassesTokens :: Bool -> Bool -> Doc ()
derivingClassesTokens :: Bool -> Bool -> Doc ()
derivingClassesTokens Bool
generic Bool
noPosToken = Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
"deriving" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
tupled [Doc ()]
toBeDerived
  where
    toBeDerived :: [Doc ()]
    toBeDerived :: [Doc ()]
toBeDerived =
      (Doc () -> Doc ()) -> [Doc ()] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
map (Doc ()
"C." Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<>) ([Doc ()]
stdClasses [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++ Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when Bool
generic [Doc ()]
genClasses)
      [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++ Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when Bool
noPosToken [Doc ()
"Data.String.IsString"]

positionDef :: Doc ()
positionDef :: Doc ()
positionDef = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"-- | Start position (line, column) of something."
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"type BNFC'Position = C.Maybe (C.Int, C.Int)"
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"pattern BNFC'NoPosition :: BNFC'Position"
  , Doc ()
"pattern BNFC'NoPosition = C.Nothing"
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"pattern BNFC'Position :: C.Int -> C.Int -> BNFC'Position"
  , Doc ()
"pattern BNFC'Position line col = C.Just (line, col)"
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"-- | Get the start position of something."
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"class HasPosition a where"
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"hasPosition :: a -> BNFC'Position"
  ]

-- | Instances of the @HasPosition@ class.

positionInstances :: [(Type, [(Label, ([Type], (Integer, ARHS)))])]
                  -> [(CatName,TokenDef)]
                  -> Bool
                  -> Doc ()
positionInstances :: [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(LabelName, TokenDef)] -> Bool -> Doc ()
positionInstances [(Type, [(Label, ([Type], (Integer, ARHS)))])]
rules [(LabelName, TokenDef)]
posTokens Bool
functor = ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ())
-> ([Doc ()] -> [Doc ()]) -> [Doc ()] -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
forall ann. Doc ann
emptyDoc) ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
    -- categories instances.
    Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (Bool -> Bool
not ([(Type, [(Label, ([Type], (Integer, ARHS)))])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Type, [(Label, ([Type], (Integer, ARHS)))])]
rules) Bool -> Bool -> Bool
&& Bool
functor) ((Type, [(Label, [Type])]) -> Doc ()
catPosInstance ((Type, [(Label, [Type])]) -> Doc ())
-> [(Type, [(Label, [Type])])] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Type, [(Label, [Type])])]
rules')
    [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
    -- position tokens instances
    Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (Bool -> Bool
not ([(LabelName, TokenDef)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LabelName, TokenDef)]
posTokens)) ((LabelName, TokenDef) -> Doc ()
tokenPosInstance ((LabelName, TokenDef) -> Doc ())
-> [(LabelName, TokenDef)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(LabelName, TokenDef)]
posTokens)

  where
    -- Get rid of (Integer, ARHS).
    rules' :: [(Type, [(Label, [Type])])]
    rules' :: [(Type, [(Label, [Type])])]
rules' = ( \(Type
t,[(Label, ([Type], (Integer, ARHS)))]
ls) -> (Type
t, ( \(Label
l,([Type]
ts, (Integer, ARHS)
_)) -> (Label
l,[Type]
ts)) ((Label, ([Type], (Integer, ARHS))) -> (Label, [Type]))
-> [(Label, ([Type], (Integer, ARHS)))] -> [(Label, [Type])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Label, ([Type], (Integer, ARHS)))]
ls ) )
             ((Type, [(Label, ([Type], (Integer, ARHS)))])
 -> (Type, [(Label, [Type])]))
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(Type, [(Label, [Type])])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
             [(Type, [(Label, ([Type], (Integer, ARHS)))])]
rules

    -- HasPosition instance coming from category (ordinary rule).

    catPosInstance :: (Type, [(Label, [Type])]) -> Doc ()
    catPosInstance :: (Type, [(Label, [Type])]) -> Doc ()
catPosInstance (Type
t, [(Label, [Type])]
lts) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"instance HasPosition" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString (Type -> String
printTypeName Type
t) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"where"
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
"hasPosition =" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
forall ann. Doc ann
backslash Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"case"
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (Label, [Type]) -> Doc ()
instanceCase ((Label, [Type]) -> Doc ()) -> [(Label, [Type])] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Label, [Type])]
lts
      ]
      where
        instanceCase :: (Label, [Type]) -> Doc ()
        instanceCase :: (Label, [Type]) -> Doc ()
instanceCase (Label
l, [Type]
ts) = String -> Doc ()
forall a. IsString a => String -> a
fromString (Label -> String
printLabelName Label
l) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"p" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
          if [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
ts
          then Doc ()
"-> p"
          else String -> Doc ()
forall a. IsString a => String -> a
fromString (Char -> String -> String
forall a. a -> [a] -> [a]
intersperse Char
' ' (Int -> Char -> String
forall a. Int -> a -> [a]
replicate ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts) Char
'_')) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"-> p"

    -- HasPosition instance coming from podition tokens.

    tokenPosInstance :: (CatName,TokenDef) -> Doc ()
    tokenPosInstance :: (LabelName, TokenDef) -> Doc ()
tokenPosInstance (LabelName
c, TokenDef
_) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"instance HasPosition" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString (LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList LabelName
c) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"where"
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
"hasPosition" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (String -> Doc ()
forall a. IsString a => String -> a
fromString (LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList LabelName
c) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"(p, _)") Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
        Doc ()
"= C.Just p"
      ]

-- | Print Haskell datatypes defined by AST rules.

printDatas :: [String]
           -> [String]
           -> Bool
           -> Bool
           -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
           -> Doc ()
printDatas :: [String]
-> [String]
-> Bool
-> Bool
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> Doc ()
printDatas [String]
usedBuiltins [String]
tokenNames Bool
functor Bool
generic =
  [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ())
-> ([(Type, [(Label, ([Type], (Integer, ARHS)))])] -> [Doc ()])
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
forall ann. Doc ann
emptyDoc ([Doc ()] -> [Doc ()])
-> ([(Type, [(Label, ([Type], (Integer, ARHS)))])] -> [Doc ()])
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [Doc ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  ((Type, [(Label, ([Type], (Integer, ARHS)))]) -> Doc ())
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Type -> [(Label, ([Type], (Integer, ARHS)))] -> Doc ())
-> (Type, [(Label, ([Type], (Integer, ARHS)))]) -> Doc ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ([String]
-> [String]
-> Bool
-> Bool
-> Type
-> [(Label, ([Type], (Integer, ARHS)))]
-> Doc ()
printData [String]
usedBuiltins [String]
tokenNames Bool
functor Bool
generic))

printData :: [String]
          -> [String]
          -> Bool
          -> Bool
          -> Type
          -> [(Label, ([Type], (Integer, ARHS)))]
          -> Doc ()
printData :: [String]
-> [String]
-> Bool
-> Bool
-> Type
-> [(Label, ([Type], (Integer, ARHS)))]
-> Doc ()
printData [String]
usedBuiltins [String]
tokenNames Bool
functor Bool
generic Type
t [(Label, ([Type], (Integer, ARHS)))]
labelItems =
  [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ [[Doc ()]] -> [Doc ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when Bool
functor
    [ Doc ()
"type" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
unprimedType Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"=" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
primedType Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
posType ]
  , [ Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
hang Int
4 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep [ Doc ()
"data" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
dataType, Doc ()
constructorsBlock] ]
  , [ Bool -> Bool -> Doc ()
derivingClasses Bool
functor Bool
generic ]
  ]
  where
    unprimedType :: Doc ()
    unprimedType :: Doc ()
unprimedType = String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ Type -> String
printTypeName Type
t
    primedType :: Doc ()
primedType = Doc ()
unprimedType Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"'"
    dataType :: Doc ()
    dataType :: Doc ()
dataType =
      if Bool
functor
      then Doc ()
primedType Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"a"
      else Doc ()
unprimedType
    constructorsBlock :: Doc ()
    constructorsBlock :: Doc ()
constructorsBlock = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (Doc () -> (Label, ([Type], ARHS)) -> Doc ())
-> [Doc ()] -> [(Label, ([Type], ARHS))] -> [Doc ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
      (\Doc ()
s (Label
l,([Type]
ts,ARHS
arhs)) -> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
        [ Doc ()
s Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [String] -> [String] -> Bool -> Label -> [Type] -> Doc ()
printConstructor [String]
usedBuiltins [String]
tokenNames Bool
functor Label
l [Type]
ts
        , Type -> Label -> ARHS -> Doc ()
printHaddockInData Type
t Label
l ARHS
arhs])
      (Doc ()
"=" Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
: Doc () -> [Doc ()]
forall a. a -> [a]
repeat Doc ()
"|")
      ((Label, ([Type], (Integer, ARHS))) -> (Label, ([Type], ARHS))
f ((Label, ([Type], (Integer, ARHS))) -> (Label, ([Type], ARHS)))
-> [(Label, ([Type], (Integer, ARHS)))]
-> [(Label, ([Type], ARHS))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Label, ([Type], (Integer, ARHS)))]
labelItems)

    f :: (Label, ([Type], (Integer, ARHS))) -> (Label, ([Type], ARHS))
    f :: (Label, ([Type], (Integer, ARHS))) -> (Label, ([Type], ARHS))
f (Label
l,([Type]
ts,(Integer, ARHS)
tup)) = (Label
l,([Type]
ts, (Integer, ARHS) -> ARHS
forall a b. (a, b) -> b
snd (Integer, ARHS)
tup))

-- | Print data type constructor and relative arguments

printConstructor :: [String] -> [String] -> Bool -> Label -> [Type] -> Doc ()
printConstructor :: [String] -> [String] -> Bool -> Label -> [Type] -> Doc ()
printConstructor [String]
usedBuiltins [String]
tokenNames Bool
functor Label
label [Type]
items =
    [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
constructor Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
: [Doc ()]
arguments
    where
      constructor :: Doc ()
      constructor :: Doc ()
constructor =
        if Bool
functor
        then String -> Doc ()
forall a. IsString a => String -> a
fromString (Label -> String
printLabelName Label
label) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"a"
        else String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ Label -> String
printLabelName Label
label
      arguments :: [Doc ()]
      arguments :: [Doc ()]
arguments = Type -> Doc ()
printArg (Type -> Doc ()) -> [Type] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
items

      printArg :: Type -> Doc ()
      printArg :: Type -> Doc ()
printArg Type
t =
        if Bool
functor
        then Bool -> (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a. Bool -> (a -> a) -> a -> a
applyWhen (Type -> Bool
isListType Type
t) Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$
             Bool -> (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a. Bool -> (a -> a) -> a -> a
applyWhen (Type -> Bool
isTypeBuiltin Type
t) Doc () -> Doc ()
addQualified (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$
             Bool -> (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a. Bool -> (a -> a) -> a -> a
applyWhen (Type -> Bool
isCat Type
t Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
isListType Type
t)) Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$
             Bool -> (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a. Bool -> (a -> a) -> a -> a
applyWhen (Type -> Bool
isCat Type
t) Doc () -> Doc ()
mkFunctor (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$
             String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ Type -> String
printTypeName Type
t
        else Bool -> (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a. Bool -> (a -> a) -> a -> a
applyWhen (Type -> Bool
isListType Type
t) Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$
             Bool -> (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a. Bool -> (a -> a) -> a -> a
applyWhen (Type -> Bool
isTypeBuiltin Type
t) Doc () -> Doc ()
addQualified (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$
             String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ Type -> String
printTypeName Type
t

      applyWhen :: Bool -> (a -> a) -> a -> a
      applyWhen :: Bool -> (a -> a) -> a -> a
applyWhen Bool
True  a -> a
f a
x = a -> a
f a
x
      applyWhen Bool
False a -> a
_ a
x = a
x
      addQualified :: Doc () -> Doc ()
      addQualified :: Doc () -> Doc ()
addQualified Doc ()
name = Doc ()
"T." Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
name
      isTypeBuiltin :: Type -> Bool
      isTypeBuiltin :: Type -> Bool
isTypeBuiltin Type
t = Type -> String
printTypeName Type
t String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
usedBuiltins
      isCat :: Type -> Bool
      isCat :: Type -> Bool
isCat Type
t = Bool -> Bool
not (Type -> Bool
isTypeBuiltin Type
t) Bool -> Bool -> Bool
&& String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem (Type -> String
printTypeName Type
t) [String]
tokenNames
      mkFunctor :: Doc () -> Doc ()
      mkFunctor :: Doc () -> Doc ()
mkFunctor Doc ()
t = Doc ()
t Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"'" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"a"

-- | Print Rule from which a datatype constructor came from as haddock comment.

printHaddockInData :: Type -> Label -> ARHS -> Doc ()
printHaddockInData :: Type -> Label -> ARHS -> Doc ()
printHaddockInData Type
t Label
_ ARHS
items =
  Doc ()
"-- ^" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString (Type -> String
printTypeName Type
t) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"::=" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ARHS -> Doc ()
items2doc ARHS
items
    where
      items2doc :: ARHS -> Doc ()
      items2doc :: ARHS -> Doc ()
items2doc ARHS
itemss = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ())
-> (Item' LabelName -> String) -> Item' LabelName -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item' LabelName -> String
printItemName (Item' LabelName -> Doc ()) -> ARHS -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ARHS
itemss)

-- | Print functions given by the define pragma.

printFunctions :: Bool -> [(LabelName,Function)] -> Doc ()
printFunctions :: Bool -> [(LabelName, Function)] -> Doc ()
printFunctions Bool
functor = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ())
-> ([(LabelName, Function)] -> [Doc ()])
-> [(LabelName, Function)]
-> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
forall ann. Doc ann
emptyDoc ([Doc ()] -> [Doc ()])
-> ([(LabelName, Function)] -> [Doc ()])
-> [(LabelName, Function)]
-> [Doc ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((LabelName, Function) -> Doc ())
-> [(LabelName, Function)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LabelName -> Function -> Doc ())
-> (LabelName, Function) -> Doc ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Bool -> LabelName -> Function -> Doc ()
printFunction Bool
functor))

printFunction :: Bool -> LabelName -> Function -> Doc ()
printFunction :: Bool -> LabelName -> Function -> Doc ()
printFunction Bool
functor LabelName
label Function
fun = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep [ Doc ()
haddock, Doc ()
header, Doc ()
withBody ]
  where
    name :: Doc ()
    name :: Doc ()
name = String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList LabelName
label
    haddock :: Doc ()
    haddock :: Doc ()
haddock = Doc ()
"-- |" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"define" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
name Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep [Doc ()]
paramsNames
      Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"=" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (Function -> String) -> Function -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String -> Exp -> String
printExp Bool
False String
functorParam (Exp -> String) -> (Function -> Exp) -> Function -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Exp
funBody) Function
fun
    header :: Doc ()
    header :: Doc ()
header = Doc ()
name Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"::" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
paramsTypes Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"->" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
returnType
    paramsTypes :: Doc ()
    paramsTypes :: Doc ()
paramsTypes =
      if Bool
functor
      then Doc ()
"a ->" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep (Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
"->" (Type -> Doc ()
paramT (Type -> Doc ()) -> [Type] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
types))
      else [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep (Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
"->" (Type -> Doc ()
paramT (Type -> Doc ()) -> [Type] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
types))
    paramT :: Type -> Doc ()
    paramT :: Type -> Doc ()
paramT Type
t =
      if Bool
functor Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
isBuiltinType Type
t)
      then (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (Type -> String) -> Type -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> String
printTypeName) Type
t Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"' a"
      else (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (Type -> String) -> Type -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> String
printTypeName) Type
t
    types :: [Type]
    types :: [Type]
types = Parameter -> Type
paramType (Parameter -> Type) -> [Parameter] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Function -> [Parameter]
funPars Function
fun
    returnType :: Doc ()
    returnType :: Doc ()
returnType =
      if Bool
functor
      then (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (Function -> String) -> Function -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> String
printTypeName (Type -> String) -> (Function -> Type) -> Function -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Type
funType) Function
fun Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"' a"
      else (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (Function -> String) -> Function -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> String
printTypeName (Type -> String) -> (Function -> Type) -> Function -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Type
funType) Function
fun
    paramsNames :: [Doc ()]
    paramsNames :: [Doc ()]
paramsNames = String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (Parameter -> String) -> Parameter -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (LabelName -> String)
-> (Parameter -> LabelName) -> Parameter -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parameter -> LabelName
paramName (Parameter -> Doc ()) -> [Parameter] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Function -> [Parameter]
funPars Function
fun
    withBody :: Doc ()
    withBody :: Doc ()
withBody =
      Doc ()
name Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
args Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"=" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (Function -> String) -> Function -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String -> Exp -> String
printExp Bool
functor String
functorParam (Exp -> String) -> (Function -> Exp) -> Function -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Exp
funBody) Function
fun
    args :: Doc ()
    args :: Doc ()
args =
      if Bool
functor
      then [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep (String -> Doc ()
forall a. IsString a => String -> a
fromString String
functorParam Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
: [Doc ()]
paramsNames)
      else [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep [Doc ()]
paramsNames
    functorParam :: String
    functorParam :: String
functorParam = String -> String
mkFunctorParam String
"a"
    mkFunctorParam :: String -> String
    mkFunctorParam :: String -> String
mkFunctorParam String
a =
      if String
a String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (String
l String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
paramNames)
      then String
a
      else String -> String
mkFunctorParam (String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")
      where
        l :: String
        l :: String
l = LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList LabelName
label
        paramNames :: [String]
        paramNames :: [String]
paramNames = LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (LabelName -> String)
-> (Parameter -> LabelName) -> Parameter -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parameter -> LabelName
paramName (Parameter -> String) -> [Parameter] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Function -> [Parameter]
funPars Function
fun


-- | Print user defined tokens.

printTokens :: Bool -> TokenText -> [(CatName,TokenDef)] -> Doc ()
printTokens :: Bool -> TokenText -> [(LabelName, TokenDef)] -> Doc ()
printTokens Bool
generic TokenText
tokenText =
  [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ())
-> ([(LabelName, TokenDef)] -> [Doc ()])
-> [(LabelName, TokenDef)]
-> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
forall ann. Doc ann
emptyDoc ([Doc ()] -> [Doc ()])
-> ([(LabelName, TokenDef)] -> [Doc ()])
-> [(LabelName, TokenDef)]
-> [Doc ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((LabelName, TokenDef) -> Doc ())
-> [(LabelName, TokenDef)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LabelName -> TokenDef -> Doc ())
-> (LabelName, TokenDef) -> Doc ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Bool -> TokenText -> LabelName -> TokenDef -> Doc ()
printToken Bool
generic TokenText
tokenText))

printToken :: Bool -> TokenText -> CatName -> TokenDef -> Doc ()
printToken :: Bool -> TokenText -> LabelName -> TokenDef -> Doc ()
printToken Bool
generic TokenText
tokenText LabelName
catName TokenDef
tokenDef = case TokenDef
tokenDef of
  (TokenDef PositionToken
PositionToken Regex
_ Bool
_) -> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
    [ Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
hang Int
4 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep [Doc ()
"newtype" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
tName
      ,Doc ()
"=" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
tName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"(" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"(C.Int, C.Int)" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"," Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
argType Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
")"]
    , Bool -> Bool -> Doc ()
derivingClassesTokens Bool
generic Bool
False]
      where
        tName :: Doc ()
tName = (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (LabelName -> String) -> LabelName -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) LabelName
catName
        argType :: Doc ()
argType = TokenText -> Doc ()
tokArgType TokenText
tokenText
  (TokenDef PositionToken
NoPositionToken Regex
_ Bool
_) -> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
    [ Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
hang Int
4 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep [ Doc ()
"newtype" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
tName
      , Doc ()
"=" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
tName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
argType ]
    , Bool -> Bool -> Doc ()
derivingClassesTokens Bool
generic Bool
True ]
      where
        tName :: Doc ()
tName = String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (LabelName -> String) -> LabelName -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (LabelName -> Doc ()) -> LabelName -> Doc ()
forall a b. (a -> b) -> a -> b
$ LabelName
catName
        argType :: Doc ()
argType = TokenText -> Doc ()
tokArgType TokenText
tokenText

tokArgType :: TokenText -> Doc ()
tokArgType :: TokenText -> Doc ()
tokArgType = \case
  TokenText
StringToken -> Doc ()
"T.String"
  TokenText
TextToken   -> Doc ()
"Data.Text.Text"