module BNFC.Backend.Haskell.InitState where

import BNFC.Prelude

import Control.Monad.Except

import qualified Data.Map as Map

import BNFC.CF

import BNFC.Backend.Haskell.Options
import BNFC.Backend.Haskell.State
import BNFC.Backend.Haskell.Utilities.InitState

import BNFC.Options.GlobalOptions


haskellInitState :: LBNF -> GlobalOptions -> HaskellBackendOptions -> Except String HaskellBackendState
haskellInitState :: LBNF
-> GlobalOptions
-> HaskellBackendOptions
-> Except String HaskellBackendState
haskellInitState LBNF
lbnf GlobalOptions
globalOpts HaskellBackendOptions
hsOpts = do
  LBNF -> Except String ()
hsChecks LBNF
lbnf
  HaskellBackendState -> Except String HaskellBackendState
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskellBackendState -> Except String HaskellBackendState)
-> HaskellBackendState -> Except String HaskellBackendState
forall a b. (a -> b) -> a -> b
$
    GlobalOptions
-> HaskellBackendOptions
-> [Token]
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(Cat, Map RHS RuleLabel)]
-> [(LabelName, Function)]
-> [(LabelName, TokenDef)]
-> HaskellBackendState
HaskellSt
      GlobalOptions
globalOpts
      HaskellBackendOptions
hsOpts
      (LBNF -> [Token]
getTokens LBNF
lbnf)
      (ASTRulesAP -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
processRules (LBNF -> ASTRulesAP
_lbnfASTRulesAP LBNF
lbnf))
      (ParserRules -> [(Cat, Map RHS RuleLabel)]
processParserRules (LBNF -> ParserRules
_lbnfParserRules LBNF
lbnf))
      (Functions -> [(LabelName, Function)]
processFunctions (LBNF -> Functions
_lbnfFunctions  LBNF
lbnf))
      (TokenDefs -> [(LabelName, TokenDef)]
sortTokens (LBNF -> TokenDefs
_lbnfTokenDefs LBNF
lbnf))


-- | Checks specific of the Haskell language.
hsChecks :: LBNF -> Except String ()
hsChecks :: LBNF -> Except String ()
hsChecks LBNF
lbnf = do

  Bool -> Except String () -> Except String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
usesLayoutStop (Except String () -> Except String ())
-> Except String () -> Except String ()
forall a b. (a -> b) -> a -> b
$
    -- If a grammar that uses layout has the @layout stop@ pragma,
    -- then it also need to have the @layout@ start one.
    Bool -> Except String () -> Except String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
usesLayoutStart
      (Except String () -> Except String ())
-> Except String () -> Except String ()
forall a b. (a -> b) -> a -> b
$ String -> Except String ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Except String ()) -> String -> Except String ()
forall a b. (a -> b) -> a -> b
$
        String
"ERROR: the grammar uses the layout stop pragma," String -> String -> String
forall a. [a] -> [a] -> [a]
++
        String
" but no layout start has been specified"

  Bool -> Except String () -> Except String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LBNF -> Bool
layoutsAreUsed LBNF
lbnf) (Except String () -> Except String ())
-> Except String () -> Except String ()
forall a b. (a -> b) -> a -> b
$
    -- A grammar that uses layout needs to contain symbols { } ;
    Bool -> Except String () -> Except String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        ( [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
missingLayoutSymbols )
        (Except String () -> Except String ())
-> Except String () -> Except String ()
forall a b. (a -> b) -> a -> b
$ String -> Except String ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Except String ()) -> String -> Except String ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
          String
"ERROR: the grammar uses layout, but does not mention symbols"
            String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
missingLayoutSymbols

  where

    usesLayoutStop :: Bool
usesLayoutStop  = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map Keyword Position -> Bool
forall k a. Map k a -> Bool
Map.null (LBNF -> Map Keyword Position
_lbnfLayoutStop LBNF
lbnf)

    usesLayoutStart :: Bool
usesLayoutStart = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map Keyword Position -> Bool
forall k a. Map k a -> Bool
Map.null (LBNF -> Map Keyword Position
_lbnfLayoutStart LBNF
lbnf)

    layoutSymbols :: [String]
    layoutSymbols :: [String]
layoutSymbols =
      if Map Keyword Position -> Bool
forall k a. Map k a -> Bool
Map.null (LBNF -> Map Keyword Position
_lbnfLayoutStart LBNF
lbnf) Bool -> Bool -> Bool
&& Map Keyword Position -> Bool
forall k a. Map k a -> Bool
Map.null (LBNF -> Map Keyword Position
_lbnfLayoutStop LBNF
lbnf)
      then [String
";"]
      else [String
";", String
"{", String
"}" ]

    missingLayoutSymbols :: [String]
    missingLayoutSymbols :: [String]
missingLayoutSymbols = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
symbols) [String]
layoutSymbols

    symbols :: [String]
    symbols :: [String]
symbols = LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (LabelName -> String) -> (Symbol -> LabelName) -> Symbol -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> LabelName
theSymbol (Symbol -> String) -> [Symbol] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Symbol (List1 Position) -> [Symbol]
forall k a. Map k a -> [k]
Map.keys (LBNF -> Map Symbol (List1 Position)
_lbnfSymbols LBNF
lbnf)