{-
    BNF Converter: GADT Abstract syntax Generator
    Copyright (C) 2004-2005  Author:  Markus Forsberg, Björn Bringert

-}

{-# LANGUAGE PatternGuards #-}

module BNFC.Backend.HaskellGADT.CFtoAbstractGADT (cf2Abstract) where

import qualified Data.List as List

import BNFC.CF
import BNFC.Backend.HaskellGADT.HaskellGADTCommon
import BNFC.Backend.Haskell.Utils
import BNFC.Backend.Haskell.CFtoAbstract (definedRules)
import BNFC.Options
import BNFC.Utils ((+++), when)


cf2Abstract :: TokenText -> String -> CF -> String -> String
cf2Abstract :: TokenText -> String -> CF -> String -> String
cf2Abstract TokenText
tokenText String
name CF
cf String
composOpMod = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$
  [ [ String
"-- For GHC version 7.10 or higher"
    , String
""
    , String
"{-# LANGUAGE GADTs, KindSignatures, DataKinds #-}"
    ]
  , [ String
"{-# LANGUAGE EmptyCase #-}" | Bool
emptyTree ]
  , [ String
"{-# LANGUAGE LambdaCase #-}"
    , String
""
    , String
"{-# OPTIONS_GHC -fno-warn-unused-binds #-}"
      -- unused-local-binds would be sufficient, but parses only from GHC 8.0
    , String
"{-# OPTIONS_GHC -fno-warn-unused-imports #-}"
    , String
"{-# OPTIONS_GHC -fno-warn-unused-matches #-}"
    , String
"{-# 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
    , String
"{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}"
    , String
""
    , String
"module" String -> String -> String
+++ String
name String -> String -> String
+++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
", " [String]
exports String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" String -> String -> String
+++ String
"where"
    , String
""
    , String
"import Prelude (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeImports String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", (.), (>), (&&), (==))"
    , String
"import qualified Prelude as P"
    -- , "import qualified Data.Kind as K (Type)"
    ]
  , TokenText -> [String]
tokenTextImport TokenText
tokenText
  , [ String
""
    , String
"import " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
composOpMod
    , String
""
    ]
  , CF -> [String]
prDummyTypes CF
cf
  , [String
""]
  , TokenText -> CF -> [String]
prTreeType TokenText
tokenText CF
cf
  , [String
""]
  , CF -> [String]
prCompos CF
cf
  , [String
""]
  , CF -> [String]
prShow CF
cf
  , [String
""]
  , CF -> [String]
prEq CF
cf
  , [String
""]
  , CF -> [String]
prOrd CF
cf
  , [String
""]
  , (Doc -> String) -> [Doc] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") (String -> String) -> (Doc -> String) -> Doc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
forall a. Show a => a -> String
show) ([Doc] -> [String]) -> [Doc] -> [String]
forall a b. (a -> b) -> a -> b
$ Bool -> CF -> [Doc]
definedRules Bool
False CF
cf
  ]
  where
    emptyTree :: Bool
emptyTree = [Constructor] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CF -> [Constructor]
cf2cons CF
cf)
    exports :: [String]
exports = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$
      [ [ if Bool
emptyTree then String
"Tree" else String
"Tree(..)" ]
      , CF -> [String]
getTreeCats CF
cf
      , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall f. IsFun f => f -> String
mkDefName ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ CF -> [String]
getDefinitions CF
cf
      , [ String
"johnMajorEq"
        , String
"module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
composOpMod
        ]
      ]
    typeImports :: String
typeImports = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ String
"Char", String
"Double" ]
      , [ String
"Int" | CF -> Bool
forall g. CFG g -> Bool
hasPositionTokens CF
cf ]
      , [ String
"Integer", String
"String" ]
      ]

getTreeCats :: CF -> [String]
getTreeCats :: CF -> [String]
getTreeCats CF
cf = [String] -> [String]
forall a. Eq a => [a] -> [a]
List.nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> String
catToStr ([Cat] -> [String]) -> [Cat] -> [String]
forall a b. (a -> b) -> a -> b
$ (Cat -> Bool) -> [Cat] -> [Cat]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Cat -> Bool) -> Cat -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Bool
isList) ([Cat] -> [Cat]) -> [Cat] -> [Cat]
forall a b. (a -> b) -> a -> b
$ (Constructor -> Cat) -> [Constructor] -> [Cat]
forall a b. (a -> b) -> [a] -> [b]
map Constructor -> Cat
consCat ([Constructor] -> [Cat]) -> [Constructor] -> [Cat]
forall a b. (a -> b) -> a -> b
$ CF -> [Constructor]
cf2cons CF
cf

