{- |

Module : ./Maude/Printing.hs

Description : Translation from Haskell to Maude

Copyright : (c) Martin Kuehl, Uni Bremen 2009

License : GPLv2 or higher, see LICENSE.txt

Maintainer : mkhl@informatik.uni-bremen.de

Stability : experimental

Portability : portable

Translations from Haskell to Maude.

The translations from Haskell datatypes to Maude source code are

implemented as instances of the typeclass 'Pretty' as defined in the

modules "Common.Doc" and "Common.DocUtils", which see.

Nothing else is exported by this module.

-}

module Maude.Printing () where

import Maude.AS_Maude

import Maude.Symbol

import Common.Doc

import Common.DocUtils (Pretty (..))

import Data.List (intersperse)

-- * Combinators

-- | Convert every item in @list@, combine with @dsep@, wrap with @wrap@.

combine :: (Pretty a) => (Doc -> Doc) -> ([Doc] -> Doc) -> [a] -> Doc

combine _ _ [] = empty

combine wrap dsep list = wrap . dsep . map pretty $ list

-- | Separate with spaces, wrap with parentheses.

parenPretties :: (Pretty a) => [a] -> Doc

parenPretties = combine parens hsep

-- | Separate with spaces, wrap with square brackets.

bracketPretties :: (Pretty a) => [a] -> Doc

bracketPretties = combine brackets hsep

-- | Separate with newlines, wrap with square brackets and newlines.

combineHooks :: (Pretty a) => [a] -> Doc

combineHooks = let bracketed doc = lbrack $+$ doc <> rbrack

in combine bracketed vcat

{- | Assemble a pretty-printing for all parts of a Sentence,

distinguishing conditional Sentence from simple ones. -}

prettySentence :: (Pretty a, Pretty b) =>

String -> String -> Doc -> a -> b -> [Condition] -> [StmntAttr] -> Doc

prettySentence s1 s2 op t1 t2 cs as = hsep $ if null cs

then [keyword s1, pretty t1, op, pretty t2, pretty as, dot]

else [keyword s2, pretty t1, op, pretty t2, pretty cs, pretty as, dot]

-- * Pretty instances

-- ** Pretty Sentences

instance Pretty Membership where

pretty (Mb t s cs as) = prettySentence "mb" "cmb" colon t s cs as

instance Pretty Equation where

pretty (Eq t1 t2 cs as) = prettySentence "eq" "ceq" equals t1 t2 cs as

instance Pretty Rule where

pretty (Rl t1 t2 cs as) = prettySentence "rl" "crl" implies t1 t2 cs as

-- ** Pretty Conditions

instance Pretty Condition where

pretty cond = let pretty' x y z = hsep [pretty x, y, pretty z]

in case cond of

MbCond t s -> pretty' t colon s

EqCond t1 t2 -> pretty' t1 equals t2

RwCond t1 t2 -> pretty' t1 implies t2

MatchCond t1 t2 -> pretty' t1 (text ":=") t2

pretties = combine (text "if" <+>) (hsep . intersperse andDoc)

-- ** Pretty Attributes

instance Pretty Attr where

pretty attr = case attr of

Assoc -> text "assoc"

Comm -> text "comm"

Idem -> text "idem"

Iter -> text "iter"

Id term -> text "id:" <+> pretty term

LeftId term -> text "id-left:" <+> pretty term

RightId term -> text "id-right:" <+> pretty term

Strat ints -> text "strat" <+> parenPretties ints

Memo -> text "memo"

Prec int -> text "prec" <+> pretty int

Gather qids -> text "gather" <+> parenPretties qids

Format qids -> text "format" <+> parenPretties qids

Ctor -> text "ctor"

Config -> text "config"

Object -> text "object"

Msg -> text "msg"

Frozen ints -> text "frozen" <+> parenPretties ints

Poly ints -> text "poly" <+> parenPretties ints

Special hooks -> text "special" <+> combineHooks hooks

pretties = bracketPretties

instance Pretty StmntAttr where

pretty attr = case attr of

Owise -> text "owise"

Nonexec -> text "nonexec"

Metadata str -> text "metadata" <+> doubleQuotes (pretty str)

Label qid -> text "label" <+> doubleQuotes (pretty qid)

Print _ -> empty

pretties = bracketPretties

-- ** Pretty Hooks

instance Pretty Hook where

pretty hook = case hook of

IdHook qid qs -> hsep

[text "id-hook", pretty qid, parenPretties qs]

OpHook qid op dom cod -> let symb = mkOpPartial op dom cod

in hsep [text "op-hook", pretty qid, parens $ pretty symb]

TermHook qid term -> hsep

[text "term-hook", pretty qid, parens $ pretty term]

pretties = combine parens vcat

-- ** Pretty Terms

instance Pretty Term where

pretty term = case term of

Const qid _ -> pretty qid

Var qid tp -> hcat [pretty qid, colon, pretty tp]

Apply qid ts _ -> pretty qid <> (parens . pretty $ ts)

pretties = combine id sepByCommas

-- ** Pretty Identifiers

instance Pretty Type where

pretty typ = case typ of

TypeSort sort -> pretty sort

TypeKind kind -> pretty kind

instance Pretty Sort where

pretty (SortId qid) = pretty qid

instance Pretty Kind where

pretty (KindId qid) = brackets $ pretty qid

instance Pretty ParamId where

pretty (ParamId qid) = pretty qid

instance Pretty ViewId where

pretty (ViewId qid) = pretty qid

instance Pretty ModId where

pretty (ModId qid) = pretty qid

instance Pretty LabelId where

pretty (LabelId qid) = pretty qid

instance Pretty OpId where

pretty (OpId qid) = pretty qid