{- |

Module : $EmptyHeader$

Description : <optional short description entry>

Copyright : (c) <Authors or Affiliations>

License : GPLv2 or higher

Maintainer : <email>

Stability : unstable | experimental | provisional | stable | frozen

Portability : portable | non-portable (<reason>)

<optional description>

-}

-- utilities for writing new rules.

module RuleUtils where

import Text.PrettyPrint.HughesPJ

import DataP (Statement (..), Data (..), Type (..), Class,

Body (..), Constructor)

-- Rule Declarations

type Tag = String

type Rule = (Tag, Data -> Doc)

type RuleDef = (Tag, Data -> Doc, String, String, Maybe String)

rArrow :: Doc

rArrow = text "->"

lArrow :: Doc

lArrow = text "<-"

prettyType :: Type -> Doc

prettyType (Arrow x y) = parens (prettyType x <+> text "->" <+> prettyType y)

prettyType (List x) = brackets (prettyType x)

prettyType (Tuple xs) = tuple (map prettyType xs)

prettyType (Var s) = text s

prettyType (Con s) = text s

prettyType (LApply t ts) = prettyType t <+> hsep (map prettyType ts)

-- New Pretty Printers ---------------

texts :: [String] -> [Doc]

texts = map text

block, parenList, bracketList :: [Doc] -> Doc

block = nest 4 . vcat

parenList = parens . fsep . sepWith comma

bracketList = brackets . fsep . sepWith comma

-- for bulding m1 >> m2 >> m3, f . g . h, etc

sepWith :: Doc -> [Doc] -> [Doc]

sepWith _ [] = []

sepWith _ [x] = [x]

sepWith a (x : xs) = (x <> a) : sepWith a xs

-- optional combinator, applys fn if arg is non-[]

opt :: [a] -> ([a] -> Doc) -> Doc

opt [] _ = empty

opt a f = f a

-- equivalent of `opt' for singleton lists

opt1 :: [a] -> ([a] -> Doc) -> (a -> Doc) -> Doc

opt1 [] _ _ = empty

opt1 [x] _ g = g x

opt1 a f _ = f a

-- new simple docs

commentLine :: Doc -> Doc

commentLine x = text "--" <+> x -- useful for warnings / error messages

commentBlock :: Doc -> Doc

commentBlock x = text "{-" <+> x <+> text "-}"

-- - Utility Functions -------------------------------------------------------

-- Instances

strippedName :: Data -> String

strippedName = reverse . takeWhile (/= '.') . reverse . name

-- instance header, handling class constraints etc.

simpleInstance :: Class -> Data -> Doc

simpleInstance s d = hsep [text "instance"

, opt1 constr (\ x -> parenList x <+> text "=>")

( \ x -> x <+> text "=>")

, text s

, opt1 (texts (strippedName d : vars d)) parenSpace id]

where

constr = map (\ (c, v) -> text c <+> text v) (constraints d) ++

map (\ x -> text s <+> text x) (vars d)

parenSpace = parens . hsep

{- instanceSkeleton handles most instance declarations, where instance

functions are not related to one another. A member function is generated

using a (IFunction,Doc) pair. The IFunction is applied to each body of the

type, creating a block of pattern - matching cases. Default cases can be

given using the Doc in the pair. If a default case is not required, set

Doc to 'empty' -}

type IFunction = Body -> Doc -- instance function

instanceSkeleton :: Class -> [(IFunction, Doc)] -> Data -> Doc

instanceSkeleton s ii d = (simpleInstance s d <+> text "where")

$$ block functions

where

functions = concatMap f ii

f (i, dflt) = map i (body d) ++ [dflt]

-- little variable name generator, generates unique names a - z

varNames :: [a] -> [Doc]

varNames l = zipWith (const char) l ['a' .. 'z']

-- variant generating aa' - aZ'

varNames' :: [a] -> [Doc]

varNames' = map (<> char '\'') . varNames

-- pattern matching a constructor and args

pattern :: Constructor -> [a] -> Doc

pattern c l = parens $ fsep (text c : varNames l)

pattern_ :: Constructor -> [a] -> Doc

pattern_ c l = parens $ fsep (text c : replicate (length l) (text "_"))

pattern' :: Constructor -> [a] -> Doc

pattern' c l = parens $ fsep (text c : varNames' l)

-- test that a datatype has at least one record constructor

hasRecord :: Data -> Bool

hasRecord d = statement d == DataStmt

&& any (not . null . labels) (body d)

tuple :: [Doc] -> Doc

tuple xs = parens $ hcat (punctuate (char ',') xs)