getDefinitions :: CF -> [String]
getDefinitions :: CF -> [String]
getDefinitions = (Define -> String) -> [Define] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (RFun -> String
forall f. IsFun f => f -> String
funName (RFun -> String) -> (Define -> RFun) -> Define -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Define -> RFun
defName) ([Define] -> [String]) -> (CF -> [Define]) -> CF -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> [Define]
forall f. CFG f -> [Define]
definitions

prDummyTypes :: CF -> [String]
prDummyTypes :: CF -> [String]
prDummyTypes CF
cf = String
prDummyData String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
prDummyType [String]
cats
  where
  cats :: [String]
cats = CF -> [String]
getTreeCats CF
cf
  prDummyData :: String
prDummyData
    | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
cats = String
"data Tag"
    | Bool
otherwise = String
"data Tag =" String -> String -> String
+++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
" | " ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
mkRealType_ [String]
cats)
  prDummyType :: String -> String
prDummyType String
cat = String
"type" String -> String -> String
+++ String
cat String -> String -> String
+++ String
"= Tree" String -> String -> String
+++ String -> String
mkRealType String
cat

-- | Use in occurrences of promoted constructors.
--
-- Promoted constructors should be preceded by a prime,
-- otherwise we get GHC warning @unticked-promoted-constructors@.
mkRealType :: String -> String
mkRealType :: String -> String
mkRealType String
cat = String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
mkRealType_ String
cat

-- | Use in @data@ definition (for the sake of GHC <= 8.6).
mkRealType_ :: String -> String
mkRealType_ :: String -> String
mkRealType_ String
cat = String
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_"


prTreeType :: TokenText -> CF -> [String]
prTreeType :: TokenText -> CF -> [String]
prTreeType TokenText
tokenText CF
cf =
  String
"data Tree (a :: Tag) where" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Constructor -> String) -> [Constructor] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (Constructor -> String) -> Constructor -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constructor -> String
prTreeCons) (CF -> [Constructor]
cf2cons CF
cf)
  where
  prTreeCons :: Constructor -> String
prTreeCons Constructor
c
      | TokenCat String
tok <- Cat
cat, CF -> String -> Bool
forall f. CFG f -> String -> Bool
isPositionCat CF
cf String
tok =
          String
fun String -> String -> String
+++ String
":: ((Int,Int),"String -> String -> String
forall a. [a] -> [a] -> [a]
++ TokenText -> String
tokenTextType TokenText
tokenText String -> String -> String
forall a. [a] -> [a] -> [a]
++String
") -> Tree" String -> String -> String
+++ String -> String
mkRealType String
tok
      | Bool
otherwise =
          String
fun String -> String -> String
+++ String
"::" String -> String -> String
+++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Cat -> String
catToStr Cat
c String -> String -> String
+++ String
"-> " | (Cat
c,String
_) <- Constructor -> [(Cat, String)]
consVars Constructor
c] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Tree" String -> String -> String
+++ String -> String
mkRealType (Cat -> String
catToStr Cat
cat)
    where
    (Cat
cat,String
fun) = (Constructor -> Cat
consCat Constructor
c, Constructor -> String
consFun Constructor
c)

prCompos :: CF -> [String]
prCompos :: CF -> [String]
prCompos CF
cf =
    [String
"instance Compos Tree where",
     String
"  compos r a f = \\case"]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"      "String -> String -> String
forall a. [a] -> [a] -> [a]
++) ((Constructor -> [String]) -> [Constructor] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Constructor -> [String]
prComposCons [Constructor]
cs
                         [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"t -> r t" | Bool -> Bool
not ((Constructor -> Bool) -> [Constructor] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Constructor -> Bool
isRecursive [Constructor]
cs)])
  where
    cs :: [Constructor]
cs = CF -> [Constructor]
cf2cons CF
cf
    prComposCons :: Constructor -> [String]
