{- |
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 :: (Doc -> Doc) -> ([Doc] -> Doc) -> [a] -> Doc
combine _ _ [] = Doc
empty
combine wrap :: Doc -> Doc
wrap dsep :: [Doc] -> Doc
dsep list :: [a]
list = Doc -> Doc
wrap (Doc -> Doc) -> ([a] -> Doc) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
dsep ([Doc] -> Doc) -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Pretty a => a -> Doc
pretty ([a] -> Doc) -> [a] -> Doc
forall a b. (a -> b) -> a -> b
$ [a]
list

-- | Separate with spaces, wrap with parentheses.
parenPretties :: (Pretty a) => [a] -> Doc
parenPretties :: [a] -> Doc
parenPretties = (Doc -> Doc) -> ([Doc] -> Doc) -> [a] -> Doc
forall a. Pretty a => (Doc -> Doc) -> ([Doc] -> Doc) -> [a] -> Doc
combine Doc -> Doc
parens [Doc] -> Doc
hsep

-- | Separate with spaces, wrap with square brackets.
bracketPretties :: (Pretty a) => [a] -> Doc
bracketPretties :: [a] -> Doc
bracketPretties = (Doc -> Doc) -> ([Doc] -> Doc) -> [a] -> Doc
forall a. Pretty a => (Doc -> Doc) -> ([Doc] -> Doc) -> [a] -> Doc
combine Doc -> Doc
brackets [Doc] -> Doc
hsep

-- | Separate with newlines, wrap with square brackets and newlines.
combineHooks :: (Pretty a) => [a] -> Doc
combineHooks :: [a] -> Doc
combineHooks = let bracketed :: Doc -> Doc
bracketed doc :: Doc
doc = Doc
lbrack Doc -> Doc -> Doc
$+$ Doc
doc Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
rbrack
               in (Doc -> Doc) -> ([Doc] -> Doc) -> [a] -> Doc
forall a. Pretty a => (Doc -> Doc) -> ([Doc] -> Doc) -> [a] -> Doc
combine Doc -> Doc
bracketed [Doc] -> Doc
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 :: String
-> String -> Doc -> a -> b -> [Condition] -> [StmntAttr] -> Doc
prettySentence s1 :: String
s1 s2 :: String
s2 op :: Doc
op t1 :: a
t1 t2 :: b
t2 cs :: [Condition]
cs as :: [StmntAttr]
as = [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ if [Condition] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Condition]
cs
    then [String -> Doc
keyword String
s1, a -> Doc
forall a. Pretty a => a -> Doc
pretty a
t1, Doc
op, b -> Doc
forall a. Pretty a => a -> Doc
pretty b
t2, [StmntAttr] -> Doc
forall a. Pretty a => a -> Doc
pretty [StmntAttr]
as, Doc
dot]
    else [String -> Doc
keyword String
s2, a -> Doc
forall a. Pretty a => a -> Doc
pretty a
t1, Doc
op, b -> Doc
forall a. Pretty a => a -> Doc
pretty b
t2, [Condition] -> Doc
forall a. Pretty a => a -> Doc
pretty [Condition]
cs, [StmntAttr] -> Doc
forall a. Pretty a => a -> Doc
pretty [StmntAttr]
as, Doc
dot]

-- * Pretty instances

-- ** Pretty Sentences

instance Pretty Membership where
    pretty :: Membership -> Doc
pretty (Mb t :: Term
t s :: Sort
s cs :: [Condition]
cs as :: [StmntAttr]
as) = String
-> String
-> Doc
-> Term
-> Sort
-> [Condition]
-> [StmntAttr]
-> Doc
forall a b.
(Pretty a, Pretty b) =>
String
-> String -> Doc -> a -> b -> [Condition] -> [StmntAttr] -> Doc
prettySentence "mb" "cmb" Doc
colon Term
t Sort
s [Condition]
cs [StmntAttr]
as

instance Pretty Equation where
    pretty :: Equation -> Doc
pretty (Eq t1 :: Term
t1 t2 :: Term
t2 cs :: [Condition]
cs as :: [StmntAttr]
as) = String
-> String
-> Doc
-> Term
-> Term
-> [Condition]
-> [StmntAttr]
-> Doc
forall a b.
(Pretty a, Pretty b) =>
String
-> String -> Doc -> a -> b -> [Condition] -> [StmntAttr] -> Doc
prettySentence "eq" "ceq" Doc
equals Term
t1 Term
t2 [Condition]
cs [StmntAttr]
as

instance Pretty Rule where
    pretty :: Rule -> Doc
pretty (Rl t1 :: Term
t1 t2 :: Term
t2 cs :: [Condition]
cs as :: [StmntAttr]
as) = String
-> String
-> Doc
-> Term
-> Term
-> [Condition]
-> [StmntAttr]
-> Doc
forall a b.
(Pretty a, Pretty b) =>
String
-> String -> Doc -> a -> b -> [Condition] -> [StmntAttr] -> Doc
prettySentence "rl" "crl" Doc
implies Term
t1 Term
t2 [Condition]
cs [StmntAttr]
as

-- ** Pretty Conditions
instance Pretty Condition where
    pretty :: Condition -> Doc
pretty cond :: Condition
cond = let pretty' :: a -> Doc -> a -> Doc
pretty' x :: a
x y :: Doc
y z :: a
z = [Doc] -> Doc
hsep [a -> Doc
forall a. Pretty a => a -> Doc
pretty a
x, Doc
y, a -> Doc
forall a. Pretty a => a -> Doc
pretty a
z]
        in case Condition
cond of
            MbCond t :: Term
t s :: Sort
s -> Term -> Doc -> Sort -> Doc
forall a a. (Pretty a, Pretty a) => a -> Doc -> a -> Doc
pretty' Term
t Doc
colon Sort
s
            EqCond t1 :: Term
t1 t2 :: Term
t2 -> Term -> Doc -> Term -> Doc
forall a a. (Pretty a, Pretty a) => a -> Doc -> a -> Doc
pretty' Term
t1 Doc
equals Term
t2
            RwCond t1 :: Term
t1 t2 :: Term
t2 -> Term -> Doc -> Term -> Doc
forall a a. (Pretty a, Pretty a) => a -> Doc -> a -> Doc
pretty' Term
t1 Doc
implies Term
t2
            MatchCond t1 :: Term
t1 t2 :: Term
t2 -> Term -> Doc -> Term -> Doc
forall a a. (Pretty a, Pretty a) => a -> Doc -> a -> Doc
pretty' Term
t1 (String -> Doc
text ":=") Term
t2
    pretties :: [Condition] -> Doc
pretties = (Doc -> Doc) -> ([Doc] -> Doc) -> [Condition] -> Doc
forall a. Pretty a => (Doc -> Doc) -> ([Doc] -> Doc) -> [a] -> Doc
combine (String -> Doc
text "if" Doc -> Doc -> Doc
<+>) ([Doc] -> Doc
hsep ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse Doc
andDoc)

-- ** Pretty Attributes

instance Pretty Attr where
    pretty :: Attr -> Doc
pretty attr :: Attr
attr = case Attr
attr of
        Assoc -> String -> Doc
text "assoc"
        Comm -> String -> Doc
text "comm"
        Idem -> String -> Doc
text "idem"
        Iter -> String -> Doc
text "iter"
        Id term :: Term
term -> String -> Doc
text "id:" Doc -> Doc -> Doc
<+> Term -> Doc
forall a. Pretty a => a -> Doc
pretty Term
term
        LeftId term :: Term
term -> String -> Doc
text "id-left:" Doc -> Doc -> Doc
<+> Term -> Doc
forall a. Pretty a => a -> Doc
pretty Term
term
        RightId term :: Term
term -> String -> Doc
text "id-right:" Doc -> Doc -> Doc
<+> Term -> Doc
forall a. Pretty a => a -> Doc
pretty Term
term
        Strat ints :: [Int]
ints -> String -> Doc
text "strat" Doc -> Doc -> Doc
<+> [Int] -> Doc
forall a. Pretty a => [a] -> Doc
parenPretties [Int]
ints
        Memo -> String -> Doc
text "memo"
        Prec int :: Int
int -> String -> Doc
text "prec" Doc -> Doc -> Doc
<+> Int -> Doc
forall a. Pretty a => a -> Doc
pretty Int
int
        Gather qids :: [Qid]
qids -> String -> Doc
text "gather" Doc -> Doc -> Doc
<+> [Qid] -> Doc
forall a. Pretty a => [a] -> Doc
parenPretties [Qid]
qids
        Format qids :: [Qid]
qids -> String -> Doc
text "format" Doc -> Doc -> Doc
<+> [Qid] -> Doc
forall a. Pretty a => [a] -> Doc
parenPretties [Qid]
qids
        Ctor -> String -> Doc
text "ctor"
        Config -> String -> Doc
text "config"
        Object -> String -> Doc
text "object"
        Msg -> String -> Doc
text "msg"
        Frozen ints :: [Int]
ints -> String -> Doc
text "frozen" Doc -> Doc -> Doc
<+> [Int] -> Doc
forall a. Pretty a => [a] -> Doc
parenPretties [Int]
ints
        Poly ints :: [Int]
ints -> String -> Doc
text "poly" Doc -> Doc -> Doc
<+> [Int] -> Doc
forall a. Pretty a => [a] -> Doc
parenPretties [Int]
ints
        Special hooks :: [Hook]
hooks -> String -> Doc
text "special" Doc -> Doc -> Doc
<+> [Hook] -> Doc
forall a. Pretty a => [a] -> Doc
combineHooks [Hook]
hooks
    pretties :: [Attr] -> Doc
pretties = [Attr] -> Doc
forall a. Pretty a => [a] -> Doc
bracketPretties

instance Pretty StmntAttr where
    pretty :: StmntAttr -> Doc
pretty attr :: StmntAttr
attr = case StmntAttr
attr of
        Owise -> String -> Doc
text "owise"
        Nonexec -> String -> Doc
text "nonexec"
        Metadata str :: String
str -> String -> Doc
text "metadata" Doc -> Doc -> Doc
<+> Doc -> Doc
doubleQuotes (String -> Doc
forall a. Pretty a => a -> Doc
pretty String
str)
        Label qid :: Qid
qid -> String -> Doc
text "label" Doc -> Doc -> Doc
<+> Doc -> Doc
doubleQuotes (Qid -> Doc
forall a. Pretty a => a -> Doc
pretty Qid
qid)
        Print _ -> Doc
empty
    pretties :: [StmntAttr] -> Doc
pretties = [StmntAttr] -> Doc
forall a. Pretty a => [a] -> Doc
bracketPretties

-- ** Pretty Hooks

instance Pretty Hook where
    pretty :: Hook -> Doc
pretty hook :: Hook
hook = case Hook
hook of
        IdHook qid :: Qid
qid qs :: [Qid]
qs -> [Doc] -> Doc
hsep
            [String -> Doc
text "id-hook", Qid -> Doc
forall a. Pretty a => a -> Doc
pretty Qid
qid, [Qid] -> Doc
forall a. Pretty a => [a] -> Doc
parenPretties [Qid]
qs]
        OpHook qid :: Qid
qid op :: Qid
op dom :: [Qid]
dom cod :: Qid
cod -> let symb :: Symbol
symb = Qid -> [Qid] -> Qid -> Symbol
mkOpPartial Qid
op [Qid]
dom Qid
cod
            in [Doc] -> Doc
hsep [String -> Doc
text "op-hook", Qid -> Doc
forall a. Pretty a => a -> Doc
pretty Qid
qid, Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Symbol -> Doc
forall a. Pretty a => a -> Doc
pretty Symbol
symb]
        TermHook qid :: Qid
qid term :: Term
term -> [Doc] -> Doc
hsep
            [String -> Doc
text "term-hook", Qid -> Doc
forall a. Pretty a => a -> Doc
pretty Qid
qid, Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Term -> Doc
forall a. Pretty a => a -> Doc
pretty Term
term]
    pretties :: [Hook] -> Doc
pretties = (Doc -> Doc) -> ([Doc] -> Doc) -> [Hook] -> Doc
forall a. Pretty a => (Doc -> Doc) -> ([Doc] -> Doc) -> [a] -> Doc
combine Doc -> Doc
parens [Doc] -> Doc
vcat

-- ** Pretty Terms

instance Pretty Term where
    pretty :: Term -> Doc
pretty term :: Term
term = case Term
term of
        Const qid :: Qid
qid _ -> Qid -> Doc
forall a. Pretty a => a -> Doc
pretty Qid
qid
        Var qid :: Qid
qid tp :: Type
tp -> [Doc] -> Doc
hcat [Qid -> Doc
forall a. Pretty a => a -> Doc
pretty Qid
qid, Doc
colon, Type -> Doc
forall a. Pretty a => a -> Doc
pretty Type
tp]
        Apply qid :: Qid
qid ts :: [Term]
ts _ -> Qid -> Doc
forall a. Pretty a => a -> Doc
pretty Qid
qid Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> (Doc -> Doc
parens (Doc -> Doc) -> ([Term] -> Doc) -> [Term] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Term] -> Doc
forall a. Pretty a => a -> Doc
pretty ([Term] -> Doc) -> [Term] -> Doc
forall a b. (a -> b) -> a -> b
$ [Term]
ts)
    pretties :: [Term] -> Doc
