Skip to content

Commit

Permalink
wip
Browse files Browse the repository at this point in the history
  • Loading branch information
@ollef
ollef committed May 17, 2024
1 parent 3ad3564 commit 96082b7
Show file tree
Hide file tree
Showing 3 changed files with 139 additions and 175 deletions.
288 changes: 117 additions & 171 deletions src/Low/Pretty.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,33 +2,33 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}

module Low.Pretty where

import qualified Boxity
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import qualified Data.Kind
import qualified Data.OrderedHashMap as OrderedHashMap
import qualified Data.Sequence as Seq
import qualified Data.Text.Unsafe as Text
import Index
import Low.PassBy (PassBy)
import qualified Low.PassBy as PassBy
import Low.Representation (Representation)
import qualified Low.Representation as Representation
import qualified Low.Syntax as Syntax
import Name (Name (Name))
import qualified Name
import Plicity
import Prettyprinter
import Protolude
import Protolude hiding (repr)
import Query (Query)
import qualified Query
import qualified Query.Mapped as Mapped
import Rock
import qualified Scope
import Telescope (Telescope)
import qualified Telescope

-------------------------------------------------------------------------------
-- Pretty-printing environments
Expand All @@ -45,17 +45,15 @@ extend env (Name name) =
go (Name.Surface name : [Name.Surface $ name <> show (i :: Int) | i <- [0 ..]])
where
go (name' : names)
| name' `HashMap.member` usedNames env =
go names
| name' `HashMap.member` usedNames env = go names
| otherwise =
( env
{ varNames = varNames env Seq.|> name'
, usedNames = HashMap.insert name' Nothing (usedNames env)
}
, name'
)
go [] =
panic "Pretty.extend"
go [] = panic "Pretty.extend"

empty :: Environment Void
empty =
Expand All @@ -82,59 +80,68 @@ emptyM module_ = do
-------------------------------------------------------------------------------

prettyTerm :: Int -> Environment v -> Syntax.Term v -> Doc ann
prettyTerm prec env term =
case term of
Syntax.Operand operand -> prettyOperand env operand
Syntax.Let lets ->
prettyParen (prec > letPrec) $
"let"
prettyTerm prec env = \case
Syntax.Operand operand -> prettyOperand env operand
Syntax.Let passBy name term body ->
prettyParen (prec > letPrec) do
let (env', name') = extend env name
"let"
<+> prettyPassBy passBy
<+> pretty name'
<+> "="
<+> prettyTerm 0 env term <> line <> "in"
<+> prettyTerm letPrec env' body
Syntax.Seq term1 term2 ->
prettyParen (prec > seqPrec) $
prettyTerm (seqPrec + 1) env term1
<> ";"
<> line
<> prettyTerm seqPrec env term2
Syntax.Case scrutinee branches defaultBranch ->
prettyParen (prec > casePrec) $
"case"
<+> prettyOperand env scrutinee
<+> "of"
<> line
<> indent 2 (prettyLets env lets)
Syntax.Call function args ->
prettyParen (prec > appPrec) $
prettyLiftedGlobal function env <> encloseSep lparen rparen comma [prettyOperand 0 env <$> args]
Syntax.Case scrutinee type_ branches defaultBranch ->
prettyParen (prec > casePrec) $
"case"
<+> prettyTerm 0 env scrutinee
<+> "of"
<+> "->"
<+> prettyTerm 0 env type_
<> line
<> indent
2
( vcat $
( case branches of
Syntax.ConstructorBranches constructorTypeName constructorBranches ->
[ prettyConstr env (Name.QualifiedConstructor constructorTypeName constr) <+> prettyBranch env tele
| (constr, (_, tele)) <- OrderedHashMap.toList constructorBranches
]
Syntax.LiteralBranches literalBranches ->
[ pretty lit <+> "->" <+> prettyTerm 0 env body
| (lit, (_, body)) <- OrderedHashMap.toList literalBranches
]
)
<> [ "_"
<+> "->"
<> line
<> indent 2 (prettyTerm casePrec env branch)
| Just branch <- [defaultBranch]
]
)
Syntax.Spanned _ term' ->
prettyTerm prec env term'

prettyOperand :: Environment v -> Operand v -> Doc ann
<> indent
2
( vcat $
(prettyBranch env <$> branches)
<> [ "_"
<+> "->"
<> line
<> indent 2 (prettyTerm casePrec env branch)
| Just branch <- [defaultBranch]
]
)
Syntax.Call function args ->
prettyLiftedGlobal env function <> encloseSep lparen rparen comma (prettyOperand env <$> args)
Syntax.StackAllocate operand ->
"#stack_allocate" <> lparen <> prettyOperand env operand <> rparen
Syntax.HeapAllocate con operand ->
"#heap_allocate" <> encloseSep lparen rparen comma [prettyConstr env con, prettyOperand env operand]
Syntax.Dereference operand ->
"*" <> prettyOperand env operand
Syntax.PointerTag operand ->
"#pointer_tag" <> lparen <> prettyOperand env operand <> rparen
Syntax.Offset operand1 operand2 ->
prettyOperand env operand1 <+> "+" <+> prettyOperand env operand2
Syntax.Copy dst src size ->
"#copy" <> encloseSep lparen rparen comma [prettyOperand env dst, prettyOperand env src, prettyOperand env size]
Syntax.Store dst src repr ->
"#store" <+> prettyRepresentation repr <> encloseSep lparen rparen comma [prettyOperand env dst, prettyOperand env src]
Syntax.Load src repr ->
"#load" <+> prettyRepresentation repr <> lparen <> prettyOperand env src <> rparen

prettyOperand :: Environment v -> Syntax.Operand v -> Doc ann
prettyOperand env = \case
Syntax.Var (Index i) ->
pretty $
Seq.index (varNames env) (Seq.length (varNames env) - i - 1)
Syntax.Global global ->
prettyGlobal env global
Syntax.Con constr ->
prettyConstr env constr
Syntax.Lit lit ->
pretty lit
Syntax.Global global -> prettyLiftedGlobal env global
Syntax.Literal lit -> pretty lit
Syntax.Representation repr -> prettyRepresentation repr
Syntax.Tag constr -> prettyConstr env constr

prettyGlobal :: Environment v -> Name.Qualified -> Doc ann
prettyGlobal env global = do
Expand All @@ -144,12 +151,23 @@ prettyGlobal env global = do
HashSet.toList $
HashMap.lookupDefault mempty global $
importedAliases env

case aliases of
[] ->
pretty global
alias : _ ->
pretty alias
[] -> pretty global
alias : _ -> pretty alias

prettyLiftedGlobal :: Environment v -> Name.Lifted -> Doc ann
prettyLiftedGlobal env = \case
Name.Lifted global 0 -> prettyGlobal env global
Name.Lifted global n -> prettyGlobal env global <> "$" <> pretty n

prettyPassBy :: PassBy () -> Doc ann
prettyPassBy = \case
PassBy.Value repr -> prettyRepresentation repr
PassBy.Reference () -> "ref"

prettyRepresentation :: Representation -> Doc ann
prettyRepresentation repr =
"p" <> pretty repr.pointers <> "b" <> pretty repr.nonPointerBytes

prettyConstr :: Environment v -> Name.QualifiedConstructor -> Doc ann
prettyConstr env constr = do
Expand All @@ -159,130 +177,58 @@ prettyConstr env constr = do
HashSet.toList $
HashMap.lookupDefault mempty constr $
importedConstructorAliases env

case aliases of
[] ->
pretty constr
alias : _ ->
pretty alias
[] -> pretty constr
alias : _ -> pretty alias

unambiguous :: Environment v -> Name.Surface -> Bool
unambiguous env name =
case HashMap.lookupDefault Nothing name $ usedNames env of
Nothing ->
True
Just (Scope.Name _) ->
True
Just (Scope.Constructors cs ds) ->
HashSet.size cs + HashSet.size ds == 1
Just (Scope.Ambiguous _ _) ->
False
Nothing -> True
Just (Scope.Name _) -> True
Just (Scope.Constructors cs ds) -> HashSet.size cs + HashSet.size ds == 1
Just (Scope.Ambiguous _ _) -> False

prettyBranch
:: Environment v
-> Telescope Name Syntax.Type Syntax.Term v
-> Doc ann
prettyBranch env tele =
case tele of
Telescope.Empty body ->
"->" <> line <> indent 2 (prettyTerm casePrec env body)
Telescope.Extend bindings type_ plicity tele' ->
let (env', name) = extendBindings env bindings
in Plicity.prettyAnnotation plicity
<> "("
<> pretty name
<+> ":"
<+> prettyTerm 0 env type_
<> ")"
<+> prettyBranch env' tele'

-------------------------------------------------------------------------------

prettyDefinition :: Environment Void -> Name.Qualified -> Syntax.Definition -> Doc ann
prettyDefinition env name def =
case def of
Syntax.TypeDeclaration type_ ->
prettyGlobal env name <+> ":" <+> prettyTerm 0 env type_
Syntax.ConstantDefinition term ->
prettyGlobal env name <+> "=" <+> prettyTerm 0 env term
Syntax.DataDefinition boxity tele ->
Boxity.prettyAnnotation boxity "data" <+> prettyGlobal env name <+> prettyConstructorDefinitions env tele

prettyConstructorDefinitions
:: Environment v
-> Telescope Binding Syntax.Type Syntax.ConstructorDefinitions v
-> Doc ann
prettyConstructorDefinitions env tele =
case tele of
Telescope.Empty (Syntax.ConstructorDefinitions constrs) ->
"where"
<> line
<> indent
2
( vcat
[ pretty constr <+> ":" <+> prettyTerm 0 env type_
| (constr, type_) <- OrderedHashMap.toList constrs
]
)
Telescope.Extend _ _ Implicit _ ->
"forall" <+> prettyConstructorDefinitionsImplicit env tele
Telescope.Extend binding type_ plicity tele' ->
let (env', name) = extendBinding env binding
in Plicity.prettyAnnotation plicity
<> "("
<> pretty name
<+> ":"
<+> prettyTerm 0 env type_
<> ")"
<+> prettyConstructorDefinitions env' tele'

prettyConstructorDefinitionsImplicit
:: Environment v
-> Telescope Binding Syntax.Type Syntax.ConstructorDefinitions v
-> Syntax.Branch v
-> Doc ann
prettyConstructorDefinitionsImplicit env tele =
case tele of
Telescope.Empty _ ->
prettyConstructorDefinitions env tele
Telescope.Extend binding type_ Implicit tele' ->
let (env', name) = extendBinding env binding
in lparen
<> pretty name
<+> ":"
<+> prettyTerm 0 env type_
<> rparen
<> prettyConstructorDefinitionsImplicit env' tele'
Telescope.Extend {} ->
"." <+> prettyConstructorDefinitions env tele
prettyBranch env = \case
Syntax.ConstructorBranch constr body ->
prettyConstr env constr <+> "->" <> line <> indent 2 (prettyTerm casePrec env body)
Syntax.LiteralBranch lit body ->
pretty lit <+> "->" <> line <> indent 2 (prettyTerm casePrec env body)

-------------------------------------------------------------------------------

prettyPattern :: Int -> Environment v -> Pattern -> Doc ann
prettyPattern prec env pattern_ =
case pattern_ of
Pattern.Wildcard ->
"_"
Pattern.Con constr [] ->
prettyConstr env constr
Pattern.Con constr patterns ->
prettyParen (prec > appPrec) $
hsep $
prettyConstr env constr
: [ Plicity.prettyAnnotation plicity <> prettyPattern (appPrec + 1) env pattern'
| (plicity, pattern') <- patterns
]
Pattern.Lit lit ->
pretty lit
prettyDefinition :: MonadFetch Query m => Environment Void -> Name.Lifted -> Syntax.Definition -> m (Doc ann)
prettyDefinition env name def = do
signature <- fetch $ Query.LowSignature name
pure case (def, signature) of
(Syntax.ConstantDefinition term, Syntax.ConstantSignature repr) ->
prettyLiftedGlobal env name <+> prettyRepresentation repr <+> "=" <+> prettyTerm 0 env term
(Syntax.ConstantDefinition _, _) -> panic "definition signature mismatch"
(Syntax.FunctionDefinition function, Syntax.FunctionSignature passArgsBy passReturnBy) ->
prettyLiftedGlobal env name <+> prettyPassBy passReturnBy <+> "=" <+> "\\" <+> prettyFunction env passArgsBy function
(Syntax.FunctionDefinition _, _) -> panic "definition signature mismatch"

prettyFunction :: Environment v -> [PassBy ()] -> Syntax.Function v -> Doc ann
prettyFunction env passArgsBy function = case (passArgsBy, function) of
([], Syntax.Body body) -> " ->" <> line <> prettyTerm 0 env body
([], _) -> panic "function signature mismatch"
(passArgBy : passArgsBy', Syntax.Parameter name function') -> do
let (env', name') = extend env name
"(" <> prettyPassBy passArgBy
<+> pretty name' <> ")" <> prettyFunction env' passArgsBy' function'
(_ : _, _) -> panic "function signature mismatch"

-------------------------------------------------------------------------------

prettyParen :: Bool -> Doc a -> Doc a
prettyParen True doc = lparen <> doc <> rparen
prettyParen False doc = doc

funPrec, appPrec, lamPrec, letPrec, casePrec :: Int
funPrec = 0
appPrec = 10
lamPrec = 0
letPrec = 0
casePrec = 0
letPrec, seqPrec, casePrec :: Int
letPrec = 1
seqPrec = 0
casePrec = 1
2 changes: 1 addition & 1 deletion src/Low/Syntax.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,7 +18,7 @@ data Term v
| Case !(Operand v) [Branch v] (Maybe (Term v))
| Call !Name.Lifted [Operand v]
| StackAllocate !(Operand v)
| HeapAllocate !Int !(Operand v)
| HeapAllocate !Name.QualifiedConstructor !(Operand v)
| Dereference !(Operand v)
| PointerTag !(Operand v)
| Offset !(Operand v) !(Operand v)
Expand Down
Loading

0 comments on commit 96082b7

Please sign in to comment.