diff --git a/examples/demo/Demo.juvix b/examples/demo/Demo.juvix index 2817794680..cfd1c0659a 100644 --- a/examples/demo/Demo.juvix +++ b/examples/demo/Demo.juvix @@ -18,7 +18,9 @@ log2 (n : Nat) : Nat := | else := log2 (div n 2) + 1; type Tree (A : Type) := - | leaf@{element : A} + | leaf@{ + element : A; + } | node@{ element : A; left : Tree A; diff --git a/examples/milestone/TicTacToe/Logic/Board.juvix b/examples/milestone/TicTacToe/Logic/Board.juvix index 6dbf5f5d0e..3539e24af9 100644 --- a/examples/milestone/TicTacToe/Logic/Board.juvix +++ b/examples/milestone/TicTacToe/Logic/Board.juvix @@ -7,7 +7,10 @@ import Logic.Symbol open public; import Logic.Extra open; --- A 3x3 grid of ;Square;s -type Board := mkBoard@{squares : List (List Square)}; +type Board := + mkBoard@{ + squares : List (List Square); + }; --- Returns the list of numbers corresponding to the empty ;Square;s possibleMoves : (list : List Square) -> List Nat diff --git a/examples/milestone/TicTacToe/Logic/Square.juvix b/examples/milestone/TicTacToe/Logic/Square.juvix index d4a40482f0..2387adcc84 100644 --- a/examples/milestone/TicTacToe/Logic/Square.juvix +++ b/examples/milestone/TicTacToe/Logic/Square.juvix @@ -7,9 +7,13 @@ import Logic.Extra open; --- A square is each of the holes in a board type Square := | --- An empty square has a ;Nat; that uniquely identifies it - empty@{id : Nat} + empty@{ + id : Nat; + } | --- An occupied square has a ;Symbol; in it - occupied@{player : Symbol}; + occupied@{ + player : Symbol; + }; instance eqSquareI : Eq Square := diff --git a/juvix-stdlib b/juvix-stdlib index 9534bd214d..fde9ac2353 160000 --- a/juvix-stdlib +++ b/juvix-stdlib @@ -1 +1 @@ -Subproject commit 9534bd214df2983f4f5918ddcff3703f63bd1de1 +Subproject commit fde9ac23534fe1c0ba3f69714233dbd1d3934a9c diff --git a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs index 00a75e8937..eec28fb658 100644 --- a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs +++ b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs @@ -584,7 +584,7 @@ goConstructors cc = do srcPart :: Sem r Html srcPart = do - sig' <- ppHelper (ppConstructorDef False (set constructorDoc Nothing c)) + sig' <- ppHelper (ppCode (set constructorDoc Nothing c)) return $ td ! Attr.class_ "src" diff --git a/src/Juvix/Compiler/Concrete/Language/Base.hs b/src/Juvix/Compiler/Concrete/Language/Base.hs index 1721130356..ecc0df54a5 100644 --- a/src/Juvix/Compiler/Concrete/Language/Base.hs +++ b/src/Juvix/Compiler/Concrete/Language/Base.hs @@ -3000,6 +3000,7 @@ makeLenses ''MarkdownInfo makeLenses ''Deriving makePrisms ''NamedArgumentNew +makePrisms ''ConstructorRhs makePrisms ''FunctionDefNameParsed functionDefLhs :: FunctionDef s -> FunctionLhs s @@ -3154,6 +3155,35 @@ instance HasLoc ScopedIden where instance (SingI s) => HasLoc (InductiveParameters s) where getLoc i = getLocSymbolType (i ^. inductiveParametersNames . _head1) <>? (getLocExpressionType <$> (i ^? inductiveParametersRhs . _Just . inductiveParametersType)) +getLocTypeSig :: (SingI s) => TypeSig s -> Maybe Interval +getLocTypeSig TypeSig {..} = + (getLocSpan <$> nonEmpty _typeSigArgs) + ?<>? (getLocExpressionType <$> _typeSigRetType) + +instance HasLoc (RhsRecord s) where + getLoc RhsRecord {..} = + let (kat, kl, kr) = _rhsRecordDelim ^. unIrrelevant + in (getLoc <$> kat) ?<> getLoc kl <> getLoc kr + +instance (SingI s) => HasLoc (RhsGadt s) where + getLoc RhsGadt {..} = fromJust (getLocTypeSig _rhsGadtTypeSig) + +getLocRhsAdt :: (SingI s) => RhsAdt s -> Maybe Interval +getLocRhsAdt RhsAdt {..} = getLocSpan' getLocExpressionType <$> nonEmpty _rhsAdtArguments + +getLocConstructorRhs :: (SingI s) => ConstructorRhs s -> Maybe Interval +getLocConstructorRhs = \case + ConstructorRhsGadt a -> Just (getLoc a) + ConstructorRhsAdt a -> getLocRhsAdt a + ConstructorRhsRecord a -> Just (getLoc a) + +instance (SingI s) => HasLoc (ConstructorDef s) where + getLoc ConstructorDef {..} = + (getLoc <$> (_constructorPipe ^. unIrrelevant)) + ?<> ( getLocSymbolType _constructorName + <>? getLocConstructorRhs _constructorRhs + ) + instance HasLoc (InductiveDef s) where getLoc i = (getLoc <$> i ^. inductivePositive) ?<> getLoc (i ^. inductiveKw) @@ -3602,11 +3632,6 @@ data ApeLeaf | ApeLeafPatternArg PatternArg | ApeLeafAtom (AnyStage ExpressionAtom) -_ConstructorRhsRecord :: Traversal' (ConstructorRhs s) (RhsRecord s) -_ConstructorRhsRecord f rhs = case rhs of - ConstructorRhsRecord r -> ConstructorRhsRecord <$> f r - _ -> pure rhs - _DefinitionSyntax :: Traversal' (Definition s) (SyntaxDef s) _DefinitionSyntax f x = case x of DefinitionSyntax r -> DefinitionSyntax <$> f r diff --git a/src/Juvix/Compiler/Concrete/Print/Base.hs b/src/Juvix/Compiler/Concrete/Print/Base.hs index 656a817066..86159ee63a 100644 --- a/src/Juvix/Compiler/Concrete/Print/Base.hs +++ b/src/Juvix/Compiler/Concrete/Print/Base.hs @@ -677,36 +677,33 @@ ppCaseBranch :: forall r s. (Members '[ExactPrint, Reader Options] r, SingI s) = ppCaseBranch isTop CaseBranch {..} = do let pat' = ppPatternParensType _caseBranchPattern rhs' = ppCaseBranchRhs isTop _caseBranchRhs - pat' <+> rhs' + pipe' = ppCode <$> (_caseBranchPipe ^. unIrrelevant) + pipe' pat' <+> rhs' ppCase :: forall r s. (Members '[ExactPrint, Reader Options] r, SingI s) => IsTop -> Case s -> Sem r () -ppCase isTop Case {..} = do - let exp' = ppExpressionType _caseExpression - align $ ppCode _caseKw <> oneLineOrNextBlock exp' <> ppCode _caseOfKw <> ppBranches _caseBranches +ppCase isTop c = do + let exp' = ppExpressionType (c ^. caseExpression) + + align $ ppCode (c ^. caseKw) <> oneLineOrNextBlock exp' <> ppCode (c ^. caseOfKw) <> ppBranches branches' where + branches' = insertFirstPipe1 (caseBranchPipe . unIrrelevant) (c ^. caseBranches) + ppBranches :: NonEmpty (CaseBranch s) -> Sem r () ppBranches = \case b :| [] -> case isTop of - Top -> oneLineOrNext (ppCaseBranch' True Top b) - NotTop -> space <> oneLineOrNextBraces (ppCaseBranch' True NotTop b) + Top -> oneLineOrNext (ppCaseBranch' Top b) + NotTop -> space <> oneLineOrNextBraces (ppCaseBranch' NotTop b) _ -> case isTop of Top -> do let brs = - vsepHard (ppCaseBranch' False NotTop <$> NonEmpty.init _caseBranches) + vsepHard (ppCaseBranch' NotTop <$> NonEmpty.init branches') <> hardline - <> ppCaseBranch' False Top (NonEmpty.last _caseBranches) + <> ppCaseBranch' Top (NonEmpty.last branches') hardline <> indent brs - NotTop -> space <> braces (blockIndent (vsepHard (ppCaseBranch' False NotTop <$> _caseBranches))) - - ppCaseBranch' :: Bool -> IsTop -> CaseBranch s -> Sem r () - ppCaseBranch' singleBranch lastTopBranch b = pipeHelper ppCaseBranch lastTopBranch b - where - pipeHelper :: Maybe (Sem r ()) - pipeHelper - | singleBranch = Nothing - | otherwise = Just $ case b ^. caseBranchPipe . unIrrelevant of - Just p -> ppCode p - Nothing -> ppCode Kw.kwPipe + NotTop -> space <> braces (blockIndent (vsepHard (ppCaseBranch' NotTop <$> branches'))) + + ppCaseBranch' :: IsTop -> CaseBranch s -> Sem r () + ppCaseBranch' lastTopBranch b = ppCaseBranch lastTopBranch b instance (SingI s) => PrettyPrint (IfBranch s 'BranchIfBool) where ppCode IfBranch {..} = do @@ -863,11 +860,20 @@ instance (SingI s) => PrettyPrint (Lambda s) where ppCode Lambda {..} = do let lambdaKw' = ppCode _lambdaKw braces' = uncurry enclose (over both ppCode (_lambdaBraces ^. unIrrelevant)) - lambdaClauses' = braces' $ case _lambdaClauses of + lambdaClauses' = braces' $ case insertFirstPipe1 (lambdaPipe . unIrrelevant) _lambdaClauses of s :| [] -> ppCode s - _ -> blockIndent (vsepHard (ppCode <$> _lambdaClauses)) + clauses' -> blockIndent (vsepHard (ppCode <$> clauses')) lambdaKw' <> lambdaClauses' +-- | Inserts a pipe to the first element when it is not already there and the +-- list has more than one element +insertFirstPipe1 :: (HasLoc a) => Lens' a (Maybe KeywordRef) -> NonEmpty a -> NonEmpty a +insertFirstPipe1 pipekw l = case l of + _ :| [] -> l + a :| as -> + let p = run (runReader (getLoc a) (Gen.kw Kw.kwPipe)) + in over pipekw (<|> Just p) a :| as + instance PrettyPrint Precedence where ppCode = \case PrecArrow -> noLoc (pretty ("-ω" :: Text)) @@ -1144,7 +1150,8 @@ instance (SingI s) => PrettyPrint (SigArg s) where instance (SingI s) => PrettyPrint (Deriving s) where ppCode Deriving {..} = - ppCode _derivingKw + (ppCode <$> _derivingPragmas) + ?<> ppCode _derivingKw <+> ppCode _derivingFunLhs instance (SingI s) => PrettyPrint (TypeSig s) where @@ -1447,8 +1454,7 @@ instance (SingI s) => PrettyPrint (RhsRecord s) where ppCode RhsRecord {..} = do let Irrelevant (_, l, r) = _rhsRecordDelim fields' - | [] <- _rhsRecordStatements = mempty - | [f] <- _rhsRecordStatements = ppCode f + | null _rhsRecordStatements = mempty | otherwise = ppBlock _rhsRecordStatements ppCode kwAt <> ppCode l <> fields' <> ppCode r @@ -1462,36 +1468,30 @@ instance (SingI s) => PrettyPrint (ConstructorRhs s) where ConstructorRhsRecord r -> ppCode r ConstructorRhsAdt r -> ppCode r -ppConstructorDef :: forall s r. (SingI s, Members '[ExactPrint, Reader Options] r) => Bool -> ConstructorDef s -> Sem r () -ppConstructorDef singleConstructor ConstructorDef {..} = do - let constructorName' = annDef _constructorName (ppSymbolType _constructorName) - constructorRhs' = constructorRhsHelper _constructorRhs - doc' = ppCode <$> _constructorDoc - pragmas' = ppCode <$> _constructorPragmas - pipeHelper nestHelper (doc' ?<> pragmas' ?<> constructorName' <> constructorRhs') - where - constructorRhsHelper :: ConstructorRhs s -> Sem r () - constructorRhsHelper r = spaceMay <> ppCode r - where - spaceMay = case r of - ConstructorRhsGadt {} -> mempty - ConstructorRhsRecord {} -> mempty - ConstructorRhsAdt a - | null (a ^. rhsAdtArguments) -> mempty - | otherwise -> space - - nestHelper :: Sem r () -> Sem r () - nestHelper - | singleConstructor = id - | otherwise = nest - - -- we use this helper so that comments appear before the first optional pipe if the pipe was omitted - pipeHelper :: Maybe (Sem r ()) - pipeHelper - | singleConstructor = Nothing - | otherwise = Just $ case _constructorPipe ^. unIrrelevant of - Just p -> ppCode p - Nothing -> ppCode Kw.kwPipe +instance (SingI s) => PrettyPrint (ConstructorDef s) where + ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => ConstructorDef s -> Sem r () + ppCode ConstructorDef {..} = do + let constructorName' = annDef _constructorName (ppSymbolType _constructorName) + constructorRhs' = constructorRhsHelper _constructorRhs + doc' = ppCode <$> _constructorDoc + pragmas' = ppCode <$> _constructorPragmas + pipe = ppCode <$> (_constructorPipe ^. unIrrelevant) + + nestCond :: Sem r () -> Sem r () + nestCond x = case _constructorPipe ^. unIrrelevant of + Just p -> printCommentsUntil (getLoc p) >> nest x + Nothing -> x + nestCond (pipe doc' ?<> pragmas' ?<> constructorName' <> constructorRhs') + where + constructorRhsHelper :: ConstructorRhs s -> Sem r () + constructorRhsHelper r = spaceMay <> ppCode r + where + spaceMay = case r of + ConstructorRhsGadt {} -> mempty + ConstructorRhsRecord {} -> mempty + ConstructorRhsAdt a + | null (a ^. rhsAdtArguments) -> mempty + | otherwise -> space ppInductiveSignature :: (SingI s) => PrettyPrinting (InductiveDef s) ppInductiveSignature InductiveDef {..} = do @@ -1518,7 +1518,7 @@ instance (SingI s) => PrettyPrint (InductiveDef s) where ppCode d@InductiveDef {..} = do let doc' = ppCode <$> _inductiveDoc pragmas' = ppCode <$> _inductivePragmas - constrs' = ppConstructorBlock _inductiveConstructors + constrs' = ppConstructorBlock (insertFirstPipe1 (constructorPipe . unIrrelevant) _inductiveConstructors) sig' = ppInductiveSignature d doc' ?<> pragmas' @@ -1528,8 +1528,9 @@ instance (SingI s) => PrettyPrint (InductiveDef s) where where ppConstructorBlock :: NonEmpty (ConstructorDef s) -> Sem r () ppConstructorBlock = \case - c :| [] -> oneLineOrNext (ppConstructorDef True c) - cs -> line <> indent (vsep (ppConstructorDef False <$> cs)) + c :| [] + | not (has (constructorRhs . _ConstructorRhsRecord . rhsRecordStatements . each) c) -> oneLineOrNext (ppCode c) + cs -> hardline <> indent (vsep (ppCode <$> cs)) instance (SingI s) => PrettyPrint (ProjectionDef s) where ppCode ProjectionDef {..} = diff --git a/src/Juvix/Data/Loc.hs b/src/Juvix/Data/Loc.hs index 2140fef45d..e655f564e9 100644 --- a/src/Juvix/Data/Loc.hs +++ b/src/Juvix/Data/Loc.hs @@ -103,7 +103,10 @@ instance HasLoc Interval where -- | The items are assumed to be in order with respect to their location. getLocSpan :: (HasLoc t) => NonEmpty t -> Interval -getLocSpan l = getLoc (head l) <> getLoc (last l) +getLocSpan = getLocSpan' getLoc + +getLocSpan' :: (t -> Interval) -> NonEmpty t -> Interval +getLocSpan' gl l = gl (head l) <> gl (last l) -- | Assumes the file is the same instance Semigroup Interval where diff --git a/tests/positive/Format.juvix b/tests/positive/Format.juvix index a0b4e67916..109c00765d 100644 --- a/tests/positive/Format.juvix +++ b/tests/positive/Format.juvix @@ -53,7 +53,7 @@ case4 (n : Nat) : Nat := | zero := case n of {x := zero} | _ := zero; --- -- case with application subject +-- case with application subject case5 (n : Nat) : Nat := case id n of x := zero; -- qualified commas @@ -274,7 +274,8 @@ module Comments; type color : Type := -- comment before pipe | black : color - | white : color + | --- documentation for white + white : color | red : color -- comment before pipe | blue : color; @@ -309,7 +310,10 @@ module Traits; import Stdlib.Prelude open hiding {Show; mkShow; module Show}; trait - type Show A := mkShow@{show : A → String}; + type Show A := + mkShow@{ + show : A → String; + }; instance showStringI : Show String := @@ -396,6 +400,18 @@ module RecordFieldPragmas; }; end; +module MultiConstructorRecord; + type Tree (A : Type) := + | leaf@{ + element : A; + } + | node@{ + element : A; + left : Tree A; + right : Tree A; + }; +end; + longLongLongArg : Int := 0; longLongLongListArg : List Int := []; diff --git a/tests/positive/InstanceImport/M.juvix b/tests/positive/InstanceImport/M.juvix index 47fe920568..f1c6049e05 100644 --- a/tests/positive/InstanceImport/M.juvix +++ b/tests/positive/InstanceImport/M.juvix @@ -1,7 +1,10 @@ module M; trait -type T A := mkT@{pp : A → A}; +type T A := + mkT@{ + pp : A → A; + }; type Unit := unit; diff --git a/tests/positive/Internal/Positivity2/main.juvix b/tests/positive/Internal/Positivity2/main.juvix index 125c72a88f..1a95f89781 100644 --- a/tests/positive/Internal/Positivity2/main.juvix +++ b/tests/positive/Internal/Positivity2/main.juvix @@ -53,8 +53,13 @@ module E6; | zero | suc Nat; - type Box := mkBox@{unbox : Nat}; + type Box := + mkBox@{ + unbox : Nat; + }; type Foldable := - mkFoldable@{for : {B : Type} -> (B -> Nat -> B) -> B -> Box -> B}; + mkFoldable@{ + for : {B : Type} -> (B -> Nat -> B) -> B -> Box -> B; + }; end; diff --git a/tests/positive/RecordProjectionSignature.juvix b/tests/positive/RecordProjectionSignature.juvix index db7facb8fd..f96324e852 100644 --- a/tests/positive/RecordProjectionSignature.juvix +++ b/tests/positive/RecordProjectionSignature.juvix @@ -3,7 +3,10 @@ module RecordProjectionSignature; import Stdlib.Data.Nat open; trait -type R A := mkR@{fun : (n : A) -> A}; +type R A := + mkR@{ + fun : (n : A) -> A; + }; f {{R Nat}} : Nat := R.fun@{ diff --git a/tests/positive/Termination/issue2414.juvix b/tests/positive/Termination/issue2414.juvix index 845c17b989..a60e95c598 100644 --- a/tests/positive/Termination/issue2414.juvix +++ b/tests/positive/Termination/issue2414.juvix @@ -3,7 +3,10 @@ module issue2414; import Stdlib.Prelude open; trait -type T := mkT@{tt : T}; +type T := + mkT@{ + tt : T; + }; f {{T}} : Nat → Nat | zero := zero diff --git a/tests/positive/TypeSignatures.juvix b/tests/positive/TypeSignatures.juvix index 18fdcd4706..3b76569b9d 100644 --- a/tests/positive/TypeSignatures.juvix +++ b/tests/positive/TypeSignatures.juvix @@ -9,7 +9,10 @@ g (x : Nat) : Nat := x := x; }; -type R := mkR@{rf (x : Nat) : Nat}; +type R := + mkR@{ + rf (x : Nat) : Nat; + }; type R' := mkR' (rf : Nat -> Nat) : R';