prComposCons Constructor
c
        | Constructor -> Bool
isRecursive Constructor
c = [Constructor -> String
consFun Constructor
c String -> String -> String
+++ [String] -> String
unwords (((Cat, String) -> String) -> [(Cat, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Cat, String) -> String
forall a b. (a, b) -> b
snd (Constructor -> [(Cat, String)]
consVars Constructor
c)) String -> String -> String
+++ String
"->" String -> String -> String
+++ Constructor -> String
rhs Constructor
c]
        | Bool
otherwise = []
    isRecursive :: Constructor -> Bool
isRecursive Constructor
c = (Cat -> Bool) -> [Cat] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CF -> Cat -> Bool
isTreeType CF
cf) (((Cat, String) -> Cat) -> [(Cat, String)] -> [Cat]
forall a b. (a -> b) -> [a] -> [b]
map (Cat, String) -> Cat
forall a b. (a, b) -> a
fst (Constructor -> [(Cat, String)]
consVars Constructor
c))
    rhs :: Constructor -> String
rhs Constructor
c = String
"r" String -> String -> String
+++ Constructor -> String
consFun Constructor
c String -> String -> String
+++ [String] -> String
unwords (((Cat, String) -> String) -> [(Cat, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Cat, String) -> String
prRec (Constructor -> [(Cat, String)]
consVars Constructor
c))
      where prRec :: (Cat, String) -> String
prRec (Cat
cat,String
var) | Bool -> Bool
not (CF -> Cat -> Bool
isTreeType CF
cf Cat
cat) = String
"`a`" String -> String -> String
+++ String
"r" String -> String -> String
+++ String
var
                            | Cat -> Bool
isList Cat
cat = String
"`a` P.foldr (\\ x z -> r (:) `a` f x `a` z) (r [])" String -> String -> String
+++ String
var
                            | Bool
otherwise = String
"`a`" String -> String -> String
+++ String
"f" String -> String -> String
+++ String
var

prShow :: CF -> [String]
prShow :: CF -> [String]
prShow CF
cf = [String
"instance P.Show (Tree c) where",
              String
"  showsPrec n = \\case"]
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Constructor -> String) -> [Constructor] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"    "String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (Constructor -> String) -> Constructor -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Constructor -> String
prShowCons) [Constructor]
cs
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"    where",
                  String
"    opar = if n > 0 then P.showChar '(' else P.id",
                  String
"    cpar = if n > 0 then P.showChar ')' else P.id"]
  where
    cs :: [Constructor]
cs = CF -> [Constructor]
cf2cons CF
cf
    prShowCons :: Constructor -> String
prShowCons Constructor
c | [(Cat, String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Cat, String)]
vars = String
fun String -> String -> String
+++ String
"->" String -> String -> String
+++ String
"P.showString" String -> String -> String
+++ String -> String
forall a. Show a => a -> String
show String
fun
                 | Bool
otherwise = String
fun String -> String -> String
+++ [String] -> String
unwords (((Cat, String) -> String) -> [(Cat, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Cat, String) -> String
forall a b. (a, b) -> b
snd [(Cat, String)]
vars) String -> String -> String
+++ String
"->"
                                   String -> String -> String
+++ String
"opar . P.showString" String -> String -> String
+++ String -> String
forall a. Show a => a -> String
show String
fun
                                   String -> String -> String
+++ [String] -> String
unwords [String
". P.showChar ' ' . P.showsPrec 1 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x | (Cat
_,String
x) <- [(Cat, String)]
vars]
                                   String -> String -> String
+++ String
". cpar"
      where (String
fun, [(Cat, String)]
vars) = (Constructor -> String
consFun Constructor
c, Constructor -> [(Cat, String)]
consVars Constructor
c)

prEq :: CF -> [String]
prEq :: CF -> [String]
prEq CF
cf = [String
"instance P.Eq (Tree c) where (==) = johnMajorEq",
           String
"",
           String
"johnMajorEq :: Tree a -> Tree b -> P.Bool"]
           [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Constructor -> String) -> [Constructor] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Constructor -> String
prEqCons (CF -> [Constructor]
cf2cons CF
cf)
           [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"johnMajorEq _ _ = P.False"]
  where prEqCons :: Constructor -> String
