{-# LANGUAGE OverloadedStrings #-} module BNFC.Backend.Haskell.GADT.AbstractSyntax where import BNFC.CF import BNFC.Backend.CommonInterface.Backend import BNFC.Backend.Common.Utils as Utils import BNFC.Backend.Haskell.AbstractSyntax (printFunctions) import BNFC.Backend.Haskell.Options import BNFC.Backend.Haskell.State import BNFC.Backend.Haskell.GADT.ComposOp import BNFC.Backend.Haskell.GADT.Template import BNFC.Backend.Haskell.GADT.Utils 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) haskellAbstractSyntaxGADT :: LBNF -> State HaskellBackendState Result haskellAbstractSyntaxGADT lbnf = do st <- get template <- haskellGADTTemplate lbnf let cfName = takeBaseName $ optInput $ globalOpt st rules = filterRules $ astRules st funs = functions st toks = tokens st tt = tokenText $ haskellOpts st inDirectory = inDir $ haskellOpts st nSpace = nameSpace $ haskellOpts st absSyntax = cf2abs lbnf cfName inDirectory nSpace rules funs toks tt composOpPath = mkFilePath inDirectory nSpace cfName "ComposOp" "hs" composOpMod = composOp (mkModule inDirectory nSpace cfName "ComposOp") composOpFile = [(composOpPath, composOpMod)] return $ [(mkFilePath inDirectory nSpace cfName "Abs" "hs", absSyntax)] ++ template ++ composOpFile 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) cf2abs :: LBNF -> String -> Bool -> Maybe String -> [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> [(LabelName,Function)] -> [(CatName,TokenDef)] -> TokenText -> String cf2abs lbnf cfName inDir nameSpace astRules functions toks tokenText = docToString defaultLayoutOptions $ cf2doc lbnf cfName inDir nameSpace astRules functions toks tokenText cf2doc :: LBNF -> String -> Bool -> Maybe String -> [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> [(LabelName,Function)] -> [(CatName,TokenDef)] -> TokenText -> Doc () cf2doc lbnf cfName inDir nameSpace astRules functions tokens tokenText = (vsep . intersperse emptyDoc) $ prologue absModule composOpModule hasPosTokens names tokenText emptyTree : toBePrinted where composOpModule = mkModule inDir nameSpace cfName "ComposOp" absModule = mkModule inDir nameSpace cfName "Abs" dataNames = printTypeName . fst <$> astRules tokenNames = toList . fst <$> tokens funNames = toList . fst <$> functions names = dataNames ++ tokenNames ++ funNames hasData = not $ null astRules hasFunctions = not $ null functions hasTokens = not $ null tokens hasPosTokens = any isPositionToken (_lbnfTokenDefs lbnf) emptyTree = not (hasData || hasTokens || hasFunctions) usedBuiltins = map (toList . printBuiltinCat) (Map.keys $ _lbnfASTBuiltins lbnf) labelsArhss :: [(Label, ARHS)] labelsArhss = (\(l,(_,tup)) -> (l, snd tup)) <$> concatMap snd astRules labelsTypes :: [(Label, [Type])] labelsTypes = map (\(l,(ts,_)) -> (l,ts)) (concatMap snd astRules) dataAndInstances = if not (null astRules) || not (null tokens) then Just $ printData names else Nothing tree = if not (null astRules) || not (null tokens) then Just $ printTree usedBuiltins tokenText astRules tokens else Nothing compos = if not (null astRules) || not (null tokens) then Just $ composInstances labelsArhss else Nothing shws = if not (null astRules) || not (null tokens) then Just $ showInstances labelsArhss tokens else Nothing eqInst = Just eqInstance ordInst = Just ordInstance index = if not (null astRules) || not (null tokens) then Just $ indexes labelsTypes tokenNames else Nothing jmEq = if not (null astRules) || not (null tokens) then Just $ johnMajorEq labelsArhss tokens else Nothing cmpSame = if not (null astRules) || not (null tokens) then Just $ compareSame labelsArhss tokens else Nothing funs = if null functions then Nothing else Just $ printFunctions False functions toBePrinted = catMaybes [dataAndInstances, tree, compos, shws, eqInst, ordInst, index, jmEq, cmpSame, funs] prologue :: ModuleName -> ModuleName -> Bool -> [String] -> TokenText -> Bool -> Doc () prologue absName compOpName hasPosTokens toExport tokenText emptyTree = vsep [ "-- For GHC version 7.10 or higher" , emptyDoc , pragmas emptyTree , emptyDoc , "module" <+> fromString absName <+> exports <+> "where" , emptyDoc , imports compOpName hasPosTokens tokenText ] where exports :: Doc () exports = tupled $ --parens $ hsep $ intersperse comma $ [ if emptyTree then "Tree" else "Tree(..)" ] ++ (fromString <$> toExport) ++ [ "johnMajorEq", "module" <+> fromString compOpName ] pragmas :: Bool -> Doc () pragmas emptyTree = vsep $ [ "{-# LANGUAGE GADTs, KindSignatures, DataKinds #-}" ] ++ Utils.when emptyTree [ "{-# LANGUAGE EmptyCase #-}" ] ++ ["{-# LANGUAGE LambdaCase #-}"] ++ [ emptyDoc , "{-# OPTIONS_GHC -fno-warn-unused-binds #-}" -- unused-local-binds would be sufficient, but parses only from GHC 8.0 , "{-# OPTIONS_GHC -fno-warn-unused-imports #-}" , "{-# OPTIONS_GHC -fno-warn-unused-matches #-}" , "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}" -- defects of coverage checker, e.g. in 8.2.2, may lead to warning -- about exceeded iterations for pattern match checker , "{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}" ] imports :: ModuleName -> Bool -> TokenText -> Doc () imports compOpName hasPosTokens tokenText = vsep $ [ "import Prelude ((.), (>), (&&), (==))" , if hasPosTokens then "import Prelude" <+> tupled (fromString <$> ("Int" : [ "(.)", "(>)", "(&&)", "(==)"])) else "import Prelude" <+> tupled (fromString <$> [ "(.)", "(>)", "(&&)", "(==)"]) , "import qualified Prelude as P" , emptyDoc , "import" <+> fromString compOpName ] ++ Utils.when (tokenText == TextToken) [ emptyDoc , tokenTextImport tokenText ] -- Dummy types. printData :: [String] -> Doc () printData names = vsep [ "data Tag =" <+> (hsep . intersperse pipe) (fromString . (++ "_") <$> names) , vsep $ mkType <$> names ] where mkType :: String -> Doc () mkType name = "type" <+> fromString name <+> "=" <+> "Tree" <+> fromString ("'" ++ name ++ "_") -- Print Tree data type. printTree :: [String] -> TokenText -> [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> [(CatName,TokenDef)] -> Doc () printTree usedBuiltins tokenText astRules tokens = vsep [ "data Tree (a :: Tag) where" , indent 2 $ vsep [ vsep $ catField <$> astRules , vsep $ tokenField <$> tokens ] ] where catField :: (Type, [(Label, ([Type], (Integer, ARHS)))]) -> Doc () catField (t, ls) = vsep $ printCase <$> ls where printCase :: (Label, ([Type], (Integer, ARHS))) -> Doc () printCase (l, (ts, _)) = fromString (printLabelName l) <+> "::" <+> if null ts then "Tree" <+> fromString ("'" ++ printTypeName t ++ "_") else (hsep . intersperse "->") (printType <$> ts) <+> "-> Tree" <+> fromString ("'" ++ printTypeName t ++ "_") printType :: Type -> Doc () printType ty = applyWhen (isListType ty) brackets $ applyWhen (isTypeBuiltin ty) addQualified $ fromString $ printTypeName ty applyWhen :: Bool -> (a -> a) -> a -> a applyWhen True f x = f x applyWhen False _ x = x addQualified :: Doc () -> Doc () addQualified name = "P." <> name isTypeBuiltin :: Type -> Bool isTypeBuiltin ty = printTypeName ty `elem` usedBuiltins tokenField :: (CatName,TokenDef) -> Doc () tokenField (cName, TokenDef PositionToken _ _) = (fromString . toList) cName <+> ":: ((Int,Int)," <> "P." <> tokenTextType tokenText <> ") ->" <+> "Tree" <+> (fromString . toList) ("'" ++ toList cName ++ "_") tokenField (cName, TokenDef NoPositionToken _ _) = (fromString . toList) cName <+> "::" <> "P." <> tokenTextType tokenText <> " ->" <+> "Tree" <+> (fromString . toList) ("'" ++ toList cName ++ "_") -- Compos instances for a category. composInstances :: [(Label, ARHS)] -> Doc () composInstances labelsArhss = vsep $ [ "instance Compos Tree where" , indent 2 "compos r a f = \\case" , indent 4 $ vsep $ treeCase <$> filter isTreeType labelsArhss ] ++ Utils.when (not $ all isTreeType labelsArhss) [ indent 4 "t -> r t" ] where treeCase :: (Label, ARHS) -> Doc () treeCase (l, arhs) = label <+> hsep args <+> "->" <+> "r" <+> label <+> "`a`" <+> (hsep . intersperse "`a`") (printRhs <$> zip3 args listArgs builtinArgs) where printRhs :: (Doc (), Bool, Bool) -> Doc () printRhs (arg, False, True ) = "r" <+> arg printRhs (arg, True, True ) = "r" <+> arg printRhs (arg, True, False) = "P.foldr (\\ x z -> r (:) `a` f x `a` z) (r [])" <+> arg printRhs (arg, _, _ ) = "f" <+> arg label :: Doc () label = fromString $ printLabelName l args :: [Doc ()] args = printArgs arhs -- Does an argument come from a list category. listArgs :: [Bool] listArgs = isItemListCat <$> filter isNTerminal arhs -- Does an argument come from a builtin category. builtinArgs :: [Bool] builtinArgs = isItemBuiltin <$> filter isNTerminal arhs showInstances :: [(Label, ARHS)] -> [(CatName,TokenDef)] -> Doc () showInstances labelsArhss tokens = vsep [ "instance P.Show (Tree c) where" , indent 2 $ vsep ["showsPrec n = \\case" , indent 2 $ vsep [ vsep $ tokenInstance <$> tokens , vsep $ catInstance <$> labelsArhss , "where" , "opar = if n > 0 then P.showChar '(' else P.id" , "cpar = if n > 0 then P.showChar ')' else P.id" ] ] ] where catInstance :: (Label, ARHS) -> Doc () catInstance (l, arhs) = label <+> if null args then "-> P.showString" <+> dquotes label else hsep args <+> "->" <+> rhs where rhs :: Doc () rhs = if null args then "P.showString" <+> dquotes label else "opar . P.showString" <+> dquotes label <+> dot <+> (hsep . intersperse dot) (printArg <$> args) <+> ". cpar" printArg :: Doc () -> Doc () printArg arg = "P.showChar ' ' . P.showsPrec 1" <+> arg label :: Doc () label = fromString $ printLabelName l args :: [Doc ()] args = printArgs arhs tokenInstance :: (CatName,TokenDef) -> Doc () tokenInstance (cName, _) = fromString (toList cName) <+> "str" <+> "->" <+> "opar . P.showString" <+> dquotes (fromString (toList cName)) <+> ". P.showChar ' ' . P.showsPrec 1 str . cpar" eqInstance :: Doc () eqInstance = "instance P.Eq (Tree c) where (==) = johnMajorEq" ordInstance :: Doc () ordInstance = "instance P.Ord (Tree c) where compare x y = P.compare (index x) (index y) `P.mappend` compareSame x y" johnMajorEq :: [(Label, ARHS)] -> [(CatName,TokenDef)] -> Doc () johnMajorEq labelsRhss tokens = vsep [ "johnMajorEq :: Tree a -> Tree b -> P.Bool" , vsep $ catCase <$> labelsRhss , vsep $ tokenCase <$> tokens , "johnMajorEq _ _ = P.False" ] where catCase :: (Label, ARHS) -> Doc () catCase (l,arhs) = hsep [ "johnMajorEq" , if null args then hsep [ label, label, "= P.True"] else hsep [ parens (label <+> hsep args) , parens (label <+> hsep (map (<> "_") args)) , "=" , (hsep . intersperse "&&") (eq <$> args) ] ] where eq :: Doc() -> Doc () eq arg = arg <+> "==" <+> arg <> "_" label :: Doc () label = fromString $ printLabelName l args :: [Doc ()] args = printArgs arhs tokenCase :: (CatName,TokenDef) -> Doc () tokenCase (cName, _) = hsep [ "johnMajorEq" , parens (tokenName <+> "str") , parens (tokenName <+> "str_") , "= str == str_" ] where tokenName :: Doc () tokenName = fromString $ toList cName indexes :: [(Label, [Type])] -> [String] -> Doc () indexes labelsTypes tokNames = vsep [ "index :: Tree c -> P.Int" , indexCases ] where indexCases :: Doc () indexCases = vsep $ (\(d,i) -> "index" <+> d <+> "=" <+> fromString (show i)) <$> zip ((catArg <$> labelsTypes) ++ (tokArg <$> tokNames)) [(1::Integer)..] catArg :: (Label, [Type]) -> Doc () catArg (l, ts) = parens ( fromString (printLabelName l) <+> hsep (replicate (length ts) "_") ) tokArg :: String -> Doc () tokArg cName = parens ( fromString cName <+> "_") compareSame :: [(Label, ARHS)] -> [(CatName,TokenDef)] -> Doc () compareSame labelsRhss tokens = vsep [ "compareSame :: Tree c -> Tree c -> P.Ordering" , vsep $ catCase <$> labelsRhss , vsep $ tokenCase <$> tokens , "compareSame _ _ = P.error \"BNFC error: compareSame\"" ] where catCase :: (Label, ARHS) -> Doc () catCase (l,arhs) = hsep [ "compareSame" , if null args then hsep [ label, label, "= P.EQ"] else hsep [ parens (label <+> hsep args) , parens (label <+> hsep (map (<> "_") args)) , "=" , rhs $ comp <$> args ] ] where rhs :: [Doc ()] -> Doc () rhs [] = panic "Arguments lost shouldn't be empty." rhs [a] = a rhs (a:a1:[]) = "P.mappend" <+> parens a <+> parens a1 rhs (a:a1:a2) = "P.mappend" <+> parens a <+> parens ( "P.mappend" <+> parens a1 <+> parens (rhs a2)) comp :: Doc() -> Doc () comp arg = "P.compare" <+> arg <+> arg <> "_" label :: Doc () label = fromString $ printLabelName l args :: [Doc ()] args = printArgs arhs tokenCase :: (CatName,TokenDef) -> Doc () tokenCase (c,_) = hsep [ "compareSame" , parens (tokenName <+> "str") , parens (tokenName <+> "str_") , "= P.compare str str_" ] where tokenName :: Doc () tokenName = fromString $ toList c