ace7680 · project-m36 · git.iko.soy

git.iko.soy/project-m36

update codebase for hlint 2.1.1

lots of <$> changes

commitace7680414dde2120678656ea9be5db48a69b1de authorAgentM <agentm@themactionfaction.com> dateSun 25 Mar 2018, 23:17 (9 years ago) parent574ffd5

15 files changed+57−79

compare with master

unifiedsplit

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs+1−3

@@ -103,9 +103,7 @@ instance FromJSON Atom where

103103 case atype of

104104 TypeVariableType _ -> fail "cannot pass TypeVariableType over the wire"

105105 caType@(ConstructedAtomType _ _) -> ConstructedAtom <$> o .: "dataconstructorname" <*> pure caType <*> o .: "atom"

106− RelationAtomType _ -> do

107− rel <- o .: "val"

108− pure $ RelationAtom rel

106+ RelationAtomType _ -> RelationAtom <$> o .: "val"

109107 IntAtomType -> IntAtom <$> o .: "val"

110108 IntegerAtomType -> IntegerAtom <$> o .: "val"

111109 DoubleAtomType -> DoubleAtom <$> o .: "val"

src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+2−3

@@ -54,9 +54,8 @@ multilineSep :: Parser T.Text

5454multilineSep = newline >> pure "\n"

5555

5656multipleDatabaseContextExprP :: Parser DatabaseContextExpr

57−multipleDatabaseContextExprP = do

58− exprs <- sepBy1 databaseContextExprP semi

59− pure $ MultipleExpr exprs

57+multipleDatabaseContextExprP =

58+ MultipleExpr <$> sepBy1 databaseContextExprP semi

6059

6160insertP :: Parser DatabaseContextExpr

6261insertP = do

src/bin/TutorialD/Interpreter/RelationalExpr.hs+1−3

@@ -66,9 +66,7 @@ tupleAtomExprP = do

6666 pure (attributeName, atomExpr)

6767

6868projectP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)

69−projectP = do

70− attrs <- braces attributeListP

71− pure $ Project attrs

69+projectP = Project <$> braces attributeListP

7270

7371renameClauseP :: Parser (T.Text, T.Text)

7472renameClauseP = do

src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs+1−3