prEqCons Constructor
c
            | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
vars = String
"johnMajorEq" String -> String -> String
+++ String
fun String -> String -> String
+++ String
fun String -> String -> String
+++ String
"=" String -> String -> String
+++ String
"P.True"
            | Bool
otherwise = String
"johnMajorEq" String -> String -> String
+++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fun String -> String -> String
+++ [String] -> String
unwords [String]
vars String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
                          String -> String -> String
+++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fun String -> String -> String
+++ [String] -> String
unwords [String]
vars' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" String -> String -> String
+++ String
"="
                          String -> String -> String
+++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
" && " ((String -> String -> String) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
x String
y -> String
x String -> String -> String
+++ String
"==" String -> String -> String
+++ String
y) [String]
vars [String]
vars')
          where (String
fun, [String]
vars) = (Constructor -> String
consFun Constructor
c, ((Cat, String) -> String) -> [(Cat, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Cat, String) -> String
forall a b. (a, b) -> b
snd (Constructor -> [(Cat, String)]
consVars Constructor
c))
                vars' :: [String]
vars' = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_") [String]
vars

prOrd :: CF -> [String]
prOrd :: CF -> [String]
prOrd CF
cf = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ String
"instance P.Ord (Tree c) where"
    , String
"  compare x y = P.compare (index x) (index y) `P.mappend` compareSame x y"
    ]
  , [ String
"", String
"index :: Tree c -> P.Int" ]
  , (Constructor -> Int -> String)
-> [Constructor] -> [Int] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Constructor -> Int -> String
forall {a}. Show a => Constructor -> a -> String
mkIndex [Constructor]
cs [Int
0::Int ..]
  , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
when ([Constructor] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Constructor]
cs) [ String
"index = P.undefined" ]
  , [ String
"", String
"compareSame :: Tree c -> Tree c -> P.Ordering" ]
  , (Constructor -> String) -> [Constructor] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Constructor -> String
mkCompareSame [Constructor]
cs
  -- Case sometimes redundant, so we need to suppress the warning.
  , [ String
"compareSame _ _ = P.error \"BNFC error: compareSame\"" ]
  ]
  where cs :: [Constructor]
cs = CF -> [Constructor]
cf2cons CF
cf
        mkCompareSame :: Constructor -> String
mkCompareSame Constructor
c
            | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
vars = String
"compareSame" String -> String -> String
+++ String
fun String -> String -> String
+++ String
fun String -> String -> String
+++ String
"=" String -> String -> String
+++ String
"P.EQ"
            | Bool
otherwise = String
"compareSame" String -> String -> String
+++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fun String -> String -> String
+++ [String] -> String
unwords [String]
vars String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
                          String -> String -> String
+++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fun String -> String -> String
+++ [String] -> String
unwords [String]
vars' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" String -> String -> String
+++ String
"="
                          String -> String -> String
+++ (String -> String -> String) -> [String] -> String
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\String
x String
y -> String
"P.mappend (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++String
") ("String -> String -> String
forall a. [a] -> [a] -> [a]
++String
yString -> String -> String
forall a. [a] -> [a] -> [a]
++String
")") [String]
cc
            where (String
fun, [String]
vars) = (Constructor -> String
consFun Constructor
c, ((Cat, String) -> String) -> [(Cat, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Cat, String) -> String
forall a b. (a, b) -> b
snd (Constructor -> [(Cat, String)]
consVars Constructor
c))
                  vars' :: [String]
vars' = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"_") [String]
vars
                  cc :: [String]
cc = (String -> String -> String) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
x String
y -> String
"P.compare"String -> String -> String
+++String
xString -> String -> String
+++String
y) [String]
vars [String]
vars'
        mkIndex :: Constructor -> a -> String
mkIndex Constructor
c a
i = String
"index" String -> String -> String
+++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Constructor -> String
consFun Constructor
c
                       String -> String -> String
+++ [String] -> String
unwords (Int -> String -> [String]
forall a. Int -> a -> [a]
replicate ([(Cat, String)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Constructor -> [(Cat, String)]
consVars Constructor
c)) String
"_") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
                       String -> String -> String
+++ String
"=" String -> String -> String
+++ a -> String
forall a. Show a => a -> String
show a
i