path: root/testsuite/tests/perf/compiler/T15164.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

module T15164 () where

data Version = VHDL1993
data T
data NT a

class Rule f a where
  get :: Decorator f => f a

class Monad f => Decorator f where
  n :: [Version] -> f a -> f (NT a) -- n stands for both NT as well as Node (in grammar tree)
  chr :: Char -> [Version] -> f T
  txt :: String -> [Version] -> f T -- token OPTIONALLY followed by spaces

  -- combinators
  m :: f a -> f [a]
  c :: [f a] -> f a -- c stands for choose
  o :: f a -> f (Maybe a) -- o stands for optional
  trace :: String -> f a -> f a

  -- helper functions in the grammar
  n93 :: Rule f a => f (NT a)
  n93 = n [VHDL1993] get


  parenOpen :: f T
  parenOpen = chr '(' [VHDL1993]

  parenClose :: f T
  parenClose = chr ')' [VHDL1993]

  comma :: f T
  comma = chr ',' [VHDL1993]

  moreComma :: Rule f a => f [(T, NT a)]
  moreComma = m $ do
    cc <- comma
    cont <- n93
    return (cc, cont)

type P_MaybeActualParameterPart = (Maybe (T, (NT ActualParameterPart), T))
maybeActualParameterPart :: Decorator f => f (Maybe (T, NT ActualParameterPart, T))
maybeActualParameterPart = o $ do
  po <- parenOpen
  app <- (n93 :: Decorator f => f (NT ActualParameterPart))
  pc <- parenClose
  return (po, app, pc)
-- helper function used with FormalPart and ActualPart
-- dcon '(' actual_designator ')'
mkNameOrTypeMark :: (Decorator m, Rule m a1, Rule m a) => (NT a -> T -> NT a1 -> T -> b) -> m b
mkNameOrTypeMark dcon = do
  name_typemark <- n93 -- either Name OR TypeMark depending on dcon !!
  po <- parenOpen
  fd  <- n93
  pc <- parenClose
  return $ dcon name_typemark po fd pc