@@ -29,9 +29,7 @@ transactionIdHeadBacktrackP = (string "~" *> (TransactionIdHeadParentBacktrack <

2929 (string "@" *> (TransactionStampHeadBacktrack <$> utcTimeP))

3030

3131backtrackP :: Parser Int

32−backtrackP = do

33− steps <- integer <|> pure 1

34− pure (fromIntegral steps)

32+backtrackP = fromIntegral <$> integer <|> pure 1

3533

3634transGraphRelationalOpP :: Parser TransGraphRelationalOperator

3735transGraphRelationalOpP = showTransGraphRelationalOpP

src/lib/ProjectM36/AtomType.hs+6−9

@@ -37,9 +37,8 @@ atomTypeForDataConstructorName :: DataConstructorName -> [AtomType] -> TypeConst

3737atomTypeForDataConstructorName dConsName atomTypesIn tConsList =

3838 case findDataConstructor dConsName tConsList of

3939 Nothing -> Left (NoSuchDataConstructorError dConsName)

40− Just (tCons, dCons) -> do

41− typeVars <- resolveDataConstructorTypeVars dCons atomTypesIn tConsList

42− pure (ConstructedAtomType (TCD.name tCons) typeVars)

40+ Just (tCons, dCons) ->

41+ ConstructedAtomType (TCD.name tCons) <$> resolveDataConstructorTypeVars dCons atomTypesIn tConsList

4342

4443atomTypeForDataConstructorDefArg :: DataConstructorDefArg -> AtomType -> TypeConstructorMapping -> Either RelationalError AtomType

4544atomTypeForDataConstructorDefArg (DataConstructorDefTypeConstructorArg tCons) aType tConss =

@@ -65,10 +64,9 @@ atomTypeForDataConstructor tConss dConsName atomArgTypes =

6564 --lookup the data constructor

6665 case findDataConstructor dConsName tConss of

6766 Nothing -> Left (NoSuchDataConstructorError dConsName)

68− Just (tCons, dCons) -> do

67+ Just (tCons, dCons) ->

6968 --validate that the type constructor arguments are fulfilled in the data constructor

70− typeVars <- resolveDataConstructorTypeVars dCons atomArgTypes tConss

71− pure (ConstructedAtomType (TCD.name tCons) typeVars)

69+ ConstructedAtomType (TCD.name tCons) <$> resolveDataConstructorTypeVars dCons atomArgTypes tConss

7270

7371-- | Walks the data and type constructors to extract the type variable map.

7472resolveDataConstructorTypeVars :: DataConstructorDef -> [AtomType] -> TypeConstructorMapping -> Either RelationalError TypeVarMap

@@ -156,9 +154,8 @@ findTypeConstructor name = foldr tConsFolder Nothing

156154 accum

157155

158156resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType

159−resolveAtomType (ConstructedAtomType tConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) = do

160− tVarMap <- resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

161− pure (ConstructedAtomType tConsName tVarMap)

157+resolveAtomType (ConstructedAtomType tConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) =

158+ ConstructedAtomType tConsName <$> resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap

162159resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then

163160 Right typeFromRelation

164161 else

src/lib/ProjectM36/Client.hs+5−8

@@ -330,8 +330,7 @@ connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId notific

330330 liftIO $ putMVar connStatus (Left LoginError)

331331 else

332332 liftIO $ putMVar connStatus (Right $ RemoteProcessConnection RemoteProcessConnectionConf {rLocalNode = localNode, rProcessId = serverProcessId, rTransport = transport})

333− status <- takeMVar connStatus

334− pure status

333+ takeMVar connStatus

335334

336335connectPersistentProjectM36 :: PersistenceStrategy ->

337336 DiskSync ->

@@ -481,9 +480,8 @@ remoteCall (RemoteProcessConnection conf) arg = runProcessResult localNode $ do

481480 serverProcessId = rProcessId conf

482481

483482sessionForSessionId :: SessionId -> Sessions -> STM (Either RelationalError Session)

484−sessionForSessionId sessionId sessions = do

485− maybeSession <- STMMap.lookup sessionId sessions

486− pure $ maybe (Left $ NoSuchSessionError sessionId) Right maybeSession

483+sessionForSessionId sessionId sessions =

484+ maybe (Left $ NoSuchSessionError sessionId) Right <$> STMMap.lookup sessionId sessions

487485

488486schemaForSessionId :: Session -> STM (Either RelationalError Schema)

489487schemaForSessionId session = do

@@ -890,9 +888,8 @@ transactionGraphAsRelation sessionId (InProcessConnection conf) = do

890888 eSession <- sessionForSessionId sessionId sessions

891889 case eSession of

892890 Left err -> pure $ Left err

893− Right session -> do

894− graph <- readTVar tvar

895− pure $ graphAsRelation (Sess.disconnectedTransaction session) graph

891+ Right session ->

892+ graphAsRelation (Sess.disconnectedTransaction session) <$> readTVar tvar

896893

897894transactionGraphAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveTransactionGraph sessionId)

898895

src/lib/ProjectM36/DataTypes/Interval.hs+2−3

@@ -89,9 +89,8 @@ intervalAtomFunctions = HS.fromList [

8989 atomFuncType = [IntervalAtomType (TypeVariableType "a"),

9090 IntervalAtomType (TypeVariableType "a"),

9191 BoolAtomType],

92− atomFuncBody = compiledAtomFunctionBody $ \(i1@IntervalAtom{}:i2@IntervalAtom{}:_) -> do

93− res <- intervalOverlaps i1 i2

94− pure (BoolAtom res)

92+ atomFuncBody = compiledAtomFunctionBody $ \(i1@IntervalAtom{}:i2@IntervalAtom{}:_) ->

93+ BoolAtom <$> intervalOverlaps i1 i2

9594 }]

9695

9796

src/lib/ProjectM36/DataTypes/List.hs+2−3

