RuleUtils.hs revision ac34194a668399bb8ef238da77c3a09e93fb253b
43b4c41fbb07705c9df321221ab9cb9832460407Christian Maeder-- utilities for writing new rules.
63f0e65a37b95621334db9ee4ba0cd9d826f5c0fChristian Maedermodule RuleUtils (module Pretty,module RuleUtils, module DataP)where
43b4c41fbb07705c9df321221ab9cb9832460407Christian Maederimport DataP (Statement(..), Data(..), Type(..), Name, Var, Class,
5191fa24c532d1f67e7a642e9aece65efb8a0975Christian Maeder Body(..), Constructor)
5191fa24c532d1f67e7a642e9aece65efb8a0975Christian Maeder-- Rule Declarations
5191fa24c532d1f67e7a642e9aece65efb8a0975Christian Maedertype Tag = String
f4a2a20e49f41b2afa657e5e64d9e349c7faa091Christian Maedertype Rule = (Tag, Data -> Doc)
f2f9df2e17e70674f0bf426ed1763c973ee4cde0Christian Maedertype RuleDef = (Tag, Data -> Doc, String, String, Maybe String)
5191fa24c532d1f67e7a642e9aece65efb8a0975Christian MaederrArrow = text "->"
5191fa24c532d1f67e7a642e9aece65efb8a0975Christian MaederlArrow = text "<-"
a53841f6d6e86ac751c12a33dc8aadf53f59d977Klaus LuettichprettyType :: Type -> Doc
a53841f6d6e86ac751c12a33dc8aadf53f59d977Klaus LuettichprettyType (Arrow x y) = parens (prettyType x <+> text "->" <+> prettyType y)
a53841f6d6e86ac751c12a33dc8aadf53f59d977Klaus LuettichprettyType (List x) = brackets (prettyType x)
a53841f6d6e86ac751c12a33dc8aadf53f59d977Klaus LuettichprettyType (Tuple xs) = tuple (map prettyType xs)
a737caf82de97c1907027c03e4b4509eb492b4b8Christian MaederprettyType (Var s) = text s
68d10d143f29fcff3c637ba24f90e983995ceae6Christian MaederprettyType (Con s) = text s
96646aed2ae087b942ae23f15bbe729a8f7c43d3Christian MaederprettyType (LApply t ts) = prettyType t <+> hsep (map prettyType ts)
3b06e23643a9f65390cb8c1caabe83fa7e87a708Till Mossakowski-- New Pretty Printers ---------------
f04e8f3ff56405901be968fd4c6e9769239f1a9bKlaus Luettichtexts :: [String] -> [Doc]
ce8b15da31cd181b7e90593cbbca98f47eda29d6Till Mossakowskitexts = map text
e7757995211bd395dc79d26fe017d99375f7d2a6Christian Maederblock, blockList,parenList,bracketList :: [Doc] -> Doc
63f0e65a37b95621334db9ee4ba0cd9d826f5c0fChristian Maederblock = nest 4 . vcat
63f0e65a37b95621334db9ee4ba0cd9d826f5c0fChristian MaederblockList = braces . fcat . sepWith semi
a1ed34933c266ce85066acb0d7b20c90cb8eb213Christian MaederparenList = parens . fcat . sepWith comma
c0c2380bced8159ff0297ece14eba948bd236471Christian MaederbracketList = brackets . fcat . sepWith comma
6a79849bed67264c396dddb3e9c184bdfc1a1bc9Christian Maeder-- for bulding m1 >> m2 >> m3, f . g . h, etc
63f0e65a37b95621334db9ee4ba0cd9d826f5c0fChristian MaedersepWith :: a -> [a] -> [a]
8410667510a76409aca9bb24ff0eda0420088274Christian MaedersepWith _ [] = []
404166b9366552e9ec5abb87a37c76ec8a815fb7Klaus LuettichsepWith _ [x] = [x]
b1f59a4ea7c96f4c03a4d7cfcb9c5e66871cfbbbChristian MaedersepWith a (x:xs) = x:a: sepWith a xs
4d56f2fa72e4aec20eb827c11ed49c8cbb7014bdChristian Maeder--optional combinator, applys fn if arg is non-[]
4cb215739e9ab13447fa21162482ebe485b47455Christian Maederopt :: [a] -> ([a] -> Doc) -> Doc
8ef75f1cc0437656bf622cec5ac9e8ea221da8f2Christian Maederopt [] _ = empty
356fa49fe3e6a8398f92d13e9f920d0f093697ecChristian Maeder--equivalent of `opt' for singleton lists
63f0e65a37b95621334db9ee4ba0cd9d826f5c0fChristian Maederopt1 :: [a] -> ([a] -> Doc) -> (a -> Doc) -> Doc
55adfe57a4de1f36adc3e3bfc16f342e44a7d444Christian Maederopt1 [] _ _ = empty
d23b0cc79c0d204e6ec758dff8d0ba71c9f693f7Christian Maederopt1 [x] _ g = g x
8d97ef4f234681b11bb5924bd4d03adef858d2d2Christian Maederopt1 a f _ = f a
63f0e65a37b95621334db9ee4ba0cd9d826f5c0fChristian Maeder-- new simple docs
e593b89bfd4952698dc37feced21cefe869d87a2Christian MaedercommentLine x = text "--" <+> x -- useful for warnings / error messages
63f0e65a37b95621334db9ee4ba0cd9d826f5c0fChristian MaedercommentBlock x = text "{-" <+> x <+> text "-}"
7cc09dd93962a2155c34d209d1d4cd7d7b838264Christian Maeder--- Utility Functions -------------------------------------------------------
7cc09dd93962a2155c34d209d1d4cd7d7b838264Christian MaederstrippedName = reverse . takeWhile (/= '.') . reverse . name
1aee4aaddde105264c1faf394d88e302c05094ffChristian Maeder-- instance header, handling class constraints etc.
c3053d57f642ca507cdf79512e604437c4546cb9Christian MaedersimpleInstance :: Class -> Data -> Doc
dcbd32289a7bdf1e6edd06c6ab0698c6a9dbf37aChristian MaedersimpleInstance s d = hsep [text "instance"
f4a2a20e49f41b2afa657e5e64d9e349c7faa091Christian Maeder , opt1 constr (\ x -> parenList x <+> text "=>")
f4a2a20e49f41b2afa657e5e64d9e349c7faa091Christian Maeder ( \ x -> x <+> text "=>")
b886e9e5db2098d0112cc4f70aeba232962939ddChristian Maeder , opt1 (texts (strippedName d : vars d)) parenSpace id]
1aee4aaddde105264c1faf394d88e302c05094ffChristian Maeder constr = map (\(c,v) -> text c <+> text v) (constraints d) ++
356fa49fe3e6a8398f92d13e9f920d0f093697ecChristian Maeder map (\x -> text s <+> text x) (vars d)
356fa49fe3e6a8398f92d13e9f920d0f093697ecChristian Maeder parenSpace = parens . hcat . sepWith space
356fa49fe3e6a8398f92d13e9f920d0f093697ecChristian Maeder-- instanceSkeleton handles most instance declarations, where instance
0206ab93ef846e4e0885996d052b9b73b9dc66b0Christian Maeder-- functions are not related to one another. A member function is generated
f13d1e86e58da53680e78043e8df182eed867efbChristian Maeder-- using a (IFunction,Doc) pair. The IFunction is applied to each body of the
c2a4d8ae266aa37cc922eba97077520229a19902Christian Maeder-- type, creating a block of pattern - matching cases. Default cases can be
79e80c4b3f0ebb337d84415a50f29ccfc793e68bChristian Maeder-- given using the Doc in the pair. If a default case is not required, set
79e80c4b3f0ebb337d84415a50f29ccfc793e68bChristian Maeder-- Doc to 'empty'
79e80c4b3f0ebb337d84415a50f29ccfc793e68bChristian Maedertype IFunction = Body -> Doc -- instance function
ecf76bc89d9a2ecd7ac7310d30654b9a79d97d62Klaus LuettichinstanceSkeleton :: Class -> [(IFunction,Doc)] -> Data -> Doc
ecf76bc89d9a2ecd7ac7310d30654b9a79d97d62Klaus LuettichinstanceSkeleton s ii d = (simpleInstance s d <+> text "where")
ecf76bc89d9a2ecd7ac7310d30654b9a79d97d62Klaus Luettich $$ block functions
36f63902db2b3463faa9f59912ad106e2d5aaa24Klaus Luettich functions = concatMap f ii
f04e8f3ff56405901be968fd4c6e9769239f1a9bKlaus Luettich f (i,dflt) = map i (body d) ++ [dflt]
8cacad2a09782249243b80985f28e9387019fe40Christian Maeder-- little variable name generator, generates unique names a - z
363939beade943a02b31004cea09dec34fa8a6d9Christian MaedervarNames :: [a] -> [Doc]
a7c27282e71cf4505026645f96d4f5cb8a284e32Christian MaedervarNames l = zipWith (const char) l ['a' .. 'z']
8a28707e9155465c6f2236a06eac6580a65c7025Christian Maeder-- variant generating aa' - aZ'
f04e8f3ff56405901be968fd4c6e9769239f1a9bKlaus LuettichvarNames' :: [a] -> [Doc]
797ccd67cb8ae127be097cd43448801b673e3b69Christian MaedervarNames' = map (<> (char '\'')) . varNames
431d34c7007a787331c4e5ec997badb0f8190fc7Christian Maeder-- pattern matching a constructor and args
63f0e65a37b95621334db9ee4ba0cd9d826f5c0fChristian Maederpattern :: Constructor -> [a] -> Doc
d3ae0072823e2ef0d41d4431fcc768e66489c20eChristian Maederpattern c l = parens $ fsep (text c : varNames l)
63f0e65a37b95621334db9ee4ba0cd9d826f5c0fChristian Maederpattern_ :: Constructor -> [a] -> Doc
5191fa24c532d1f67e7a642e9aece65efb8a0975Christian Maederpattern_ c l = parens $ fsep (text c : replicate (length l) (text "_"))
9e748851c150e1022fb952bab3315e869aaf0214Christian Maederpattern' :: Constructor -> [a] -> Doc
6a79849bed67264c396dddb3e9c184bdfc1a1bc9Christian Maederpattern' c l = parens $ fsep (text c : varNames' l)
6a79849bed67264c396dddb3e9c184bdfc1a1bc9Christian Maeder-- test that a datatype has at least one record constructor
6a79849bed67264c396dddb3e9c184bdfc1a1bc9Christian MaederhasRecord :: Data -> Bool
6a79849bed67264c396dddb3e9c184bdfc1a1bc9Christian MaederhasRecord d = statement d == DataStmt
b886e9e5db2098d0112cc4f70aeba232962939ddChristian Maeder && any (not . null . labels) (body d)
9e748851c150e1022fb952bab3315e869aaf0214Christian Maedertuple :: [Doc] -> Doc
9e748851c150e1022fb952bab3315e869aaf0214Christian Maedertuple xs = parens $ hcat (punctuate (char ',') xs)