{-# LANGUAGE OverloadedStrings #-} module BNFC.Backend.Haskell.Template 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.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) haskellTemplate :: LBNF -> State HaskellBackendState Result haskellTemplate lbnf = do st <- get let cfName = takeBaseName $ optInput $ globalOpt st rules = filterRules $ astRules st tokensNames = fst <$> tokens st inDirectory = inDir $ haskellOpts st nSpace = nameSpace $ haskellOpts st funct = functor $ haskellOpts st template = cf2template rules tokensNames cfName inDirectory nSpace funct return [(mkFilePath inDirectory nSpace cfName "Skel" "hs", template)] where filterRules :: [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> [(Type, [(Label, ([Type], (Integer, ARHS)))])] filterRules rules = filter (\(_,l) -> not (null l)) ((\(f,s) -> (f, filterLabelsAST fNames s)) <$> rules) -- Functions names. fNames :: [String] fNames = toList <$> Map.keys (_lbnfFunctions lbnf) cf2template :: [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> [CatName] -> String -> Bool -> Maybe String -> Bool -> String cf2template astRules tokens cfName inDir nameSpace functor = docToString defaultLayoutOptions $ cf2doc astRules tokens cfName inDir nameSpace functor cf2doc :: [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> [CatName] -> String -> Bool -> Maybe String -> Bool -> Doc () cf2doc astRules tokens cfName inDir nameSpace functor = (vsep . intersperse emptyDoc) $ prologue modName absName emptyTree hasData : toBePrinted where hasData = not $ null astRules hasTokens = not $ null tokens emptyTree = not (hasData || hasTokens) datas = if null astRules then Nothing else Just $ printDatas absName functor astRules toks = if null tokens then Nothing else Just $ printTokens absName tokens toBePrinted = catMaybes [ toks, datas] modName :: ModuleName modName = mkModule inDir nameSpace cfName "Skel" absName :: ModuleName absName = mkModule inDir nameSpace cfName "Abs" prologue :: ModuleName -> ModuleName -> Bool -> Bool -> Doc () prologue modName absName emptyTree hasData = vsep $ [ "-- File generated by the BNF Converter." , emptyDoc , "-- Templates for pattern matching on abstract syntax" , emptyDoc ] ++ Utils.when emptyTree [ "{-# LANGUAGE EmptyCase #-}", emptyDoc ] ++ [ "{-# OPTIONS_GHC -fno-warn-unused-matches #-}" , emptyDoc , "module" <+> fromString modName <+> "where" , emptyDoc , "import Prelude (($), Either(..), String, (++), Show, show)" , emptyDoc ] ++ Utils.when hasData [ "import qualified" <+> fromString absName , emptyDoc ] ++ [ "type Err = Either String" , "type Result = Err String" , emptyDoc , "failure :: Show a => a -> Result" , "failure x = Left $ \"Undefined case: \" ++ show x" ] printTokens :: ModuleName -> [CatName] -> Doc () printTokens absName = vsep . intersperse emptyDoc . fmap (printToken absName) printToken :: ModuleName -> CatName -> Doc () printToken absName catName = vsep [ "trans" <> tokenName <+> "::" <+> fromString absName <> dot <> tokenName <+> "-> Result" , "trans" <> tokenName <+> "x = case x of" , indent 2 $ fromString absName <> dot <> tokenName <+> "string" <+> "-> failure x" ] where tokenName :: Doc () tokenName = (fromString . toList) catName printDatas :: ModuleName -> Bool -> [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> Doc () printDatas absName functor = vsep . intersperse emptyDoc . fmap (uncurry (printData absName functor)) printData :: ModuleName -> Bool -> Type -> [(Label, ([Type], (Integer, ARHS)))] -> Doc () printData absName functor t labelsRhs = vsep [ "trans" <> tName <+> "::" <+> if functor then "Show a =>" <+> fromString absName <> dot <> tName <> "' a" <+> "-> Result" else fromString absName <> dot <> tName <+> "-> Result" , "trans" <> tName <+> "x = case x of" , indent 2 $ vsep (printCase absName functor <$> labelsArhss) ] where tName :: Doc () tName = fromString $ printTypeName t labelsArhss :: [(Label, ARHS)] labelsArhss = (\(l,(_,tup)) -> (l, snd tup)) <$> labelsRhs printCase :: ModuleName -> Bool -> (Label, ARHS) -> Doc () printCase absName functor (l, arhs) = if functor then hsep [ fromString absName <> dot <> fromString (printLabelName l) <+> "_" <+> if null args then "-> failure x" else hsep args <+> "-> failure x" ] else hsep [ fromString absName <> dot <> fromString (printLabelName l) <+> if null args then "-> failure x" else hsep args <+> "-> failure x" ] where args :: [Doc ()] args = printArgs arhs