@@ -37,9 +37,8 @@ listAtomFunctions = HS.fromList [

3737 AtomFunction {

3838 atomFuncName = "length",

3939 atomFuncType = [listAtomType (TypeVariableType "a"), IntAtomType],

40− atomFuncBody = AtomFunctionBody Nothing (\(listAtom:_) -> do

41− c <- listLength listAtom

42− pure (IntAtom (fromIntegral c)))

40+ atomFuncBody = AtomFunctionBody Nothing (\(listAtom:_) ->

41+ IntAtom . fromIntegral <$> listLength listAtom)

4342 },

4443 AtomFunction {

4544 atomFuncName = "maybeHead",

src/lib/ProjectM36/Relation.hs+2−3

@@ -317,9 +317,8 @@ relationVariablesAsRelation relVarMap = mkRelationFromList attrs tups

317317

318318-- | Randomly resort the tuples. This is useful for emphasizing that two relations are equal even when they are printed to the console in different orders.

319319randomizeTupleOrder :: MonadRandom m => Relation -> m Relation

320−randomizeTupleOrder (Relation attrs tupSet) = do

321− newTupSet <- shuffleM (asList tupSet)

322− pure (Relation attrs (RelationTupleSet newTupSet))

320+randomizeTupleOrder (Relation attrs tupSet) =

321+ Relation attrs . RelationTupleSet <$> shuffleM (asList tupSet)

323322

324323-- returns a tuple from the tupleset- this is useful for priming folds over the tuples

325324oneTuple :: Relation -> Maybe RelationTuple

src/lib/ProjectM36/Relation/Parse/CSV.hs+5−5

@@ -60,9 +60,8 @@ parseCSVAtomP :: AttributeName -> TypeConstructorMapping -> AtomType -> APT.Pars

6060parseCSVAtomP _ _ IntegerAtomType = Right . IntegerAtom <$> APT.decimal

6161parseCSVAtomP _ _ IntAtomType = Right . IntAtom <$> APT.decimal

6262parseCSVAtomP _ _ DoubleAtomType = Right . DoubleAtom <$> APT.double

63−parseCSVAtomP _ _ TextAtomType = do

64− s <- quotedString <|> takeToEndOfData

65− pure (Right (TextAtom s))

63+parseCSVAtomP _ _ TextAtomType =

64+ Right . TextAtom <$> (quotedString <|> takeToEndOfData)

6665parseCSVAtomP _ _ DayAtomType = do

6766 dString <- T.unpack <$> takeToEndOfData

6867 case readMaybe dString of

@@ -94,8 +93,9 @@ parseCSVAtomP attrName tConsMap (IntervalAtomType iType) = do

9493 case eEndv of

9594 Left err -> pure (Left err)

9695 Right endv -> do

97− end <- (APT.char ']' >> pure False) <|> (APT.char ')' >> pure True)

98− pure (Right (IntervalAtom beginv endv begin end))

96+ let end = (APT.char ']' >> pure False) <|>

97+ (APT.char ')' >> pure True)

98+ Right . IntervalAtom beginv endv begin <$> end

9999parseCSVAtomP attrName tConsMap typ@(ConstructedAtomType _ tvmap) = do

100100 dConsName <- capitalizedIdentifier

101101 APT.skipSpace

src/lib/ProjectM36/RelationalExpression.hs+4−8

@@ -161,9 +161,8 @@ evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

161161 -- if the mAttrExprs is Nothing, then we should attempt to infer the tuple attributes from the first tuple itself- note that this is not always possible

162162 runExceptT $ do

163163 mAttrs <- case mAttrExprs of

164− Just _ -> do

165− attrs <- mapM (either throwE pure . evalAttrExpr tConss) (fromMaybe [] mAttrExprs)

166− pure (Just (A.attributesFromList attrs))

164+ Just _ ->

165+ Just . A.attributesFromList <$> mapM (either throwE pure . evalAttrExpr tConss) (fromMaybe [] mAttrExprs)

167166 Nothing -> pure Nothing

168167 tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs

169168 let attrs = fromMaybe firstTupleAttrs mAttrs

@@ -646,9 +645,7 @@ predicateRestrictionFilter _ TruePredicate = pure (Right (\_ -> pure True))

646645predicateRestrictionFilter attrs (NotPredicate expr) =

647646 runExceptT $ do

648647 exprv <- liftE (predicateRestrictionFilter attrs expr)

649− pure (\x -> do

650− ev <- exprv x

651− pure (not ev))

648+ pure (fmap not . exprv)

652649

653650--optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here

654651predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do

@@ -813,8 +810,7 @@ typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =

813810 runExceptT $ do

814811 argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs

815812 context <- fmap stateElemsContext (lift ask)

816− aType <- either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)

817− pure aType

813+ either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)

818814

819815-- | Validate that the type of the AtomExpr matches the expected type.

820816verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType)

src/lib/ProjectM36/ScriptSession.hs+2−3