-- actual_designator
--          ::= expression
--            | name
--            | 'OPEN'
data ActualDesignator = AD1 (NT Expression) | AD2 (NT Name) | AD3 T
instance Rule f ActualDesignator where
  get = trace "ActualDesignator" $ {-# SCC "get_ActualDesignator" #-} c
    [ AD3 <$> (txt "open" [VHDL1993]) -- order matters here
    , AD2 <$> n93 -- try a simple name first
    , AD1 <$> n93
    -- [ AD3 <$> txt "open" [VHDL1993] -- order matters here
    -- , AD2 <$> (n93 :: f (NT Name)) -- try a simple name first
    -- , AD1 <$> (n93 :: f (NT Expression))
    ]

-- actual_parameter_part
--          ::= association_list
newtype ActualParameterPart = APP (NT AssociationList)
instance Rule f AssociationList => Rule f ActualParameterPart where
  get = APP <$> n93

-- actual_part
--          ::= actual_designator
--            | ( name | type_mark ) '(' actual_designator ')'
data ActualPart = AP1 (NT ActualDesignator) | APName (NT Name) T (NT ActualDesignator) T | APTypeMark (NT TypeMark) T (NT ActualDesignator) T
instance (Rule f ActualDesignator, Rule f Name, Rule f TypeMark) => Rule f ActualPart where
  get = trace "ActualPart" $ {-# SCC "get_ActualPart" #-} c
    [ AP1 <$> n93
    , mkNameOrTypeMark APName
    , mkNameOrTypeMark APTypeMark
    ]

-- aggregate
--          ::= '(' element_association ( ',' element_association )* ')'
data Aggregate = MkAggregate T (NT ElementAssociation) [(T, (NT ElementAssociation))] T
instance Rule f ElementAssociation => Rule f Aggregate where
  get = do
    po <- parenOpen
    ea <- n93
    rest <- moreComma
    pc <- parenClose
    return $ MkAggregate po ea rest pc

-- allocator
--          ::= 'NEW' ( subtype_indication | qualified_expression )
data Allocator = A1 T (NT SubtypeIndication) | A2 T (NT QualifiedExpression)
instance (Rule f SubtypeIndication, Rule f QualifiedExpression) => Rule f Allocator where
  get = c
    [ A1 <$> (txt "new" [VHDL1993]) <*> n93
    , A2 <$> (txt "new" [VHDL1993]) <*> n93
    ]

-- association_element
--          ::= ( formal_part '=>' )? actual_part
data AssociationElement = AE (Maybe (NT FormalPart, T)) (NT ActualPart)
instance (Rule f FormalPart, Rule f ActualPart) => Rule f AssociationElement where
  get = do
    fp <- o $ do
      f <- n93
      a <- txt "=>" [VHDL1993]
      return (f, a)
    ap <- n93
    return $ AE fp ap

-- association_list
--          ::= association_element ( ',' association_element )*
data AssociationList = AL (NT AssociationElement) [(T, NT AssociationElement)]
instance Rule f AssociationElement => Rule f AssociationList where
  get = do
    ae <- n93
    rest <- moreComma
    return $ AL ae rest

-- attribute_name
--          ::= prefix signature? "'" attribute_designator ( '(' expression ')' )?
data AttributeName = AN (NT Prefix) (Maybe (NT TypeMark)) T (Maybe (T, (NT Expression), T))
instance (Rule f Prefix, Rule f TypeMark, Rule f Expression) => Rule f AttributeName where
  get = do
    pp <- n93
    ss <- o n93
    cc <- chr '\'' [VHDL1993]
    -- ad <- n93
    ee <- o $ do
      po <- parenOpen
      e <- n93
      pc <- parenClose
      return (po, e, pc)
    return $ AN pp ss cc ee

-- choice   ::= simple_expression
--            | discrete_range
--            | simple_name
--            | 'OTHERS'
data Choice =
  CSmimpleExpression (NT SimpleExpression)
  | CDiscreteRange (NT DiscreteRange)
  -- | CSimpleName (NT SimpleName)
  | COthers T

instance (Rule f SimpleExpression, Rule f DiscreteRange) => Rule f Choice where
  get = c
    [ CSmimpleExpression <$> n93
    , CDiscreteRange     <$> n93
    -- , CSimpleName        <$> n93
    , COthers            <$> txt "others" [VHDL1993]
    ]

-- constraint
--          ::= range_constraint
--            | index_constraint
data Constraint = CRange (NT RangeConstraint) | CIndex (NT DiscreteRange)
instance (Rule f RangeConstraint, Rule f DiscreteRange) => Rule f Constraint where
  get = c
    [ CRange <$> n93
    , CIndex <$> n93
    ]

-- discrete_range
--          ::= subtype_indication
--            | range
data DiscreteRange = DRSubtypeIndication (NT SubtypeIndication) | DRRange (NT Range)
instance (Rule f SubtypeIndication, Rule f Range) => Rule f DiscreteRange where
  get = c
    [ DRSubtypeIndication <$> n93
    , DRRange <$> n93
    ]

-- element_association
--          ::= ( choices '=>' )? expression
data ElementAssociation = EA (Maybe (NT Choice, T)) (NT Expression)
instance (Rule f Choice, Rule f Expression) => Rule f ElementAssociation where
  get = do
    c <- o $ do
      c <- n93
      a <- txt "=>" [VHDL1993]
      return (c, a)
    e <- n93
    return $ EA c e

-- expression
--          ::= relation ( ( 'AND' relation )* | ( 'OR' relation )* | ( 'XOR' relation )* | ( 'NAND' | 'NOR' ) relation | ( 'XNOR' relation )* )
data Expression =
  And (NT SimpleExpression) [(T, (NT SimpleExpression))]
  | Or (NT SimpleExpression) [(T, (NT SimpleExpression))]
  | Xor (NT SimpleExpression) [(T, (NT SimpleExpression))]
  | Nand (NT SimpleExpression) (T, (NT SimpleExpression))
  | Nor (NT SimpleExpression) (T, (NT SimpleExpression))
  | Xnor (NT SimpleExpression) [(T, (NT SimpleExpression))]

instance Rule f SimpleExpression => Rule f Expression where
  get = {-# SCC "get_IndexedName" #-} c
    [ And  <$> n93 <*> emore "and"
    , Or   <$> n93 <*> emore "or"
    , Xor  <$> n93 <*> emore "xor"
    , Nand <$> n93 <*> etwo "nand"
    , Nor  <$> n93 <*> etwo "nor"
    , Xnor <$> n93 <*> emore "xnor"
    ]
    where etwo tok = do
            n1 <- txt tok [VHDL1993]
            n2 <- n93
            return (n1, n2)
          emore tok = do
            m $ do
              n2 <- txt tok [VHDL1993]
              n3 <- n93
              return (n2, n3)

-- factor   ::= ( primary '**' | 'ABS' | 'NOT' )? primary
data Factor = FPower (NT Primary) (Maybe (T, (NT Primary))) | FAbs T (NT Primary) | FNot T (NT Primary)
instance Rule f Primary => Rule f Factor where
  get = trace "Factor" $ {-# SCC "get_Factor" #-} c -- c
    [ do
      p <- n93
      rest <- o $ do
        p <- txt "**" [VHDL1993]
        p2 <- n93
        return (p, p2)
      return $ FPower p rest
    , FAbs <$> (txt "abs" [VHDL1993]) <*> n93
    , FNot <$> (txt "not" [VHDL1993]) <*> n93
    ]

-- formal_designator
--          ::= name
newtype FormalDesignator = MkFormalDesignator (NT Name)
instance Rule f Name => Rule f FormalDesignator where
  get = trace "FormalDesignator" $ {-# SCC "get_FormalDesignator" #-} (MkFormalDesignator <$> n93)

-- formal_part
--          ::= formal_designator
--            | ( name | type_mark ) '(' formal_designator ')'
data FormalPart = FP1 (NT FormalDesignator) | FPName (NT Name) T (NT FormalDesignator) T | FPTypeMark (NT TypeMark) T (NT FormalDesignator) T
instance (Rule f FormalDesignator, Rule f Name, Rule f TypeMark) => Rule f FormalPart where
  get = trace "FormalPart" $ {-# SCC "get_FormalPart" #-} c
    [ FP1 <$> n93
    , mkNameOrTypeMark FPName
    , mkNameOrTypeMark FPTypeMark
    ]

-- function_call
--          ::= name ( '(' actual_parameter_part ')' )?
data FunctionCall = FC (NT Name) P_MaybeActualParameterPart
-- redundant: Rule f ActualParameterPart
instance Rule f Name => Rule f FunctionCall where
  get = trace "FunctionCall" $ {-# SCC "get_FunctionCall" #-} do
    nn <- n93
    app <- maybeActualParameterPart
    return $ FC nn app

-- index_constraint
--          ::= '(' discrete_range ( ',' discrete_range )* ')'
data IndexConstraint = IC T (NT DiscreteRange) [(T, NT DiscreteRange)] T
instance Rule f DiscreteRange => Rule f IndexConstraint where
  get = do
    po <- parenOpen
    dr <- n93
    rest <- moreComma
    pc <- parenClose
    return $ IC po dr rest pc

-- indexed_name
--          ::= prefix '(' expression ( ',' expression )* ')'
data IndexedName = IN (NT Prefix) T (NT Expression) [(T, NT Expression)] T
instance (Rule f Prefix, Rule f Expression) => Rule f IndexedName where
  get = {-# SCC "get_IndexedName" #-} do
    pp <- n93
    po <- parenOpen
    ee <- n93
    ee2 <- moreComma
    pc <- parenClose
    return $ IN pp po ee ee2 pc

-- literal  ::= numeric_literal
--            | enumeration_literal
--            | string_literal
--            | bit_string_literal
--            | 'NULL'
data Literal =
  LNumericLiteral (NT Name)
  -- | LEnumerationLiteral (NT EnumerationLiteral)
  -- | LStringLiteral (NT StringLiteral)
  -- | LBitStringLiteral (NT BitStringLiteral)
  | LNull T

instance (Rule f Name) => Rule f Literal where
  get = c
    [ LNumericLiteral     <$> n93
    -- , LEnumerationLiteral <$> n93
    -- , LStringLiteral      <$> n93
    -- , LBitStringLiteral   <$> n93
    , LNull               <$> txt "null" [VHDL1993]
    ]

-- name     ::= simple_name
--            | operator_symbol
--            | selected_name
--            | indexed_name
--            | slice_name
--            | attribute_name
data Name = N3 (NT Prefix) | N4 (NT IndexedName) | N6 (NT AttributeName)
instance (Rule f Prefix, Rule f IndexedName, Rule f AttributeName) => Rule f Name where
  get = trace "Name" $ {-# SCC "get_Name" #-} c
    [ N3 <$> n93
    , N4 <$> n93
    -- , N5 <$> n93
    , N6 <$> n93
    ]

-- prefix   ::= name
--            | function_call
data Prefix = PrefixName (NT Name) | PrefixFunctionCall (NT FunctionCall)
instance (Rule f Name, Rule f FunctionCall) => Rule f Prefix where
  get = trace "Prefix" $ {-# SCC "get_Prefix" #-} c
    [ PrefixName <$> n93
    , PrefixFunctionCall <$> n93
    ]

-- primary  ::= name
--            | literal
--            | aggregate
--            | function_call
--            | qualified_expression
--            | type_conversion
--            | allocator
--            | '(' expression ')'
data Primary =
  PName (NT Name)
  -- | PLiteral (NT Literal)
  | PAggregate (NT Aggregate)
  | PFunctionCall (NT FunctionCall)
  | PQualifiedExpression (NT QualifiedExpression)
  | PTypeConversion (NT TypeConversion)
  | PAllocator (NT Allocator)
  | PExpression T (NT Expression) T

--get_levels: instance (Rule f Name, Rule f Aggregate, Rule f FunctionCall, Rule f QualifiedExpression, Rule f TypeConversion, Rule f Allocator, Rule f Expression) => Rule f Primary where
instance (Rule f Name, Rule f Aggregate, Rule f FunctionCall, Rule f QualifiedExpression
         , Rule f TypeConversion, Rule f Allocator, Rule f Expression) => Rule f Primary where
  get = trace "Primary" $ {-# SCC "get_Primary" #-} c
    [ PName                <$> n93
    -- , PLiteral             <$> n93
    , PAggregate           <$> n93
    , PFunctionCall        <$> n93
    , PQualifiedExpression <$> n93
    , PTypeConversion      <$> n93
    , PAllocator           <$> n93
    ,                          exp
    -- [ PName <$> (n93 :: f (NT Name))
    -- , PLiteral <$> (n93 :: f (NT Literal))
    -- , PAggregate <$> (n93 :: f (NT Aggregate))
    -- , PFunctionCall <$> (n93 :: f (NT FunctionCall))
    -- , PQualifiedExpression <$> (n93 :: f (NT QualifiedExpression))
    -- , PTypeConversion <$> (n93 :: f (NT TypeConversion))
    -- , PAllocator <$> (n93 :: f (NT Allocator))
    -- , PExpression <$> parenOpen <*> (n93 :: f (NT Expression)) <*> parenClose
    -- , exp
    ]
    where exp = do
            po <- parenOpen
            ee  <- n93
            pc <- parenClose
            return $ PExpression po ee pc

-- qualified_expression
--          ::= type_mark "'" ( '(' expression ')' | aggregate )
data QualifiedExpression = QEExpression (NT TypeMark) T T (NT Expression) T | EQAggregate (NT TypeMark) T
instance (Rule f TypeMark, Rule f Expression) => Rule f QualifiedExpression where
  get = c [qexp, qagg]
    where qexp = do
            tm <- n93
            q  <- chr '\'' [VHDL1993]
            po <- parenOpen
            ee  <- n93
            pc <- parenClose
            return $ QEExpression tm q po ee pc
          qagg = do
            tm <- n93
            q  <- chr '\'' [VHDL1993]
            -- a  <- n93
            return $ EQAggregate tm q

-- range    ::= attribute_name
--            | simple_expression direction simple_expression
data Range = R1 (NT AttributeName) | R2 (NT SimpleExpression) (NT SimpleExpression)
instance (Rule f AttributeName, Rule f SimpleExpression) => Rule f Range where
  get = c
    [ R1 <$> n93
    , R2 <$> n93<*> n93
    ]

-- range_constraint
--          ::= 'range' range
data RangeConstraint = RC T (NT Range)
instance Rule f Range => Rule f RangeConstraint where
  get = do
    r1 <- txt "range" [VHDL1993]
    r2 <- n93
    return $ RC r1 r2

-- relation
--          ::= shift_expression ( relational_operator shift_expression )?
data Relation = R (NT SimpleExpression) (Maybe ((NT SimpleExpression)))
instance (Rule f SimpleExpression) => Rule f Relation where
  get = do
    se <- n93
    rest <- o $ do
      -- ro <- n93
      se <- n93
      return se
    return $ R se rest

-- shift_expression
--          ::= simple_expression ( shift_operator simple_expression )?
data ShiftExpression = ShiftE (NT SimpleExpression) (Maybe ((NT SimpleExpression)))
instance (Rule f SimpleExpression) => Rule f ShiftExpression where
  get = do
    se <- n93
    rest <- o $ do
      -- so <- n93
      se <- n93
      return se
    return $ ShiftE se rest

-- simple_expression
--          ::= sign? term ( adding_operator term )*
data SimpleExpression = SimpleE (NT Primary) [(NT Primary)]
-- data SimpleExpression = SimpleE T
instance (Rule f Primary) => Rule f SimpleExpression where
  -- get = SimpleE <$> txt "bla" [VHDL1993]
  get = do
    -- ss <- o n93
    tt <- n93
    rest <- m $ do
      -- ao <- n93
      tt2 <- n93
      return tt2
    return $ SimpleE tt rest

-- slice_name
--          ::= prefix '(' discrete_range ')'
data SliceName = SliceNPrefix (NT DiscreteRange)
instance Rule f DiscreteRange => Rule f SliceName where
  get = SliceNPrefix <$> n93

-- subtype_indication
--          ::= name? type_mark constraint?
data SubtypeIndication = SI (Maybe (NT Name)) (NT TypeMark) (Maybe (NT Constraint))
instance (Rule f Name, Rule f TypeMark, Rule f Constraint) => Rule f SubtypeIndication where
  get = trace "SubtypeIndication" $ {-# SCC "get_SubtypeIndication" #-} do
    nn <- o n93
    tm <- n93
    cc <- o n93
    return $ SI nn tm cc

-- type_conversion
--          ::= type_mark '(' expression ')'
data TypeConversion = MkTypeConversion (NT TypeMark) T (NT Expression) T
instance (Rule f TypeMark, Rule f Expression) => Rule f TypeConversion where
  get = do
    tm <- n93
    po <- parenOpen
    e  <- n93
    pc <- parenClose
    return $ MkTypeConversion tm po e pc

-- type_mark
--          ::= type_name | subtype_name
data TypeMark = TM1 (NT Name) | TM2 (NT Name)
instance Rule f Name => Rule f TypeMark where
  get = trace "TypeMark" $ {-# SCC "get_TypeMark" #-} c
    [ TM1 <$> n93
    , TM2 <$> n93
    ]