{-# 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 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat 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 #-}"
, String
"{-# OPTIONS_GHC -fno-warn-unused-imports #-}"
, String
"{-# OPTIONS_GHC -fno-warn-unused-matches #-}"
, String
"{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}"
, String
"{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}"
, String
""
, String
"module" String -> String -> String
+++ String
name String -> String -> String
+++ String
"(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
List.intercalate String
", " [String]
exports forall a. [a] -> [a] -> [a]
++ String
")" String -> String -> String
+++ String
"where"
, String
""
, String
"import Prelude (" forall a. [a] -> [a] -> [a]
++ String
typeImports forall a. [a] -> [a] -> [a]
++ String
", (.), (>), (&&), (==))"
, String
"import qualified Prelude as P"
]
, TokenText -> [String]
tokenTextImport TokenText
tokenText
, [ String
""
, String
"import " 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
""]
, forall a b. (a -> b) -> [a] -> [b]
map ((forall a. [a] -> [a] -> [a]
++ String
"\n") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall a b. (a -> b) -> a -> b
$ Bool -> CF -> [Doc]
definedRules Bool
False CF
cf
]
where
emptyTree :: Bool
emptyTree = forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CF -> [Constructor]
cf2cons CF
cf)
exports :: [String]
exports = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
[ [ if Bool
emptyTree then String
"Tree" else String
"Tree(..)" ]
, CF -> [String]
getTreeCats CF
cf
, forall a b. (a -> b) -> [a] -> [b]
map forall f. IsFun f => f -> String
mkDefName forall a b. (a -> b) -> a -> b
$ CF -> [String]
getDefinitions CF
cf
, [ String
"johnMajorEq"
, String
"module " forall a. [a] -> [a] -> [a]
++ String
composOpMod
]
]
typeImports :: String
typeImports = forall a. [a] -> [[a]] -> [a]
List.intercalate String
", " forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ String
"Char", String
"Double" ]
, [ String
"Int" | forall g. CFG g -> Bool
hasPositionTokens CF
cf ]
, [ String
"Integer", String
"String" ]
]
getTreeCats :: CF -> [String]
getTreeCats :: CF -> [String]
getTreeCats CF
cf = forall a. Eq a => [a] -> [a]
List.nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Cat -> String
catToStr forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Bool
isList) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Constructor -> Cat
consCat forall a b. (a -> b) -> a -> b
$ CF -> [Constructor]
cf2cons CF
cf
getDefinitions :: CF -> [String]
getDefinitions :: CF -> [String]
getDefinitions = forall a b. (a -> b) -> [a] -> [b]
map (forall f. IsFun f => f -> String
funName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Define -> RFun
defName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f. CFG f -> [Define]
definitions
prDummyTypes :: CF -> [String]
prDummyTypes :: CF -> [String]
prDummyTypes CF
cf = String
prDummyData forall a. a -> [a] -> [a]
: 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
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
cats = String
"data Tag"
| Bool
otherwise = String
"data Tag =" String -> String -> String
+++ forall a. [a] -> [[a]] -> [a]
List.intercalate 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
mkRealType :: String -> String
mkRealType :: String -> String
mkRealType String
cat = String
"'" forall a. [a] -> [a] -> [a]
++ String -> String
mkRealType_ String
cat
mkRealType_ :: String -> String
mkRealType_ :: String -> String
mkRealType_ String
cat = String
cat 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" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ((String
" " forall a. [a] -> [a] -> [a]
++) 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, forall f. CFG f -> String -> Bool
isPositionCat CF
cf String
tok =
String
fun String -> String -> String
+++ String
":: ((Int,Int),"forall a. [a] -> [a] -> [a]
++ TokenText -> String
tokenTextType TokenText
tokenText 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
+++ 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] 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"]
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (String
" "forall a. [a] -> [a] -> [a]
++) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Constructor -> [String]
prComposCons [Constructor]
cs
forall a. [a] -> [a] -> [a]
++ [String
"t -> r t" | Bool -> Bool
not (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 (forall a b. (a -> b) -> [a] -> [b]
map 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CF -> Cat -> Bool
isTreeType CF
cf) (forall a b. (a -> b) -> [a] -> [b]
map 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 (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"]
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map ((String
" "forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
.Constructor -> String
prShowCons) [Constructor]
cs
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 | 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
+++ forall a. Show a => a -> String
show String
fun
| Bool
otherwise = String
fun String -> String -> String
+++ [String] -> String
unwords (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Cat, String)]
vars) String -> String -> String
+++ String
"->"
String -> String -> String
+++ String
"opar . P.showString" String -> String -> String
+++ forall a. Show a => a -> String
show String
fun
String -> String -> String
+++ [String] -> String
unwords [String
". P.showChar ' ' . P.showsPrec 1 " 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"]
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Constructor -> String
prEqCons (CF -> [Constructor]
cf2cons CF
cf)
forall a. [a] -> [a] -> [a]
++ [String
"johnMajorEq _ _ = P.False"]
where prEqCons :: Constructor -> String
prEqCons Constructor
c
| 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
"(" forall a. [a] -> [a] -> [a]
++ String
fun String -> String -> String
+++ [String] -> String
unwords [String]
vars forall a. [a] -> [a] -> [a]
++ String
")"
String -> String -> String
+++ String
"(" forall a. [a] -> [a] -> [a]
++ String
fun String -> String -> String
+++ [String] -> String
unwords [String]
vars' forall a. [a] -> [a] -> [a]
++ String
")" String -> String -> String
+++ String
"="
String -> String -> String
+++ forall a. [a] -> [[a]] -> [a]
List.intercalate 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, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (Constructor -> [(Cat, String)]
consVars Constructor
c))
vars' :: [String]
vars' = forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> [a] -> [a]
++ String
"_") [String]
vars
prOrd :: CF -> [String]
prOrd :: CF -> [String]
prOrd CF
cf = 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" ]
, forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a}. Show a => Constructor -> a -> String
mkIndex [Constructor]
cs [Int
0::Int ..]
, forall m. Monoid m => Bool -> m -> m
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Constructor]
cs) [ String
"index = P.undefined" ]
, [ String
"", String
"compareSame :: Tree c -> Tree c -> P.Ordering" ]
, forall a b. (a -> b) -> [a] -> [b]
map Constructor -> String
mkCompareSame [Constructor]
cs
, [ String
"compareSame _ _ = P.error \"BNFC error: compareSame\"" ]
]
where cs :: [Constructor]
cs = CF -> [Constructor]
cf2cons CF
cf
mkCompareSame :: Constructor -> String
mkCompareSame Constructor
c
| 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
"(" forall a. [a] -> [a] -> [a]
++ String
fun String -> String -> String
+++ [String] -> String
unwords [String]
vars forall a. [a] -> [a] -> [a]
++ String
")"
String -> String -> String
+++ String
"(" forall a. [a] -> [a] -> [a]
++ String
fun String -> String -> String
+++ [String] -> String
unwords [String]
vars' forall a. [a] -> [a] -> [a]
++ 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 (" forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++String
") ("forall a. [a] -> [a] -> [a]
++String
yforall a. [a] -> [a] -> [a]
++String
")") [String]
cc
where (String
fun, [String]
vars) = (Constructor -> String
consFun Constructor
c, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (Constructor -> [(Cat, String)]
consVars Constructor
c))
vars' :: [String]
vars' = forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> [a] -> [a]
++String
"_") [String]
vars
cc :: [String]
cc = 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
"(" forall a. [a] -> [a] -> [a]
++ Constructor -> String
consFun Constructor
c
String -> String -> String
+++ [String] -> String
unwords (forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length (Constructor -> [(Cat, String)]
consVars Constructor
c)) String
"_") forall a. [a] -> [a] -> [a]
++ String
")"
String -> String -> String
+++ String
"=" String -> String -> String
+++ forall a. Show a => a -> String
show a
i