@@ -158,12 +158,11 @@ compileScript funcType script = do

158158 mErr <- typeCheckScript funcType script

159159 case mErr of

160160 Just err -> pure (Left err)

161− Nothing -> do

161+ Nothing ->

162162 --catch exception here

163163 --we could potentially wrap the script with Atom pattern matching so that the script doesn't have to do it, but the change to an Atom ADT should make it easier. Still, it would be nice if the script didn't have to handle a list of arguments, for example.

164164 -- we can't use dynCompileExpr here because

165− func <- compileExpr sScript

166− pure $ Right (unsafeCoerce func)

165+ Right . unsafeCoerce <$> compileExpr sScript

167166

168167typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError)

169168typeCheckScript expectedType inp = do

src/lib/ProjectM36/TransGraphRelationalExpression.hs+18−18

@@ -68,8 +68,8 @@ evalTransGraphRelationalExpr (Join exprA exprB) graph = do

6868 exprB' <- evalTransGraphRelationalExpr exprB graph

6969 pure (Join exprA' exprB')

7070evalTransGraphRelationalExpr (Rename attrName1 attrName2 expr) graph = do

71− expr' <- evalTransGraphRelationalExpr expr graph

72− pure (Rename attrName1 attrName2 expr')

71+ let expr' = evalTransGraphRelationalExpr expr graph

72+ Rename attrName1 attrName2 <$> expr'

7373evalTransGraphRelationalExpr (Difference exprA exprB) graph = do

7474 exprA' <- evalTransGraphRelationalExpr exprA graph

7575 exprB' <- evalTransGraphRelationalExpr exprB graph

@@ -79,8 +79,8 @@ evalTransGraphRelationalExpr (Group transAttrNames attrName expr) graph = do

7979 attrNames <- evalTransAttributeNames transAttrNames graph

8080 pure (Group attrNames attrName expr')

8181evalTransGraphRelationalExpr (Ungroup attrName expr) graph = do

82− expr' <- evalTransGraphRelationalExpr expr graph

83− pure (Ungroup attrName expr')

82+ let expr' = evalTransGraphRelationalExpr expr graph

83+ Ungroup attrName <$> expr'

8484evalTransGraphRelationalExpr (Restrict predicateExpr expr) graph = do

8585 expr' <- evalTransGraphRelationalExpr expr graph

8686 predicateExpr' <- evalTransGraphRestrictionPredicateExpr predicateExpr graph

@@ -100,11 +100,11 @@ evalTransGraphRelationalExpr (Extend extendExpr expr) graph = do

100100

101101evalTransGraphTupleExpr :: TransactionGraph -> TransGraphTupleExpr -> Either RelationalError TupleExpr

102102evalTransGraphTupleExpr graph (TupleExpr attrMap) = do

103− attrAssoc <- mapM (\(attrName, atomExpr) -> do

103+ let attrAssoc = mapM (\(attrName, atomExpr) -> do

104104 aExpr <- evalTransGraphAtomExpr graph atomExpr

105105 pure (attrName, aExpr)

106106 ) (M.toList attrMap)

107− pure (TupleExpr (M.fromList attrAssoc))

107+ TupleExpr . M.fromList <$> attrAssoc

108108

109109evalTransGraphAtomExpr :: TransactionGraph -> TransGraphAtomExpr -> Either RelationalError AtomExpr

110110evalTransGraphAtomExpr _ (AttributeAtomExpr aname) = pure $ AttributeAtomExpr aname

@@ -116,8 +116,8 @@ evalTransGraphAtomExpr graph (FunctionAtomExpr funcName args tLookup) = do

116116 atom <- runReader (evalAtomExpr emptyTuple (FunctionAtomExpr funcName args' ())) (RelationalExprStateElems (concreteDatabaseContext trans))

117117 pure (NakedAtomExpr atom)

118118evalTransGraphAtomExpr graph (RelationAtomExpr expr) = do

119− expr' <- evalTransGraphRelationalExpr expr graph

120− pure (RelationAtomExpr expr')

119+ let expr' = evalTransGraphRelationalExpr expr graph

120+ RelationAtomExpr <$> expr'

121121evalTransGraphAtomExpr graph (ConstructedAtomExpr dConsName args tLookup) = do

122122 trans <- lookupTransaction graph tLookup

123123 args' <- mapM (evalTransGraphAtomExpr graph) args

@@ -135,22 +135,22 @@ evalTransGraphRestrictionPredicateExpr (OrPredicate exprA exprB) graph = do

135135 exprB' <- evalTransGraphRestrictionPredicateExpr exprB graph

136136 pure (OrPredicate exprA' exprB')

137137evalTransGraphRestrictionPredicateExpr (NotPredicate expr) graph = do

138− expr' <- evalTransGraphRestrictionPredicateExpr expr graph

139− pure (NotPredicate expr')

138+ let expr' = evalTransGraphRestrictionPredicateExpr expr graph

139+ NotPredicate <$> expr'

140140evalTransGraphRestrictionPredicateExpr (RelationalExprPredicate expr) graph = do

141− expr' <- evalTransGraphRelationalExpr expr graph

142− pure (RelationalExprPredicate expr')

141+ let expr' = evalTransGraphRelationalExpr expr graph

142+ RelationalExprPredicate <$> expr'

143143evalTransGraphRestrictionPredicateExpr (AtomExprPredicate expr) graph = do

144− expr' <- evalTransGraphAtomExpr graph expr

145− pure (AtomExprPredicate expr')

144+ let expr' = evalTransGraphAtomExpr graph expr

145+ AtomExprPredicate <$> expr'

146146evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr) graph = do

147− expr' <- evalTransGraphAtomExpr graph expr

148− pure (AttributeEqualityPredicate attrName expr')

147+ let expr' = evalTransGraphAtomExpr graph expr

148+ AttributeEqualityPredicate attrName <$> expr'

149149

150150evalTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransactionGraph -> Either RelationalError ExtendTupleExpr

151151evalTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) graph = do

152− expr' <- evalTransGraphAtomExpr graph expr

153− pure (AttributeExtendTupleExpr attrName expr')

152+ let expr' = evalTransGraphAtomExpr graph expr

153+ AttributeExtendTupleExpr attrName <$> expr'

154154

155155evalTransGraphAttributeExpr :: TransactionGraph -> TransGraphAttributeExpr -> Either RelationalError AttributeExpr

156156evalTransGraphAttributeExpr graph (AttributeAndTypeNameExpr attrName tCons tLookup) = do

src/lib/ProjectM36/TransactionGraph.hs+2−2

@@ -321,8 +321,8 @@ evalROGraphOp discon graph ShowGraph = do

321321-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph

322322createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

323323createMergeTransaction stamp newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do

324− selectedTrans <- validateHeadName selectedBranch graph t2

325− pure $ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty stamp) (schemas selectedTrans)

324+ let selectedTrans = validateHeadName selectedBranch graph t2

325+ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty stamp) . schemas <$> selectedTrans

326326

327327-- merge functions, relvars, individually

328328createMergeTransaction stamp newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp newId strat graph t2

src/lib/ProjectM36/TransactionGraph/Persist.hs+4−5

@@ -83,9 +83,8 @@ setupDatabaseDir sync dbdir bootstrapGraph = do

8383 locker <- openLockFile (lockFilePath dbdir)

8484 gDigest <- bracket_ (lockFile locker WriteLock) (unlockFile locker) (readGraphTransactionIdFileDigest dbdir)

8585 pure (Right (locker, gDigest))

86− else if not m36exists then do

87− locks <- bootstrapDatabaseDir sync dbdir bootstrapGraph

88− pure (Right locks)

86+ else if not m36exists then

87+ Right <$> bootstrapDatabaseDir sync dbdir bootstrapGraph

8988 else

9089 pure (Left (InvalidDirectoryError dbdir))

9190{-

@@ -201,8 +200,8 @@ writeGraphTransactionIdFile sync destDirectory (TransactionGraph _ transSet) = w

201200

202201readGraphTransactionIdFileDigest :: FilePath -> IO LockFileHash

203202readGraphTransactionIdFileDigest dbdir = do

204− graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir)

205− pure (SHA256.hash (encodeUtf8 graphTransactionIdData))

203+ let graphTransactionIdData = TIO.readFile (transactionLogPath dbdir)

204+ SHA256.hash . encodeUtf8 <$> graphTransactionIdData

206205

207206readGraphTransactionIdFile :: FilePath -> IO (Either PersistenceError [(TransactionId, UTCTime, [TransactionId])])

208207readGraphTransactionIdFile dbdir = do