Commit 917029dc authored by Camil Staps's avatar Camil Staps 🐧

Clean.PrettyPrint: Start

parent b4823616
definition module CleanPrettyPrint
from syntax import :: ParsedDefinition
class cpp t :: t -> String
instance cpp ParsedDefinition
implementation module CleanPrettyPrint
import StdEnv
import syntax
import CleanPrettyPrint.Util
import CleanPrettyPrint.Common
import CleanPrettyPrint.Expression
import CleanPrettyPrint.Definition
instance cpp ParsedDefinition where cpp pd = print zero pd
definition module CleanPrettyPrint.Common
from CleanPrettyPrint.Util import class print
from syntax import :: Ident, :: Import
instance print Ident, Import
implementation module CleanPrettyPrint.Common
import StdEnv
import CleanPrettyPrint.Util
import CleanPrettyPrint.Definition
import syntax
instance print Ident
where
print _ {id_name} = lookup id_name namemap
where
lookup k [] = k
lookup k [(k`,v):m] = if (k == k`) v (lookup k m)
namemap =
[ ("_Nil", "[]")
, ("_nil", "[|]")
, ("_|Nil", "[|]")
, ("_#Nil", "[#]")
]
instance print Import
where
print st ip=:{import_symbols=ImportSymbolsOnly ids,import_qualified=NotQualified}
= print st ("from " :+: ip.import_module :+: " import " :+: join st ", " ids)
print st ip=:{import_symbols=ImportSymbolsOnly _}
= abort "UNKNOWN: ImportSymbolsOnly with Qualified"
print st ip=:{import_symbols=ImportSymbolsAll}
= print st ("import " :+: q :+: ip.import_module :+: as_)
where
q = case ip.import_qualified of
NotQualified = ""
_ = "qualified "
as_ = case ip.import_qualified of
(QualifiedAs name) = " as " :+: name
_ = PrintNil
instance print ImportDeclaration
where
print st (ID_Function f)
= print st f
print st (ID_Class c mems)
= print st ("class " :+: c :+: mems`)
where
mems` = case mems of
(Yes []) = "(..)"
(Yes mems) = "(" +++ join st "," mems +++ ")"
_ = ""
print st (ID_Type t conses)
= print st (":: " :+: t :+: conses`)
where
conses` = case conses of
(Yes []) = "(..)"
(Yes conses) = "(" +++ join st "," conses +++ ")"
_ = ""
print st (ID_Record t fields)
= print st (":: " :+: t :+: fields`)
where
fields` = case fields of
(Yes []) = "{..}"
(Yes fields) = "{" +++ join st "," fields +++ "}"
_ = ""
print st (ID_Instance cls _ (ts, tcs))
= print st (cls :+: join_start st " " ts :+: if (isEmpty tcs) "" (" | " +++ join st " & " tcs))
print st _
= abort "UNKNOWN_IMPORTDECLARATION"
definition module CleanPrettyPrint.Definition
from CleanPrettyPrint.Util import class print
from syntax import :: ParsedDefinition, :: Type, :: TypeContext
instance print ParsedDefinition, Type, TypeContext
implementation module CleanPrettyPrint.Definition
import StdEnv
import CleanPrettyPrint.Util
import CleanPrettyPrint.Common
import CleanPrettyPrint.Expression
import syntax
instance print ParsedDefinition
where
print st (PD_Import ips)
= join st "\n" ips
print st (PD_Class cd mems)
= print st ("class " :+: cd.class_ident :+: args :+: context :+: if (isEmpty mems) "" " where" :+: join_start st` ("\n" :+: st`) mems)
where
st` = { st & cpp_indent = st.cpp_indent + 1 }
context = if (isEmpty cd.class_context) "" (" | " +++ join st " & " cd.class_context)
args = if (isEmpty cd.class_args) "" (join_start st " " cd.class_args)
print st (PD_Instance {pim_pi={pi_ident,pi_types,pi_context}})
= print st ("instance " :+: pi_ident :+: " " :+: join st ", " pi_types :+: pi_context`)
where
pi_context` = if (isEmpty pi_context) PrintNil (" | " :+: join st " & " pi_context)
print st (PD_Instances pis=:[{pim_pi={pi_ident}}:_])
= print st ("instance " :+: pi_ident :+: " " :+: join st ", " (map (\i -> i.pim_pi.pi_types) pis))
print st (PD_Generic {gen_ident,gen_type,gen_vars})
= print st ("generic " :+: gen_ident :+: join_start st " " gen_vars :+: " :: " :+: gen_type)
print st (PD_Derive gencasedefs)
= print st ("derive " :+: join st ", " gencasedefs)
print st (PD_TypeSpec pos id prio type funspecs)
= print st (id` :+: prio` :+: type`)
where
id` = case prio of
NoPrio = id :+: PrintNil
_ = "(" :+: id :+: ")"
prio` = case prio of
(Prio LeftAssoc p) = " infixl " :+: p
(Prio RightAssoc p) = " infixr " :+: p
(Prio NoAssoc p) = " infix " :+: p
NoPrio = PrintNil
type` = case type of
(Yes t) = " :: " :+: t
No = PrintNil
print st (PD_NodeDef _ l r)
= print st (l :+: " = " :+: r)
print st (PD_Function _ id isinfix args rhs fk)
= print st (id` :+: join_start st " " args :+: if show_eq eq "" :+: rhs)
where
id` = if isinfix ("(" :+: id :+: ")") (id :+: PrintNil)
show_eq = case rhs.rhs_alts of (GuardedAlts _ _) = False; _ = True
eq = case fk of FK_Macro = " :== "; _ = " = "
print st (PD_Type {td_ident,td_args,td_attribute,td_rhs})
= print st (":: " :+: td_attribute :+: td_ident :+: join_start st " " td_args :+: equals :+: td_rhs)
where
equals = case td_rhs of
(TypeSpec _) = " :== "
(EmptyRhs _) = ""
_ = " = "
print _ _
= abort "UNKNOWN_PD"
// General types
instance print BasicType
where
print st BT_Int = "Int"
print st BT_Char = "Char"
print st BT_Real = "Real"
print st BT_Bool = "Bool"
print st (BT_String t) = print st ("String" :+: t)
print st BT_File = "File"
print st BT_World = "World"
print st BT_Dynamic = "Dynamic"
instance print SymbolType
where
print st t
= print st (if (isEmpty t.st_args) PrintNil (args` :+: " -> ") :+: t.st_result :+: st_context`)
where
st_context` = if (isEmpty t.st_context) PrintNil (" | " :+: join st " & " t.st_context)
args` = join st " " [if s "!" "" :+: a \\ a <- t.st_args & s <- strictnessListToBools t.st_args_strictness]
strictnessListToBools :: StrictnessList -> [Bool]
strictnessListToBools NotStrict = repeat False
strictnessListToBools (Strict i) = [i bitand (1 << e) <> 0 \\ e <- [0..31]]
strictnessListToBools (StrictList i l) = strictnessListToBools (Strict i) ++ strictnessListToBools l
instance print Type
where
print st (TA tsi ats)
= print st (tsi, ats, [False \\ _ <- ats])
print st (TAS tsi ats slist)
= print st (tsi, ats, strictnessListToBools slist)
print st (at1 --> at2)
= print st ("(" :+: at1 :+: " -> " :+: at2 :+: ")")
print st TArrow
= "(->)"
//print st (TArrow1 at)
// = print st ("((->) " :+: at :+: ")")
print st (cv :@: ats)
= print st ("(" :+: cv :+: " " :+: join st " " ats :+: ")")
print st (TB bt)
= print st bt
//print st (TFA atvs type)
// = "TFA"
//print st (GTV tv)
// = "GTV"
print st (TV tv)
= print st tv
//| TFAC ![ATypeVar] !Type ![TypeContext] // Universally quantified function argument type with contexts
//| TQualifiedIdent !Ident !String ![AType]
//| TGenericFunctionInDictionary !(Global DefinedSymbol) !TypeKind !GlobalIndex /*GenericDict*/
//| TE
print st _
= abort "UNKNOWN_TYPE"
instance print ConsVariable where print st (CV tv) = print st tv //TODO
instance print TypeVar where print st {tv_ident} = tv_ident.id_name
instance print AType
where
print st at = print st (at.at_attribute :+: at.at_type)
instance print ATypeVar
where
print st v = print st (v.atv_attribute :+: v.atv_variable)
instance print TypeAttribute where print _ a = toString a
instance print (TypeSymbIdent, [AType], /* is_strict */ [Bool])
where
print st (tsi, ats, strict)
= print st (case lookup tsi.type_ident.id_name of
(Yes s) = s
No = case ats of
[] = tsi :+: PrintNil
_ = "(" :+: tsi :+: " " :+: join st " " ats :+: ")"
)
where
lookup "_String" = Yes ("String" :+: PrintNil)
lookup "_List" = Yes ("[" :+: join st " " ats :+: "]")
lookup "_!List" = Yes ("[!" :+: join st " " ats :+: "]")
lookup "_List!" = Yes ("[" :+: join st " " ats :+: "!]")
lookup "_!List!" = Yes ("[!" :+: join st " " ats :+: "!]")
lookup "_|List" = Yes ("[|" :+: join st " " ats :+: "]")
lookup "_#List" = Yes ("[#" :+: join st " " ats :+: "]")
lookup "_#List!" = Yes ("[#" :+: join st " " ats :+: "!]")
lookup "_Array" = Yes ("{" :+: join st " " ats :+: "}")
lookup "_#Array" = Yes ("{#" :+: join st " " ats :+: "}")
lookup "_!Array" = Yes ("{!" :+: join st " " ats :+: "}")
lookup name
| name % (0,5) == "_Tuple" = Yes ("(" :+: join st "," ats :+: ")")
lookup _ = No
// Type contexts
instance print TypeContext
where
print st tc
= print st (tc.tc_class :+: " " :+: join st ", " tc.tc_types)
// Type definitions
instance print RhsDefsOfType
where
print st (ConsList conses)
= join st " | " conses
print st (SelectorList _ exivars _ fields)
= print st (exivars` :+: "{" :+: join st ", " fields :+: "}")
where
exivars` = if (isEmpty exivars) PrintNil ("E." :+: join st " " exivars :+: ": ")
print st (TypeSpec type)
= print st type
print st (EmptyRhs _)
= ""
print _ _
= abort "UNKNOWN_RHSDEFSOFTYPE"
instance print ParsedSelector
where
print st ps = print st (ps.ps_selector_ident :+: " :: " :+: ps.ps_field_type)
instance print ParsedConstructor
where
print st cons = print st (cons.pc_cons_ident :+: " " :+: cons.pc_arg_types)
// Generics
instance print GenericCaseDef
where
print st {gc_type,gc_gcf=GCF id _}
= print st (id :+: " " :+: gc_type)
print _ _
= abort "UNKNOWN_GENERICCASEDEF"
// Classes
instance print TCClass
where
print st (TCClass {glob_object={ds_ident}})
= print st ds_ident
print st _
= abort "UNKNOWN_TCCLASS"
// Miscellaneous
instance print TypeSymbIdent where print st tsi = print st tsi.type_ident
definition module CleanPrettyPrint.Expression
from CleanPrettyPrint.Util import class print
from syntax import :: ParsedExpr, :: Rhs
instance print ParsedExpr, Rhs
implementation module CleanPrettyPrint.Expression
import StdEnv
import CleanPrettyPrint.Util
import CleanPrettyPrint.Common
import CleanPrettyPrint.Definition
import syntax
// General expressions
instance print ParsedExpr
where
print st (PE_List [(PE_Ident {id_name}),a,b])
| id_name == "_Cons"
= "[" +++ rest
| id_name == "_cons"
= "[|" +++ rest
| id_name.[0] == '_' && id_name % (2,6) == "Cons"
= "[" +++ {id_name.[1]} +++ rest
where
rest = print st a +++ ":" +++ print st b +++ "]"
print st (PE_List pes)
= printp st pes
print st (PE_Ident id)
= print st id
print st (PE_Basic b)
= print st b
print st (PE_Tuple pes)
= "(" +++ join st "," pes +++ ")"
print st (PE_ArrayDenot ak elems)
= print st ("{" :+: ak :+: join st "," elems :+: "}")
print st (PE_Record init name fields)
= print st ("{ " :+: name` :+: init` :+: join st ", " fields :+: " }")
where
init` = case init of
PE_Empty = ""
_ = print st init +++ " & "
name` = case name of
NoRecordName = ""
(RecordNameIdent id) = print st id +++ " | "
_ = abort "UNKNOWN_OPTIONALRECORDNAME"
print st (PE_ListCompr cons nil pe qs)
= print st ("[" :+: pe :+: " \\\\ " :+: join st ", " qs :+: "]")
print st (PE_If _ c i e)
= "if " +++ join { st & cpp_parens=True } " " [c,i,e]
print st (PE_Case _ pe alts)
= "case " +++ print {st & cpp_parens=True} pe +++ " of" +++ join_start st` ("\n" :+: st`) alts
where
st` = {st & cpp_indent = st.cpp_indent + 1}
print st (PE_Sequ seq)
= print st seq
print st (PE_Lambda _ pes rhs _)
= printp st ("\\" :+: join st " " pes :+: " -> " :+: rhs)
print st (PE_Let lds pe)
= printp st ("let " :+: join st ", " lds :+: " in " :+: pe)
print st (PE_Bound {bind_src,bind_dst})
= print st (bind_dst :+: "=:" :+: bind_src)
print st PE_WildCard
= "_"
print st pe
= abort "UNKNOWN_PE"
instance print Rhs
where
print st {rhs_alts,rhs_locals=LocalParsedDefs []}
= print st rhs_alts
print st {rhs_alts,rhs_locals}
= let st` = {st & cpp_indent = st.cpp_indent + 1} in
print st (rhs_alts :+: "\n" :+: st :+: "where\n" :+: st` :+: join st` ("\n" :+: st`) rhs_locals)
// Basic values
instance print BasicValue
where
print _ (BVInt i) = toString i
print _ (BVC c) = c
print _ (BVB b) = toString b
print _ (BVR r) = r
print _ (BVS s) = s
print _ (BVI _) = "BVI???"
// Lists
instance print Qualifier
where
print st q=:{qual_filter=Yes filt} = print st ({q & qual_filter=No} :+: " | " :+: filt)
print st q=:{qual_generators} = join st " & " qual_generators
instance print Generator
where
print st {gen_pattern,gen_expr,gen_kind}
= print st (gen_pattern :+: select :+: gen_expr)
where
select = case gen_kind of
IsListGenerator = " <- "
IsOverloadedListGenerator = " <|- "
IsArrayGenerator = " <-: "
instance print Sequence
where
print st (SQ_FromThen i e1 e2)
= print st ("[" :+: e1 :+: "," :+: e2 :+: "..]")
print st (SQ_FromThenTo i e1 e2 e3)
= print st ("[" :+: e1 :+: "," :+: e2 :+: ".." :+: e3 :+: "]")
print st (SQ_From i e)
= print st ("[" :+: e :+: "..]")
print st (SQ_FromTo i e1 e2)
= print st ("[" :+: e1 :+: ".." :+: e2 :+: "]")
// Arrays
instance print ArrayKind
where
print _ OverloadedArray = ""
print _ StrictArray = "!"
print _ UnboxedArray = "#"
// Records
instance print FieldAssignment
where
print st {bind_src,bind_dst} = print st (bind_dst :+: "=" :+: bind_src)
instance print FieldNameOrQualifiedFieldName
where
print st (FieldName id) = print st id
print st (QualifiedFieldName mod s) = abort "UNKNOWN_QUALIFIEDFIELDNAME"
// Case .. of
instance print CaseAlt
where
print st ca = print st (ca.calt_pattern :+: " = " :+: ca.calt_rhs)
// Local definitions
instance join LocalDefs
where
join st glue (LocalParsedDefs lds) = join st glue lds
join st glue _ = abort "JOIN: UNKNOWN_LOCALDEFS"
instance print ExprWithLocalDefs
where
print st {ewl_expr} = print st ewl_expr
// Guards
instance print OptGuardedAlts
where
print st (GuardedAlts ges (Yes othe))
= print st ("\n" :+: st :+: "| " :+: join st ("\n" :+: st :+: "| ") ges :+: "\n" :+: st :+: "| otherwise = " :+: othe)
print st (GuardedAlts ges No)
= join st ("\n" :+: st :+: "| ") ges
print st (UnGuardedExpr e)
= print st e
instance print GuardedExpr
where
print st {alt_guard,alt_expr}
= print {st & cpp_indent = st.cpp_indent + 1} alt_guard +++ if show_eq " = " "" +++ print st alt_expr
where
show_eq = case alt_expr of (GuardedAlts _ _) = False; _ = True
definition module CleanPrettyPrint.Util
from StdOverloaded import class zero, class +++(+++)
from StdList import isEmpty
:: CPPState =
{ cpp_indent :: Int
, cpp_parens :: Bool
}
:: PrintList = PrintNil
| E.t u: (:+:) infixl 0 t u & print t & print u
class print t where
print :: CPPState t -> String
printp :: CPPState t -> String | print t
printp st x :== if st.cpp_parens ("(" +++ print st x +++ ")") (print {st & cpp_parens=True} x)
class join e where
join :: CPPState t e -> String | print t
join_start :: CPPState t e -> String | print t
join_start st glue elems :== if (isEmpty elems) "" (print st glue) +++ join st glue elems
instance zero CPPState
instance print String, Int, [t] | print t, CPPState, PrintList
instance join [u] | print u
implementation module CleanPrettyPrint.Util
import StdEnv
instance zero CPPState
where
zero = { cpp_indent = 0
, cpp_parens = False
}
instance print String where print _ s = s
instance print Int where print _ i = toString i
instance print [t] | print t where print st ts = join st " " ts
instance print CPPState where print _ st = {'\t' \\ _ <- [1..st.cpp_indent]}
instance print PrintList
where
print _ PrintNil = ""
print st (a :+: b) = print st a +++ print st b
instance join [u] | print u
where
join _ _ [] = ""
join st _ [e] = print st e
join st glue [e:es] = print st e +++ print st glue +++ join st glue es
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment