Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Tell Fourmolu about Foreword operator fixities #1305

Merged
merged 2 commits into from
Nov 27, 2024
Merged

Tell Fourmolu about Foreword operator fixities #1305

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
523488d
style: Tell Fourmolu about Foreword operator fixities
georgefst Nov 25, 2024
4353938
style: Use simpler approach to specifying operator fixities for Four…
georgefst Nov 27, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
8 changes: 8 additions & 0 deletions fourmolu.yaml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -8,3 +8,11 @@ haddock-style: single-line
newlines-between-decls: 1
single-constraint-parens: auto

# Foreword might not actually re-export _all_ operators from these modules,
# but this is a lot nicer than explicitly listing all of the ones that it does.
# For some reason they're not picked up with `module Foreword exports Protolude`.
reexports:
- module Foreword exports Prelude
- module Foreword exports Control.Applicative
- module Foreword exports Data.Function
- module Foreword exports Data.Monoid
75 changes: 36 additions & 39 deletions primer-api/src/Primer/API.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -588,9 +588,8 @@ deleteSession = logAPI (noError DeleteSession) $ \sid -> do
listSessions :: (MonadIO m, MonadAPILog l m) => OffsetLimit -> PrimerM m (Page Session)
listSessions = logAPI (noError ListSessions) $ \ol -> do
q <- asks dbOpQueue
callback <- liftIO
$ atomically
$ do
callback <- liftIO $
atomically $ do
cb <- newEmptyTMVar
writeTBQueue q $ Database.ListSessions ol cb
pure cb
Expand All @@ -603,9 +602,8 @@ findSessions :: (MonadIO m, MonadAPILog l m) => Text -> OffsetLimit -> PrimerM m
findSessions = curry $ logAPI (noError FindSessions) $ \case
(substr, ol) -> do
q <- asks dbOpQueue
callback <- liftIO
$ atomically
$ do
callback <- liftIO $
atomically $ do
cb <- newEmptyTMVar
writeTBQueue q $ Database.FindSessions substr ol cb
pure cb
Expand Down Expand Up @@ -793,9 +791,8 @@ viewProg p =
, constructors = case d of
TypeDef.TypeDefPrim _ -> Nothing
TypeDef.TypeDefAST t ->
Just
$ astTypeDefConstructors t
<&> \(TypeDef.ValCon nameCon argsCon) ->
Just $
astTypeDefConstructors t <&> \(TypeDef.ValCon nameCon argsCon) ->
ValCon
{ name = nameCon
, fields = viewTreeType' . over _typeKindMeta (show . view _id) . over _typeMeta (show . view _id) <$> argsCon
Expand Down Expand Up @@ -875,8 +872,8 @@ viewTreeExpr e0 = case e0 of
, body = NoBody Flavor.Lam
, childTrees = [RecordPair EdgeFlavor.Lam $ viewTreeExpr e]
, rightChild =
Just
$ RecordPair
Just $
RecordPair
EdgeFlavor.Bind
Tree
{ nodeId = bindingNodeId
Expand All @@ -891,8 +888,8 @@ viewTreeExpr e0 = case e0 of
, body = NoBody Flavor.LAM
, childTrees = [RecordPair EdgeFlavor.Lam $ viewTreeExpr e]
, rightChild =
Just
$ RecordPair
Just $
RecordPair
EdgeFlavor.Bind
Tree
{ nodeId = bindingNodeId
Expand All @@ -916,8 +913,8 @@ viewTreeExpr e0 = case e0 of
, body = NoBody Flavor.Let
, childTrees = [RecordPair EdgeFlavor.LetEqual $ viewTreeExpr e1, RecordPair EdgeFlavor.LetIn $ viewTreeExpr e2]
, rightChild =
Just
$ RecordPair
Just $
RecordPair
EdgeFlavor.Bind
Tree
{ nodeId = bindingNodeId
Expand All @@ -932,8 +929,8 @@ viewTreeExpr e0 = case e0 of
, body = NoBody Flavor.LetType
, childTrees = [RecordPair EdgeFlavor.LetEqual $ viewTreeExpr e, RecordPair EdgeFlavor.LetIn $ viewTreeType t]
, rightChild =
Just
$ RecordPair
Just $
RecordPair
EdgeFlavor.Bind
Tree
{ nodeId = bindingNodeId
Expand All @@ -948,8 +945,8 @@ viewTreeExpr e0 = case e0 of
, body = NoBody Flavor.Letrec
, childTrees = [RecordPair EdgeFlavor.LetEqual $ viewTreeExpr e1, RecordPair EdgeFlavor.Ann $ viewTreeType t, RecordPair EdgeFlavor.LetIn $ viewTreeExpr e2]
, rightChild =
Just
$ RecordPair
Just $
RecordPair
EdgeFlavor.Bind
Tree
{ nodeId = bindingNodeId
Expand Down Expand Up @@ -1111,8 +1108,8 @@ viewTreeType' t0 = case t0 of
, body = NoBody Flavor.TForall
, childTrees = [RecordPair EdgeFlavor.ForallKind $ viewTreeKind' k, RecordPair EdgeFlavor.Forall $ viewTreeType' t]
, rightChild =
Just
$ RecordPair
Just $
RecordPair
EdgeFlavor.Bind
Tree
{ nodeId = bindingNodeId
Expand All @@ -1127,8 +1124,8 @@ viewTreeType' t0 = case t0 of
, body = NoBody Flavor.TLet
, childTrees = [RecordPair EdgeFlavor.LetEqual $ viewTreeType' t, RecordPair EdgeFlavor.LetIn $ viewTreeType' b]
, rightChild =
Just
$ RecordPair
Just $
RecordPair
EdgeFlavor.Bind
Tree
{ nodeId = bindingNodeId
Expand Down Expand Up @@ -1257,8 +1254,8 @@ evalFull' = curry4 $ logAPI (noError EvalFull') $ \(sid, lim, closed, d) -> do
-- evaluation step will be to inline this definition, removing the node.
let e = create' $ DSL.gvar d
x <-
handleEvalFullRequest
$ EvalFullReq
handleEvalFullRequest $
EvalFullReq
{ evalFullReqExpr = e
, evalFullCxtDir = Chk
, evalFullMaxSteps = fromMaybe 10 lim
Expand Down Expand Up @@ -1343,8 +1340,8 @@ evalInterp' = curry $ logAPI (noError EvalInterp') $ \(sid, d) -> do
-- evaluation step will be to inline this definition, removing the node.
let e = create' $ DSL.gvar d
(App.EvalInterpRespNormal e') <-
handleEvalInterpRequest
$ EvalInterpReq
handleEvalInterpRequest $
EvalInterpReq
{ expr = e
, dir = Chk
}
Expand Down Expand Up @@ -1437,8 +1434,8 @@ evalBoundedInterp' = curry3 $ logAPI (noError EvalBoundedInterp') $ \(sid, timeo
-- evaluation step will be to inline this definition, removing the node.
let e = create' $ DSL.gvar d
x <-
handleEvalBoundedInterpRequest
$ EvalBoundedInterpReq
handleEvalBoundedInterpRequest $
EvalBoundedInterpReq
{ expr = e
, dir = Chk
, timeout = fromMaybe (MicroSec 10) timeout
Expand Down Expand Up @@ -1467,8 +1464,8 @@ createDefinition ::
Maybe Text ->
PrimerM m Prog
createDefinition =
curry3
$ logAPI (noError CreateDef) \(sid, moduleName, mDefName) ->
curry3 $
logAPI (noError CreateDef) \(sid, moduleName, mDefName) ->
edit sid (App.Edit [App.CreateDef moduleName mDefName])
>>= either (throwM . AddDefError moduleName mDefName) (pure . viewProg)

Expand All @@ -1480,8 +1477,8 @@ createTypeDef ::
[ValConName] ->
PrimerM m Prog
createTypeDef =
curry3
$ logAPI (noError CreateTypeDef) \(sid, tyconName, valcons) ->
curry3 $
logAPI (noError CreateTypeDef) \(sid, tyconName, valcons) ->
edit sid (App.Edit [App.AddTypeDef tyconName $ ASTTypeDef [] (map (`TypeDef.ValCon` []) valcons) []])
>>= either (throwM . AddTypeDefError tyconName valcons) (pure . viewProg)

Expand Down Expand Up @@ -1530,8 +1527,8 @@ actionOptions = curry4 $ logAPI (noError ActionOptions) $ \(sid, level, selectio
allDefs = progDefMap prog
allTypeDefs = progTypeDefMap prog
def <- snd <$> findASTTypeOrTermDef prog selection
maybe (throwM $ ActionOptionsNoID selection) pure
$ Available.options allTypeDefs allDefs (progCxt prog) level def selection action
maybe (throwM $ ActionOptionsNoID selection) pure $
Available.options allTypeDefs allDefs (progCxt prog) level def selection action

findASTDef :: MonadThrow m => Map GVarName (Editable, Def.Def) -> GVarName -> m (Editable, ASTDef)
findASTDef allDefs def = case allDefs Map.!? def of
Expand Down Expand Up @@ -1562,8 +1559,8 @@ applyActionNoInput = curry3 $ logAPI (noError ApplyActionNoInput) $ \(sid, selec
prog <- getProgram sid
def <- snd <$> findASTTypeOrTermDef prog selection
actions <-
either (throwM . ToProgActionError (Available.NoInput action)) pure
$ toProgActionNoInput (progDefMap prog) def selection action
either (throwM . ToProgActionError (Available.NoInput action)) pure $
toProgActionNoInput (progDefMap prog) def selection action
applyActions sid actions

applyActionInput ::
Expand All @@ -1576,8 +1573,8 @@ applyActionInput = curry3 $ logAPI (noError ApplyActionInput) $ \(sid, body, act
prog <- getProgram sid
def <- snd <$> findASTTypeOrTermDef prog body.selection
actions <-
either (throwM . ToProgActionError (Available.Input action)) pure
$ toProgActionInput def body.selection body.option action
either (throwM . ToProgActionError (Available.Input action)) pure $
toProgActionInput def body.selection body.option action
applyActions sid actions

data ApplyActionBody = ApplyActionBody
Expand Down
116 changes: 58 additions & 58 deletions primer-api/test/Tests/API.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -808,30 +808,30 @@ test_eval_undo =
Just e@EmptyHole{} -> pure $ getID e
_ -> liftIO $ assertFailure "unexpected form of main"
_ <-
expectSuccess
$ edit sid
$ Edit
[ MoveToDef $ qualifyName scope "main"
, BodyAction
[ SetCursor i1
, InsertSaturatedVar $ GlobalVarRef Integer.even
]
]
expectSuccess $
edit sid $
Edit
[ MoveToDef $ qualifyName scope "main"
, BodyAction
[ SetCursor i1
, InsertSaturatedVar $ GlobalVarRef Integer.even
]
]
step "insert 4"
i2 <-
getMain >>= \case
Just (App _ _ e) -> pure $ getID e
_ -> liftIO $ assertFailure "unexpected form of main"
_ <-
expectSuccess
$ edit sid
$ Edit
[ MoveToDef $ qualifyName scope "main"
, BodyAction
[ SetCursor i2
, ConstructPrim $ PrimInt 4
]
]
expectSuccess $
edit sid $
Edit
[ MoveToDef $ qualifyName scope "main"
, BodyAction
[ SetCursor i2
, ConstructPrim $ PrimInt 4
]
]
step "get edited App"
app0 <- getApp sid
step "undo"
Expand Down Expand Up @@ -876,12 +876,12 @@ test_selectioninfo =
Just e@EmptyHole{} -> pure $ getID e
_ -> assertFailure' $ "unexpected form of " <> toS (unName d)
_ <-
expectSuccess
$ edit sid
$ Edit
[ MoveToDef $ qualifyName scope d
, BodyAction $ SetCursor i : as
]
expectSuccess $
edit sid $
Edit
[ MoveToDef $ qualifyName scope d
, BodyAction $ SetCursor i : as
]
pure ()
let mkType d as = do
_ <- expectSuccess $ edit sid $ Edit [CreateDef scope $ Just $ unName d]
Expand All @@ -890,12 +890,12 @@ test_selectioninfo =
Just e@TEmptyHole{} -> pure $ getID e
_ -> assertFailure' $ "unexpected form of " <> toS (unName d)
_ <-
expectSuccess
$ edit sid
$ Edit
[ MoveToDef $ qualifyName scope d
, SigAction $ SetCursor i : as
]
expectSuccess $
edit sid $
Edit
[ MoveToDef $ qualifyName scope d
, SigAction $ SetCursor i : as
]
pure ()

step "tm1 :: ? = not {? Zero ?}"
Expand All @@ -917,15 +917,15 @@ test_selectioninfo =
e -> assertFailure' $ "unexpected form of tm1: " <> show e
step "tm1 mismatch info"
tm1tk <-
getSelectionTypeOrKind sid
$ SelectionDef
$ DefSelection (qualifyName scope "tm1")
$ Just
$ NodeSelection BodyNode htm1
getSelectionTypeOrKind sid $
SelectionDef $
DefSelection (qualifyName scope "tm1") $
Just $
NodeSelection BodyNode htm1
zeroTKIds tm1tk
@?= zeroTKIds
( Type
$ Mismatch
( Type $
Mismatch
{ got = viewTreeType $ create' $ tcon tNat
, expected = viewTreeType $ create' $ tcon tBool
}
Expand All @@ -952,15 +952,15 @@ test_selectioninfo =
e -> assertFailure' $ "unexpected form of tm2: " <> show e
step "tm2 mismatch info"
tm2tk <-
getSelectionTypeOrKind sid
$ SelectionDef
$ DefSelection (qualifyName scope "tm2")
$ Just
$ NodeSelection BodyNode htm2
getSelectionTypeOrKind sid $
SelectionDef $
DefSelection (qualifyName scope "tm2") $
Just $
NodeSelection BodyNode htm2
zeroTKIds tm2tk
@?= zeroTKIds
( Type
$ Mismatch
( Type $
Mismatch
{ got = viewTreeType $ create' $ tcon tNat
, -- We require @expected@ to be an empty hole, matching
-- the behaviour of @? True@
Expand Down Expand Up @@ -990,15 +990,15 @@ test_selectioninfo =
e -> assertFailure' $ "unexpected form of ty1: " <> show e
step "ty1 mismatch info"
ty1tk <-
getSelectionTypeOrKind sid
$ SelectionDef
$ DefSelection (qualifyName scope "ty1")
$ Just
$ NodeSelection SigNode hty1
getSelectionTypeOrKind sid $
SelectionDef $
DefSelection (qualifyName scope "ty1") $
Just $
NodeSelection SigNode hty1
zeroTKIds ty1tk
@?= zeroTKIds
( Kind
$ Mismatch
( Kind $
Mismatch
{ got = viewTreeKind $ create' $ ktype `kfun` ktype
, expected = viewTreeKind $ create' ktype
}
Expand All @@ -1024,15 +1024,15 @@ test_selectioninfo =
e -> assertFailure' $ "unexpected form of ty2: " <> show e
step "ty2 mismatch info"
ty2tk <-
getSelectionTypeOrKind sid
$ SelectionDef
$ DefSelection (qualifyName scope "ty2")
$ Just
$ NodeSelection SigNode hty2
getSelectionTypeOrKind sid $
SelectionDef $
DefSelection (qualifyName scope "ty2") $
Just $
NodeSelection SigNode hty2
zeroTKIds ty2tk
@?= zeroTKIds
( Kind
$ Mismatch
( Kind $
Mismatch
{ got = viewTreeKind $ create' ktype
, -- We require @expected@ to be @?@, matching the behaviour of an empty hole.
-- Arguably we should change both this and the empty hole case to
Expand Down
Loading