pretties = (Doc -> Doc) -> ([Doc] -> Doc) -> [Term] -> Doc
forall a. Pretty a => (Doc -> Doc) -> ([Doc] -> Doc) -> [a] -> Doc
combine Doc -> Doc
forall a. a -> a
id [Doc] -> Doc
sepByCommas

-- ** Pretty Identifiers

instance Pretty Type where
    pretty :: Type -> Doc
pretty typ :: Type
typ = case Type
typ of
        TypeSort sort :: Sort
sort -> Sort -> Doc
forall a. Pretty a => a -> Doc
pretty Sort
sort
        TypeKind kind :: Kind
kind -> Kind -> Doc
forall a. Pretty a => a -> Doc
pretty Kind
kind

instance Pretty Sort where
    pretty :: Sort -> Doc
pretty (SortId qid :: Qid
qid) = Qid -> Doc
forall a. Pretty a => a -> Doc
pretty Qid
qid

instance Pretty Kind where
    pretty :: Kind -> Doc
pretty (KindId qid :: Qid
qid) = Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Qid -> Doc
forall a. Pretty a => a -> Doc
pretty Qid
qid

instance Pretty ParamId where
    pretty :: ParamId -> Doc
pretty (ParamId qid :: Qid
qid) = Qid -> Doc
forall a. Pretty a => a -> Doc
pretty Qid
qid

instance Pretty ViewId where
    pretty :: ViewId -> Doc
pretty (ViewId qid :: Qid
qid) = Qid -> Doc
forall a. Pretty a => a -> Doc
pretty Qid
qid

instance Pretty ModId where
    pretty :: ModId -> Doc
pretty (ModId qid :: Qid
qid) = Qid -> Doc
forall a. Pretty a => a -> Doc
pretty Qid
qid

instance Pretty LabelId where
    pretty :: LabelId -> Doc
pretty (LabelId qid :: Qid
qid) = Qid -> Doc
forall a. Pretty a => a -> Doc
pretty Qid
qid

instance Pretty OpId where
    pretty :: OpId -> Doc
pretty (OpId qid :: Qid
qid) = Qid -> Doc
forall a. Pretty a => a -> Doc
pretty Qid
qid